From 9f0f000b2139ed22e791b876e990a9c16426f9d2 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 22 Feb 2022 19:12:17 +0100 Subject: [PATCH] Add C versions as fallback --- lapack-netlib/TESTING/MATGEN/Makefile | 7 + lapack-netlib/TESTING/MATGEN/clagge.c | 908 ++++++++++ lapack-netlib/TESTING/MATGEN/claghe.c | 741 +++++++++ lapack-netlib/TESTING/MATGEN/clagsy.c | 794 +++++++++ lapack-netlib/TESTING/MATGEN/clahilb.c | 711 ++++++++ lapack-netlib/TESTING/MATGEN/clahilb.f | 15 +- lapack-netlib/TESTING/MATGEN/clakf2.c | 621 +++++++ lapack-netlib/TESTING/MATGEN/clarge.c | 586 +++++++ lapack-netlib/TESTING/MATGEN/clarnd.c | 540 ++++++ lapack-netlib/TESTING/MATGEN/claror.c | 783 +++++++++ lapack-netlib/TESTING/MATGEN/clarot.c | 771 +++++++++ lapack-netlib/TESTING/MATGEN/clatm1.c | 732 +++++++++ lapack-netlib/TESTING/MATGEN/clatm2.c | 740 +++++++++ lapack-netlib/TESTING/MATGEN/clatm3.c | 758 +++++++++ lapack-netlib/TESTING/MATGEN/clatm5.c | 1158 +++++++++++++ lapack-netlib/TESTING/MATGEN/clatm6.c | 815 +++++++++ lapack-netlib/TESTING/MATGEN/clatme.c | 1094 ++++++++++++ lapack-netlib/TESTING/MATGEN/clatmr.c | 1980 ++++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/clatms.c | 2092 +++++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/clatmt.c | 2100 +++++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/dlagge.c | 847 ++++++++++ lapack-netlib/TESTING/MATGEN/dlagsy.c | 706 ++++++++ lapack-netlib/TESTING/MATGEN/dlahilb.c | 626 +++++++ lapack-netlib/TESTING/MATGEN/dlakf2.c | 615 +++++++ lapack-netlib/TESTING/MATGEN/dlaran.c | 526 ++++++ lapack-netlib/TESTING/MATGEN/dlarge.c | 581 +++++++ lapack-netlib/TESTING/MATGEN/dlarnd.c | 508 ++++++ lapack-netlib/TESTING/MATGEN/dlaror.c | 721 ++++++++ lapack-netlib/TESTING/MATGEN/dlarot.c | 709 ++++++++ lapack-netlib/TESTING/MATGEN/dlatm1.c | 698 ++++++++ lapack-netlib/TESTING/MATGEN/dlatm2.c | 698 ++++++++ lapack-netlib/TESTING/MATGEN/dlatm3.c | 716 ++++++++ lapack-netlib/TESTING/MATGEN/dlatm5.c | 981 +++++++++++ lapack-netlib/TESTING/MATGEN/dlatm6.c | 750 +++++++++ lapack-netlib/TESTING/MATGEN/dlatm7.c | 699 ++++++++ lapack-netlib/TESTING/MATGEN/dlatme.c | 1158 +++++++++++++ lapack-netlib/TESTING/MATGEN/dlatmr.c | 1768 ++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/dlatms.c | 1769 ++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/dlatmt.c | 1780 ++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/slagge.c | 845 ++++++++++ lapack-netlib/TESTING/MATGEN/slagsy.c | 702 ++++++++ lapack-netlib/TESTING/MATGEN/slahilb.c | 626 +++++++ lapack-netlib/TESTING/MATGEN/slakf2.c | 614 +++++++ lapack-netlib/TESTING/MATGEN/slaran.c | 527 ++++++ lapack-netlib/TESTING/MATGEN/slarge.c | 579 +++++++ lapack-netlib/TESTING/MATGEN/slarnd.c | 508 ++++++ lapack-netlib/TESTING/MATGEN/slaror.c | 718 ++++++++ lapack-netlib/TESTING/MATGEN/slarot.c | 709 ++++++++ lapack-netlib/TESTING/MATGEN/slatm1.c | 699 ++++++++ lapack-netlib/TESTING/MATGEN/slatm2.c | 698 ++++++++ lapack-netlib/TESTING/MATGEN/slatm3.c | 716 ++++++++ lapack-netlib/TESTING/MATGEN/slatm5.c | 972 +++++++++++ lapack-netlib/TESTING/MATGEN/slatm6.c | 748 +++++++++ lapack-netlib/TESTING/MATGEN/slatm7.c | 701 ++++++++ lapack-netlib/TESTING/MATGEN/slatme.c | 1152 +++++++++++++ lapack-netlib/TESTING/MATGEN/slatmr.c | 1768 ++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/slatms.c | 1765 ++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/slatmt.c | 1776 ++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/zlagge.c | 909 ++++++++++ lapack-netlib/TESTING/MATGEN/zlaghe.c | 745 +++++++++ lapack-netlib/TESTING/MATGEN/zlagsy.c | 796 +++++++++ lapack-netlib/TESTING/MATGEN/zlahilb.c | 711 ++++++++ lapack-netlib/TESTING/MATGEN/zlahilb.f | 15 +- lapack-netlib/TESTING/MATGEN/zlakf2.c | 622 +++++++ lapack-netlib/TESTING/MATGEN/zlarge.c | 587 +++++++ lapack-netlib/TESTING/MATGEN/zlarnd.c | 542 ++++++ lapack-netlib/TESTING/MATGEN/zlaror.c | 788 +++++++++ lapack-netlib/TESTING/MATGEN/zlarot.c | 771 +++++++++ lapack-netlib/TESTING/MATGEN/zlatm1.c | 731 ++++++++ lapack-netlib/TESTING/MATGEN/zlatm2.c | 741 +++++++++ lapack-netlib/TESTING/MATGEN/zlatm3.c | 759 +++++++++ lapack-netlib/TESTING/MATGEN/zlatm5.c | 1161 +++++++++++++ lapack-netlib/TESTING/MATGEN/zlatm6.c | 817 +++++++++ lapack-netlib/TESTING/MATGEN/zlatme.c | 1097 ++++++++++++ lapack-netlib/TESTING/MATGEN/zlatmr.c | 1984 ++++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/zlatms.c | 2096 +++++++++++++++++++++++ lapack-netlib/TESTING/MATGEN/zlatmt.c | 2104 ++++++++++++++++++++++++ 77 files changed, 69587 insertions(+), 14 deletions(-) create mode 100644 lapack-netlib/TESTING/MATGEN/clagge.c create mode 100644 lapack-netlib/TESTING/MATGEN/claghe.c create mode 100644 lapack-netlib/TESTING/MATGEN/clagsy.c create mode 100644 lapack-netlib/TESTING/MATGEN/clahilb.c create mode 100644 lapack-netlib/TESTING/MATGEN/clakf2.c create mode 100644 lapack-netlib/TESTING/MATGEN/clarge.c create mode 100644 lapack-netlib/TESTING/MATGEN/clarnd.c create mode 100644 lapack-netlib/TESTING/MATGEN/claror.c create mode 100644 lapack-netlib/TESTING/MATGEN/clarot.c create mode 100644 lapack-netlib/TESTING/MATGEN/clatm1.c create mode 100644 lapack-netlib/TESTING/MATGEN/clatm2.c create mode 100644 lapack-netlib/TESTING/MATGEN/clatm3.c create mode 100644 lapack-netlib/TESTING/MATGEN/clatm5.c create mode 100644 lapack-netlib/TESTING/MATGEN/clatm6.c create mode 100644 lapack-netlib/TESTING/MATGEN/clatme.c create mode 100644 lapack-netlib/TESTING/MATGEN/clatmr.c create mode 100644 lapack-netlib/TESTING/MATGEN/clatms.c create mode 100644 lapack-netlib/TESTING/MATGEN/clatmt.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlagge.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlagsy.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlahilb.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlakf2.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlaran.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlarge.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlarnd.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlaror.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlarot.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlatm1.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlatm2.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlatm3.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlatm5.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlatm6.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlatm7.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlatme.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlatmr.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlatms.c create mode 100644 lapack-netlib/TESTING/MATGEN/dlatmt.c create mode 100644 lapack-netlib/TESTING/MATGEN/slagge.c create mode 100644 lapack-netlib/TESTING/MATGEN/slagsy.c create mode 100644 lapack-netlib/TESTING/MATGEN/slahilb.c create mode 100644 lapack-netlib/TESTING/MATGEN/slakf2.c create mode 100644 lapack-netlib/TESTING/MATGEN/slaran.c create mode 100644 lapack-netlib/TESTING/MATGEN/slarge.c create mode 100644 lapack-netlib/TESTING/MATGEN/slarnd.c create mode 100644 lapack-netlib/TESTING/MATGEN/slaror.c create mode 100644 lapack-netlib/TESTING/MATGEN/slarot.c create mode 100644 lapack-netlib/TESTING/MATGEN/slatm1.c create mode 100644 lapack-netlib/TESTING/MATGEN/slatm2.c create mode 100644 lapack-netlib/TESTING/MATGEN/slatm3.c create mode 100644 lapack-netlib/TESTING/MATGEN/slatm5.c create mode 100644 lapack-netlib/TESTING/MATGEN/slatm6.c create mode 100644 lapack-netlib/TESTING/MATGEN/slatm7.c create mode 100644 lapack-netlib/TESTING/MATGEN/slatme.c create mode 100644 lapack-netlib/TESTING/MATGEN/slatmr.c create mode 100644 lapack-netlib/TESTING/MATGEN/slatms.c create mode 100644 lapack-netlib/TESTING/MATGEN/slatmt.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlagge.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlaghe.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlagsy.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlahilb.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlakf2.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlarge.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlarnd.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlaror.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlarot.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlatm1.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlatm2.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlatm3.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlatm5.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlatm6.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlatme.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlatmr.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlatms.c create mode 100644 lapack-netlib/TESTING/MATGEN/zlatmt.c diff --git a/lapack-netlib/TESTING/MATGEN/Makefile b/lapack-netlib/TESTING/MATGEN/Makefile index 0b94e3aaa..351757d28 100644 --- a/lapack-netlib/TESTING/MATGEN/Makefile +++ b/lapack-netlib/TESTING/MATGEN/Makefile @@ -33,6 +33,13 @@ TOPSRCDIR = ../.. include $(TOPSRCDIR)/make.inc +ifneq ($(C_LAPACK), 1) +.SUFFIXES: +.SUFFIXES: .f .o +.f.o: + $(FC) $(FFLAGS) -c -o $@ $< +endif + ifneq "$(or $(BUILD_SINGLE),$(BUILD_COMPLEX))" "" SCATGEN = slatm1.o slatm7.o slaran.o slarnd.o endif diff --git a/lapack-netlib/TESTING/MATGEN/clagge.c b/lapack-netlib/TESTING/MATGEN/clagge.c new file mode 100644 index 000000000..4ff535d8c --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clagge.c @@ -0,0 +1,908 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLAGGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, KL, KU, LDA, M, N */ +/* INTEGER ISEED( 4 ) */ +/* REAL D( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAGGE generates a complex general m by n matrix A, by pre- and post- */ +/* > multiplying a real diagonal matrix D with random unitary matrices: */ +/* > A = U*D*V. The lower and upper bandwidths may then be reduced to */ +/* > kl and ku by additional unitary transformations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of nonzero subdiagonals within the band of A. */ +/* > 0 <= KL <= M-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of nonzero superdiagonals within the band of A. */ +/* > 0 <= KU <= N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (f2cmin(M,N)) */ +/* > The diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The generated m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (M+N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clagge_(integer *m, integer *n, integer *kl, integer *ku, + real *d__, complex *a, integer *lda, integer *iseed, complex *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1; + complex q__1; + + /* Local variables */ + integer i__, j; + extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *), + cscal_(integer *, complex *, complex *, integer *), cgemv_(char * + , integer *, integer *, complex *, complex *, integer *, complex * + , integer *, complex *, complex *, integer *); + extern real scnrm2_(integer *, complex *, integer *); + complex wa, wb; + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *); + real wn; + extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_( + integer *, integer *, integer *, complex *); + complex tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0 || *kl > *m - 1) { + *info = -3; + } else if (*ku < 0 || *ku > *n - 1) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -7; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("CLAGGE", &i__1); + return 0; + } + +/* initialize A to diagonal matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + i__1 = f2cmin(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + i__3 = i__; + a[i__2].r = d__[i__3], a[i__2].i = 0.f; +/* L30: */ + } + +/* Quick exit if the user wants a diagonal matrix */ + + if (*kl == 0 && *ku == 0) { + return 0; + } + +/* pre- and post-multiply A by random unitary matrices */ + + for (i__ = f2cmin(*m,*n); i__ >= 1; --i__) { + if (i__ < *m) { + +/* generate random reflection */ + + i__1 = *m - i__ + 1; + clarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *m - i__ + 1; + wn = scnrm2_(&i__1, &work[1], &c__1); + r__1 = wn / c_abs(&work[1]); + q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__1 = *m - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__1, &q__1, &work[2], &c__1); + work[1].r = 1.f, work[1].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* multiply A(i:m,i:n) by random reflection from the left */ + + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + cgemv_("Conjugate transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * + a_dim1], lda, &work[1], &c__1, &c_b1, &work[*m + 1], & + c__1); + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&i__1, &i__2, &q__1, &work[1], &c__1, &work[*m + 1], &c__1, + &a[i__ + i__ * a_dim1], lda); + } + if (i__ < *n) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + clarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = scnrm2_(&i__1, &work[1], &c__1); + r__1 = wn / c_abs(&work[1]); + q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__1 = *n - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__1, &q__1, &work[2], &c__1); + work[1].r = 1.f, work[1].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* multiply A(i:m,i:n) by random reflection from the right */ + + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + cgemv_("No transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * a_dim1] + , lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1); + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&i__1, &i__2, &q__1, &work[*n + 1], &c__1, &work[1], &c__1, + &a[i__ + i__ * a_dim1], lda); + } +/* L40: */ + } + +/* Reduce number of subdiagonals to KL and number of superdiagonals */ +/* to KU */ + +/* Computing MAX */ + i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku; + i__1 = f2cmax(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + if (*kl <= *ku) { + +/* annihilate subdiagonal elements first (necessary if KL = 0) */ + +/* Computing MIN */ + i__2 = *m - 1 - *kl; + if (i__ <= f2cmin(i__2,*n)) { + +/* generate reflection to annihilate A(kl+i+1:m,i) */ + + i__2 = *m - *kl - i__ + 1; + wn = scnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1); + r__1 = wn / c_abs(&a[*kl + i__ + i__ * a_dim1]); + i__2 = *kl + i__ + i__ * a_dim1; + q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + i__2 = *kl + i__ + i__ * a_dim1; + q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__2 = *m - *kl - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__2, &q__1, &a[*kl + i__ + 1 + i__ * a_dim1], & + c__1); + i__2 = *kl + i__ + i__ * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* apply reflection to A(kl+i:m,i+1:n) from the left */ + + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl + + i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * + a_dim1], &c__1, &c_b1, &work[1], &c__1); + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&i__2, &i__3, &q__1, &a[*kl + i__ + i__ * a_dim1], & + c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * + a_dim1], lda); + i__2 = *kl + i__ + i__ * a_dim1; + q__1.r = -wa.r, q__1.i = -wa.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + +/* Computing MIN */ + i__2 = *n - 1 - *ku; + if (i__ <= f2cmin(i__2,*m)) { + +/* generate reflection to annihilate A(i,ku+i+1:n) */ + + i__2 = *n - *ku - i__ + 1; + wn = scnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + r__1 = wn / c_abs(&a[i__ + (*ku + i__) * a_dim1]); + i__2 = i__ + (*ku + i__) * a_dim1; + q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + i__2 = i__ + (*ku + i__) * a_dim1; + q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__2 = *n - *ku - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__2, &q__1, &a[i__ + (*ku + i__ + 1) * a_dim1], + lda); + i__2 = i__ + (*ku + i__) * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* apply reflection to A(i+1:m,ku+i:n) from the right */ + + i__2 = *n - *ku - i__ + 1; + clacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku + + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1], + lda, &c_b1, &work[1], &c__1); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&i__2, &i__3, &q__1, &work[1], &c__1, &a[i__ + (*ku + + i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * + a_dim1], lda); + i__2 = i__ + (*ku + i__) * a_dim1; + q__1.r = -wa.r, q__1.i = -wa.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + } else { + +/* annihilate superdiagonal elements first (necessary if */ +/* KU = 0) */ + +/* Computing MIN */ + i__2 = *n - 1 - *ku; + if (i__ <= f2cmin(i__2,*m)) { + +/* generate reflection to annihilate A(i,ku+i+1:n) */ + + i__2 = *n - *ku - i__ + 1; + wn = scnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + r__1 = wn / c_abs(&a[i__ + (*ku + i__) * a_dim1]); + i__2 = i__ + (*ku + i__) * a_dim1; + q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + i__2 = i__ + (*ku + i__) * a_dim1; + q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__2 = *n - *ku - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__2, &q__1, &a[i__ + (*ku + i__ + 1) * a_dim1], + lda); + i__2 = i__ + (*ku + i__) * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* apply reflection to A(i+1:m,ku+i:n) from the right */ + + i__2 = *n - *ku - i__ + 1; + clacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku + + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1], + lda, &c_b1, &work[1], &c__1); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&i__2, &i__3, &q__1, &work[1], &c__1, &a[i__ + (*ku + + i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * + a_dim1], lda); + i__2 = i__ + (*ku + i__) * a_dim1; + q__1.r = -wa.r, q__1.i = -wa.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + +/* Computing MIN */ + i__2 = *m - 1 - *kl; + if (i__ <= f2cmin(i__2,*n)) { + +/* generate reflection to annihilate A(kl+i+1:m,i) */ + + i__2 = *m - *kl - i__ + 1; + wn = scnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1); + r__1 = wn / c_abs(&a[*kl + i__ + i__ * a_dim1]); + i__2 = *kl + i__ + i__ * a_dim1; + q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + i__2 = *kl + i__ + i__ * a_dim1; + q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__2 = *m - *kl - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__2, &q__1, &a[*kl + i__ + 1 + i__ * a_dim1], & + c__1); + i__2 = *kl + i__ + i__ * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* apply reflection to A(kl+i:m,i+1:n) from the left */ + + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl + + i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * + a_dim1], &c__1, &c_b1, &work[1], &c__1); + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&i__2, &i__3, &q__1, &a[*kl + i__ + i__ * a_dim1], & + c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * + a_dim1], lda); + i__2 = *kl + i__ + i__ * a_dim1; + q__1.r = -wa.r, q__1.i = -wa.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + } + + if (i__ <= *n) { + i__2 = *m; + for (j = *kl + i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L50: */ + } + } + + if (i__ <= *m) { + i__2 = *n; + for (j = *ku + i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L60: */ + } + } +/* L70: */ + } + return 0; + +/* End of CLAGGE */ + +} /* clagge_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/claghe.c b/lapack-netlib/TESTING/MATGEN/claghe.c new file mode 100644 index 000000000..9d3901d32 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/claghe.c @@ -0,0 +1,741 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLAGHE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, K, LDA, N */ +/* INTEGER ISEED( 4 ) */ +/* REAL D( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAGHE generates a complex hermitian matrix A, by pre- and post- */ +/* > multiplying a real diagonal matrix D with a random unitary matrix: */ +/* > A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */ +/* > unitary transformations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of nonzero subdiagonals within the band of A. */ +/* > 0 <= K <= N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The generated n by n hermitian matrix A (the full matrix is */ +/* > stored). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int claghe_(integer *n, integer *k, real *d__, complex *a, + integer *lda, integer *iseed, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex * + , integer *, complex *, integer *, complex *, integer *); + integer i__, j; + extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *); + complex alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), chemv_(char *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, complex *, + integer *), caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *); + extern real scnrm2_(integer *, complex *, integer *); + complex wa, wb; + real wn; + extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_( + integer *, integer *, integer *, complex *); + complex tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*k < 0 || *k > *n - 1) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("CLAGHE", &i__1); + return 0; + } + +/* initialize lower triangle of A to diagonal matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + i__3 = i__; + a[i__2].r = d__[i__3], a[i__2].i = 0.f; +/* L30: */ + } + +/* Generate lower triangle of hermitian matrix */ + + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + clarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = scnrm2_(&i__1, &work[1], &c__1); + r__1 = wn / c_abs(&work[1]); + q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__1 = *n - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__1, &q__1, &work[2], &c__1); + work[1].r = 1.f, work[1].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* apply random reflection to A(i:n,i:n) from the left */ +/* and the right */ + +/* compute y := tau * A * u */ + + i__1 = *n - i__ + 1; + chemv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], & + c__1, &c_b1, &work[*n + 1], &c__1); + +/* compute v := y - 1/2 * tau * ( y, u ) * u */ + + q__3.r = -.5f, q__3.i = 0.f; + q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + + q__3.i * tau.r; + i__1 = *n - i__ + 1; + cdotc_(&q__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1); + q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i + + q__2.i * q__4.r; + alpha.r = q__1.r, alpha.i = q__1.i; + i__1 = *n - i__ + 1; + caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1); + +/* apply the transformation as a rank-2 update to A(i:n,i:n) */ + + i__1 = *n - i__ + 1; + q__1.r = -1.f, q__1.i = 0.f; + cher2_("Lower", &i__1, &q__1, &work[1], &c__1, &work[*n + 1], &c__1, & + a[i__ + i__ * a_dim1], lda); +/* L40: */ + } + +/* Reduce number of subdiagonals to K */ + + i__1 = *n - 1 - *k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* generate reflection to annihilate A(k+i+1:n,i) */ + + i__2 = *n - *k - i__ + 1; + wn = scnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); + r__1 = wn / c_abs(&a[*k + i__ + i__ * a_dim1]); + i__2 = *k + i__ + i__ * a_dim1; + q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + i__2 = *k + i__ + i__ * a_dim1; + q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__2 = *n - *k - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__2, &q__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1); + i__2 = *k + i__ + i__ * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */ + + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__ + + 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, & + c_b1, &work[1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&i__2, &i__3, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[ + 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda); + +/* apply reflection to A(k+i:n,k+i:n) from the left and the right */ + +/* compute y := tau * A * u */ + + i__2 = *n - *k - i__ + 1; + chemv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, + &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1); + +/* compute v := y - 1/2 * tau * ( y, u ) * u */ + + q__3.r = -.5f, q__3.i = 0.f; + q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + + q__3.i * tau.r; + i__2 = *n - *k - i__ + 1; + cdotc_(&q__4, &i__2, &work[1], &c__1, &a[*k + i__ + i__ * a_dim1], & + c__1); + q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i + + q__2.i * q__4.r; + alpha.r = q__1.r, alpha.i = q__1.i; + i__2 = *n - *k - i__ + 1; + caxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & + c__1); + +/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */ + + i__2 = *n - *k - i__ + 1; + q__1.r = -1.f, q__1.i = 0.f; + cher2_("Lower", &i__2, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, & + work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda); + + i__2 = *k + i__ + i__ * a_dim1; + q__1.r = -wa.r, q__1.i = -wa.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = *n; + for (j = *k + i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L50: */ + } +/* L60: */ + } + +/* Store full hermitian matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &a[i__ + j * a_dim1]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L70: */ + } +/* L80: */ + } + return 0; + +/* End of CLAGHE */ + +} /* claghe_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clagsy.c b/lapack-netlib/TESTING/MATGEN/clagsy.c new file mode 100644 index 000000000..ed9fabe42 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clagsy.c @@ -0,0 +1,794 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLAGSY */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, K, LDA, N */ +/* INTEGER ISEED( 4 ) */ +/* REAL D( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAGSY generates a complex symmetric matrix A, by pre- and post- */ +/* > multiplying a real diagonal matrix D with a random unitary matrix: */ +/* > A = U*D*U**T. The semi-bandwidth may then be reduced to k by */ +/* > additional unitary transformations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of nonzero subdiagonals within the band of A. */ +/* > 0 <= K <= N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The generated n by n symmetric matrix A (the full matrix is */ +/* > stored). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clagsy_(integer *n, integer *k, real *d__, complex *a, + integer *lda, integer *iseed, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, + i__9; + real r__1; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer i__, j; + extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *); + complex alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer + *, complex *, integer *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *), caxpy_(integer *, complex *, complex *, + integer *, complex *, integer *), csymv_(char *, integer *, + complex *, complex *, integer *, complex *, integer *, complex *, + complex *, integer *); + extern real scnrm2_(integer *, complex *, integer *); + integer ii, jj; + complex wa, wb; + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *); + real wn; + extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_( + integer *, integer *, integer *, complex *); + complex tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*k < 0 || *k > *n - 1) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("CLAGSY", &i__1); + return 0; + } + +/* initialize lower triangle of A to diagonal matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L10: */ + } +/* L20: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + i__3 = i__; + a[i__2].r = d__[i__3], a[i__2].i = 0.f; +/* L30: */ + } + +/* Generate lower triangle of symmetric matrix */ + + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + clarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = scnrm2_(&i__1, &work[1], &c__1); + r__1 = wn / c_abs(&work[1]); + q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__1 = *n - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__1, &q__1, &work[2], &c__1); + work[1].r = 1.f, work[1].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* apply random reflection to A(i:n,i:n) from the left */ +/* and the right */ + +/* compute y := tau * A * conjg(u) */ + + i__1 = *n - i__ + 1; + clacgv_(&i__1, &work[1], &c__1); + i__1 = *n - i__ + 1; + csymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], & + c__1, &c_b1, &work[*n + 1], &c__1); + i__1 = *n - i__ + 1; + clacgv_(&i__1, &work[1], &c__1); + +/* compute v := y - 1/2 * tau * ( u, y ) * u */ + + q__3.r = -.5f, q__3.i = 0.f; + q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + + q__3.i * tau.r; + i__1 = *n - i__ + 1; + cdotc_(&q__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1); + q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i + + q__2.i * q__4.r; + alpha.r = q__1.r, alpha.i = q__1.i; + i__1 = *n - i__ + 1; + caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1); + +/* apply the transformation as a rank-2 update to A(i:n,i:n) */ + +/* CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, */ +/* $ A( I, I ), LDA ) */ + + i__1 = *n; + for (jj = i__; jj <= i__1; ++jj) { + i__2 = *n; + for (ii = jj; ii <= i__2; ++ii) { + i__3 = ii + jj * a_dim1; + i__4 = ii + jj * a_dim1; + i__5 = ii - i__ + 1; + i__6 = *n + jj - i__ + 1; + q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[ + i__6].i, q__3.i = work[i__5].r * work[i__6].i + work[ + i__5].i * work[i__6].r; + q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i; + i__7 = *n + ii - i__ + 1; + i__8 = jj - i__ + 1; + q__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[ + i__8].i, q__4.i = work[i__7].r * work[i__8].i + work[ + i__7].i * work[i__8].r; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L40: */ + } +/* L50: */ + } +/* L60: */ + } + +/* Reduce number of subdiagonals to K */ + + i__1 = *n - 1 - *k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* generate reflection to annihilate A(k+i+1:n,i) */ + + i__2 = *n - *k - i__ + 1; + wn = scnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); + r__1 = wn / c_abs(&a[*k + i__ + i__ * a_dim1]); + i__2 = *k + i__ + i__ * a_dim1; + q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + i__2 = *k + i__ + i__ * a_dim1; + q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__2 = *n - *k - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__2, &q__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1); + i__2 = *k + i__ + i__ * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */ + + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__ + + 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, & + c_b1, &work[1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&i__2, &i__3, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[ + 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda); + +/* apply reflection to A(k+i:n,k+i:n) from the left and the right */ + +/* compute y := tau * A * conjg(u) */ + + i__2 = *n - *k - i__ + 1; + clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); + i__2 = *n - *k - i__ + 1; + csymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, + &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1); + i__2 = *n - *k - i__ + 1; + clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); + +/* compute v := y - 1/2 * tau * ( u, y ) * u */ + + q__3.r = -.5f, q__3.i = 0.f; + q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + + q__3.i * tau.r; + i__2 = *n - *k - i__ + 1; + cdotc_(&q__4, &i__2, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & + c__1); + q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i + + q__2.i * q__4.r; + alpha.r = q__1.r, alpha.i = q__1.i; + i__2 = *n - *k - i__ + 1; + caxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & + c__1); + +/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */ + +/* CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, */ +/* $ A( K+I, K+I ), LDA ) */ + + i__2 = *n; + for (jj = *k + i__; jj <= i__2; ++jj) { + i__3 = *n; + for (ii = jj; ii <= i__3; ++ii) { + i__4 = ii + jj * a_dim1; + i__5 = ii + jj * a_dim1; + i__6 = ii + i__ * a_dim1; + i__7 = jj - *k - i__ + 1; + q__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i, + q__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[ + i__7].r; + q__2.r = a[i__5].r - q__3.r, q__2.i = a[i__5].i - q__3.i; + i__8 = ii - *k - i__ + 1; + i__9 = jj + i__ * a_dim1; + q__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i, + q__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[ + i__9].r; + q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i; + a[i__4].r = q__1.r, a[i__4].i = q__1.i; +/* L70: */ + } +/* L80: */ + } + + i__2 = *k + i__ + i__ * a_dim1; + q__1.r = -wa.r, q__1.i = -wa.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = *n; + for (j = *k + i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; +/* L90: */ + } +/* L100: */ + } + +/* Store full symmetric matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + i__4 = i__ + j * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; +/* L110: */ + } +/* L120: */ + } + return 0; + +/* End of CLAGSY */ + +} /* clagsy_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clahilb.c b/lapack-netlib/TESTING/MATGEN/clahilb.c new file mode 100644 index 000000000..4884d1e3c --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clahilb.c @@ -0,0 +1,711 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLAHILB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, */ +/* INFO, PATH) */ + +/* INTEGER N, NRHS, LDA, LDX, LDB, INFO */ +/* REAL WORK(N) */ +/* COMPLEX A(LDA,N), X(LDX, NRHS), B(LDB, NRHS) */ +/* CHARACTER*3 PATH */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAHILB generates an N by N scaled Hilbert matrix in A along with */ +/* > NRHS right-hand sides in B and solutions in X such that A*X=B. */ +/* > */ +/* > The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */ +/* > entries are integers. The right-hand sides are the first NRHS */ +/* > columns of M * the identity matrix, and the solutions are the */ +/* > first NRHS columns of the inverse Hilbert matrix. */ +/* > */ +/* > The condition number of the Hilbert matrix grows exponentially with */ +/* > its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */ +/* > Hilbert matrices beyond a relatively small dimension cannot be */ +/* > generated exactly without extra precision. Precision is exhausted */ +/* > when the largest entry in the inverse Hilbert matrix is greater than */ +/* > 2 to the power of the number of bits in the fraction of the data type */ +/* > used plus one, which is 24 for single precision. */ +/* > */ +/* > In single, the generated solution is exact for N <= 6 and has */ +/* > small componentwise error for 7 <= N <= 11. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The requested number of right-hand sides. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA, N) */ +/* > The generated scaled Hilbert matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX, NRHS) */ +/* > The generated exact solutions. Currently, the first NRHS */ +/* > columns of the inverse Hilbert matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB, NRHS) */ +/* > The generated right-hand sides. Currently, the first NRHS */ +/* > columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > = 1: N is too large; the data is still generated but may not */ +/* > be not exact. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PATH */ +/* > \verbatim */ +/* > PATH is CHARACTER*3 */ +/* > The LAPACK path name. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clahilb_(integer *n, integer *nrhs, complex *a, integer * + lda, complex *x, integer *ldx, complex *b, integer *ldb, real *work, + integer *info, char *path) +{ + /* Initialized data */ + + static complex d1[8] = { {-1.f,0.f},{0.f,1.f},{-1.f,-1.f},{0.f,-1.f},{1.f, + 0.f},{-1.f,1.f},{1.f,1.f},{1.f,-1.f} }; + static complex d2[8] = { {-1.f,0.f},{0.f,-1.f},{-1.f,1.f},{0.f,1.f},{1.f, + 0.f},{-1.f,-1.f},{1.f,-1.f},{1.f,1.f} }; + static complex invd1[8] = { {-1.f,0.f},{0.f,-1.f},{-.5f,.5f},{0.f,1.f},{ + 1.f,0.f},{-.5f,-.5f},{.5f,-.5f},{.5f,.5f} }; + static complex invd2[8] = { {-1.f,0.f},{0.f,1.f},{-.5f,-.5f},{0.f,-1.f},{ + 1.f,0.f},{-.5f,.5f},{.5f,.5f},{.5f,-.5f} }; + + /* System generated locals */ + integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2, + i__3, i__4, i__5; + real r__1; + complex q__1, q__2; + + /* Local variables */ + integer i__, j, m, r__; + char c2[2]; + integer ti, tm; + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *), xerbla_(char *, + integer *); + extern logical lsamen_(integer *, char *, char *); + complex tmp; + + +/* -- LAPACK test routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ +/* NMAX_EXACT the largest dimension where the generated data is */ +/* exact. */ +/* NMAX_APPROX the largest dimension where the generated data has */ +/* a small componentwise relative error. */ +/* ??? complex uses how many bits ??? */ + +/* d's are generated from random permutation of those eight elements. */ + /* Parameter adjustments */ + --work; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2); + +/* Test the input arguments */ + + *info = 0; + if (*n < 0 || *n > 11) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*lda < *n) { + *info = -4; + } else if (*ldx < *n) { + *info = -6; + } else if (*ldb < *n) { + *info = -8; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("CLAHILB", &i__1); + return 0; + } + if (*n > 6) { + *info = 1; + } + +/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */ +/* reasonable N is small enough that integers suffice (up to N = 11). */ + m = 1; + i__1 = (*n << 1) - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + tm = m; + ti = i__; + r__ = tm % ti; + while(r__ != 0) { + tm = ti; + ti = r__; + r__ = tm % ti; + } + m = m / ti * i__; + } + +/* Generate the scaled Hilbert matrix in A */ +/* If we are testing SY routines, take */ +/* D1_i = D2_i, else, D1_i = D2_i* */ + if (lsamen_(&c__2, c2, "SY")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = j % 8; + r__1 = (real) m / (i__ + j - 1); + q__2.r = r__1 * d1[i__4].r, q__2.i = r__1 * d1[i__4].i; + i__5 = i__ % 8; + q__1.r = q__2.r * d1[i__5].r - q__2.i * d1[i__5].i, q__1.i = + q__2.r * d1[i__5].i + q__2.i * d1[i__5].r; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = j % 8; + r__1 = (real) m / (i__ + j - 1); + q__2.r = r__1 * d1[i__4].r, q__2.i = r__1 * d1[i__4].i; + i__5 = i__ % 8; + q__1.r = q__2.r * d2[i__5].r - q__2.i * d2[i__5].i, q__1.i = + q__2.r * d2[i__5].i + q__2.i * d2[i__5].r; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } + } + +/* Generate matrix B as simply the first NRHS columns of M * the */ +/* identity. */ + r__1 = (real) m; + tmp.r = r__1, tmp.i = 0.f; + claset_("Full", n, nrhs, &c_b6, &tmp, &b[b_offset], ldb); + +/* Generate the true solutions in X. Because B = the first NRHS */ +/* columns of M*I, the true solutions are just the first NRHS columns */ +/* of the inverse Hilbert matrix. */ + work[1] = (real) (*n); + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j - + 1); + } +/* If we are testing SY routines, */ +/* take D1_i = D2_i, else, D1_i = D2_i* */ + if (lsamen_(&c__2, c2, "SY")) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * x_dim1; + i__4 = j % 8; + r__1 = work[i__] * work[j] / (i__ + j - 1); + q__2.r = r__1 * invd1[i__4].r, q__2.i = r__1 * invd1[i__4].i; + i__5 = i__ % 8; + q__1.r = q__2.r * invd1[i__5].r - q__2.i * invd1[i__5].i, + q__1.i = q__2.r * invd1[i__5].i + q__2.i * invd1[i__5] + .r; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } + } + } else { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * x_dim1; + i__4 = j % 8; + r__1 = work[i__] * work[j] / (i__ + j - 1); + q__2.r = r__1 * invd2[i__4].r, q__2.i = r__1 * invd2[i__4].i; + i__5 = i__ % 8; + q__1.r = q__2.r * invd1[i__5].r - q__2.i * invd1[i__5].i, + q__1.i = q__2.r * invd1[i__5].i + q__2.i * invd1[i__5] + .r; + x[i__3].r = q__1.r, x[i__3].i = q__1.i; + } + } + } + return 0; +} /* clahilb_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clahilb.f b/lapack-netlib/TESTING/MATGEN/clahilb.f index f4481fc78..6c51bdb0c 100644 --- a/lapack-netlib/TESTING/MATGEN/clahilb.f +++ b/lapack-netlib/TESTING/MATGEN/clahilb.f @@ -166,13 +166,6 @@ * * d's are generated from random permutation of those eight elements. COMPLEX D1(8), D2(8), INVD1(8), INVD2(8) - DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/ - DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ - - DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0), - $ (-.5,-.5),(.5,-.5),(.5,.5)/ - DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0), - $ (-.5,.5),(.5,.5),(.5,-.5)/ * .. * .. External Subroutines .. EXTERNAL XERBLA @@ -181,6 +174,14 @@ EXTERNAL CLASET, LSAMEN INTRINSIC REAL LOGICAL LSAMEN + + DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/ + DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ + + DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0), + $ (-.5,-.5),(.5,-.5),(.5,.5)/ + DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0), + $ (-.5,.5),(.5,.5),(.5,-.5)/ * .. * .. Executable Statements .. C2 = PATH( 2: 3 ) diff --git a/lapack-netlib/TESTING/MATGEN/clakf2.c b/lapack-netlib/TESTING/MATGEN/clakf2.c new file mode 100644 index 000000000..3a4e7439d --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clakf2.c @@ -0,0 +1,621 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLAKF2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) */ + +/* INTEGER LDA, LDZ, M, N */ +/* COMPLEX A( LDA, * ), B( LDA, * ), D( LDA, * ), */ +/* $ E( LDA, * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Form the 2*M*N by 2*M*N matrix */ +/* > */ +/* > Z = [ kron(In, A) -kron(B', Im) ] */ +/* > [ kron(In, D) -kron(E', Im) ], */ +/* > */ +/* > where In is the identity matrix of size n and X' is the transpose */ +/* > of X. kron(X, Y) is the Kronecker product between the matrices X */ +/* > and Y. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Size of matrix, must be >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Size of matrix, must be >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX, dimension ( LDA, M ) */ +/* > The matrix A in the output matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A, B, D, and E. ( LDA >= M+N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX, dimension ( LDA, N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is COMPLEX, dimension ( LDA, M ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX, dimension ( LDA, N ) */ +/* > */ +/* > The matrices used in forming the output matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX, dimension ( LDZ, 2*M*N ) */ +/* > The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of Z. ( LDZ >= 2*M*N ) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clakf2_(integer *m, integer *n, complex *a, integer *lda, + complex *b, complex *d__, complex *e, complex *z__, integer *ldz) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1, + e_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + complex q__1; + + /* Local variables */ + integer i__, j, l, ik, jk, mn; + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *); + integer mn2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ==================================================================== */ + + +/* Initialize Z */ + + /* Parameter adjustments */ + e_dim1 = *lda; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + d_dim1 = *lda; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + b_dim1 = *lda; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + + /* Function Body */ + mn = *m * *n; + mn2 = mn << 1; + claset_("Full", &mn2, &mn2, &c_b1, &c_b1, &z__[z_offset], ldz); + + ik = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + +/* form kron(In, A) */ + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m; + for (j = 1; j <= i__3; ++j) { + i__4 = ik + i__ - 1 + (ik + j - 1) * z_dim1; + i__5 = i__ + j * a_dim1; + z__[i__4].r = a[i__5].r, z__[i__4].i = a[i__5].i; +/* L10: */ + } +/* L20: */ + } + +/* form kron(In, D) */ + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m; + for (j = 1; j <= i__3; ++j) { + i__4 = ik + mn + i__ - 1 + (ik + j - 1) * z_dim1; + i__5 = i__ + j * d_dim1; + z__[i__4].r = d__[i__5].r, z__[i__4].i = d__[i__5].i; +/* L30: */ + } +/* L40: */ + } + + ik += *m; +/* L50: */ + } + + ik = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + jk = mn + 1; + + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + +/* form -kron(B', Im) */ + + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = ik + i__ - 1 + (jk + i__ - 1) * z_dim1; + i__5 = j + l * b_dim1; + q__1.r = -b[i__5].r, q__1.i = -b[i__5].i; + z__[i__4].r = q__1.r, z__[i__4].i = q__1.i; +/* L60: */ + } + +/* form -kron(E', Im) */ + + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1; + i__5 = j + l * e_dim1; + q__1.r = -e[i__5].r, q__1.i = -e[i__5].i; + z__[i__4].r = q__1.r, z__[i__4].i = q__1.i; +/* L70: */ + } + + jk += *m; +/* L80: */ + } + + ik += *m; +/* L90: */ + } + + return 0; + +/* End of CLAKF2 */ + +} /* clakf2_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clarge.c b/lapack-netlib/TESTING/MATGEN/clarge.c new file mode 100644 index 000000000..cdaa1a318 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clarge.c @@ -0,0 +1,586 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLARGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLARGE( N, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, LDA, N */ +/* INTEGER ISEED( 4 ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLARGE pre- and post-multiplies a complex general n by n matrix A */ +/* > with a random unitary matrix: A = U*D*U'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On entry, the original n by n matrix A. */ +/* > On exit, A is overwritten by U*A*U' for some random */ +/* > unitary matrix U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clarge_(integer *n, complex *a, integer *lda, integer * + iseed, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + real r__1; + complex q__1; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *), + cscal_(integer *, complex *, complex *, integer *), cgemv_(char * + , integer *, integer *, complex *, complex *, integer *, complex * + , integer *, complex *, complex *, integer *); + extern real scnrm2_(integer *, complex *, integer *); + complex wa, wb; + real wn; + extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_( + integer *, integer *, integer *, complex *); + complex tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*lda < f2cmax(1,*n)) { + *info = -3; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("CLARGE", &i__1); + return 0; + } + +/* pre- and post-multiply A by random unitary matrix */ + + for (i__ = *n; i__ >= 1; --i__) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + clarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = scnrm2_(&i__1, &work[1], &c__1); + r__1 = wn / c_abs(&work[1]); + q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i; + wa.r = q__1.r, wa.i = q__1.i; + if (wn == 0.f) { + tau.r = 0.f, tau.i = 0.f; + } else { + q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i; + wb.r = q__1.r, wb.i = q__1.i; + i__1 = *n - i__; + c_div(&q__1, &c_b2, &wb); + cscal_(&i__1, &q__1, &work[2], &c__1); + work[1].r = 1.f, work[1].i = 0.f; + c_div(&q__1, &wb, &wa); + r__1 = q__1.r; + tau.r = r__1, tau.i = 0.f; + } + +/* multiply A(i:n,1:n) by random reflection from the left */ + + i__1 = *n - i__ + 1; + cgemv_("Conjugate transpose", &i__1, n, &c_b2, &a[i__ + a_dim1], lda, + &work[1], &c__1, &c_b1, &work[*n + 1], &c__1); + i__1 = *n - i__ + 1; + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&i__1, n, &q__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__ + + a_dim1], lda); + +/* multiply A(1:n,i:n) by random reflection from the right */ + + i__1 = *n - i__ + 1; + cgemv_("No transpose", n, &i__1, &c_b2, &a[i__ * a_dim1 + 1], lda, & + work[1], &c__1, &c_b1, &work[*n + 1], &c__1); + i__1 = *n - i__ + 1; + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(n, &i__1, &q__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ + * a_dim1 + 1], lda); +/* L10: */ + } + return 0; + +/* End of CLARGE */ + +} /* clarge_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clarnd.c b/lapack-netlib/TESTING/MATGEN/clarnd.c new file mode 100644 index 000000000..f0f2d9610 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clarnd.c @@ -0,0 +1,540 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLARND */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* COMPLEX FUNCTION CLARND( IDIST, ISEED ) */ + +/* INTEGER IDIST */ +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLARND returns a random complex number from a uniform or normal */ +/* > distribution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > Specifies the distribution of the random numbers: */ +/* > = 1: real and imaginary parts each uniform (0,1) */ +/* > = 2: real and imaginary parts each uniform (-1,1) */ +/* > = 3: real and imaginary parts each normal (0,1) */ +/* > = 4: uniformly distributed on the disc abs(z) <= 1 */ +/* > = 5: uniformly distributed on the circle abs(z) = 1 */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine calls the auxiliary routine SLARAN to generate a random */ +/* > real number from a uniform (0,1) distribution. The Box-Muller method */ +/* > is used to transform numbers from a uniform to a normal distribution. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +///* Complex */ VOID clarnd_(complex * ret_val, integer *idist, integer *iseed) + complex clarnd_(integer *idist, integer *iseed) +{ + /* System generated locals */ + real r__1, r__2; + complex q__1, q__2, q__3; + complex *ret_val =(complex*)malloc(sizeof(complex)); + + /* Local variables */ + real t1, t2; + extern real slaran_(integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Generate a pair of real random numbers from a uniform (0,1) */ +/* distribution */ + + /* Parameter adjustments */ + --iseed; + + /* Function Body */ + t1 = slaran_(&iseed[1]); + t2 = slaran_(&iseed[1]); + + if (*idist == 1) { + +/* real and imaginary parts each uniform (0,1) */ + + q__1.r = t1, q__1.i = t2; + ret_val->r = q__1.r, ret_val->i = q__1.i; + } else if (*idist == 2) { + +/* real and imaginary parts each uniform (-1,1) */ + + r__1 = t1 * 2.f - 1.f; + r__2 = t2 * 2.f - 1.f; + q__1.r = r__1, q__1.i = r__2; + ret_val->r = q__1.r, ret_val->i = q__1.i; + } else if (*idist == 3) { + +/* real and imaginary parts each normal (0,1) */ + + r__1 = sqrt(log(t1) * -2.f); + r__2 = t2 * 6.2831853071795864769252867663f; + q__3.r = 0.f, q__3.i = r__2; + c_exp(&q__2, &q__3); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + ret_val->r = q__1.r, ret_val->i = q__1.i; + } else if (*idist == 4) { + +/* uniform distribution on the unit disc abs(z) <= 1 */ + + r__1 = sqrt(t1); + r__2 = t2 * 6.2831853071795864769252867663f; + q__3.r = 0.f, q__3.i = r__2; + c_exp(&q__2, &q__3); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + ret_val->r = q__1.r, ret_val->i = q__1.i; + } else if (*idist == 5) { + +/* uniform distribution on the unit circle abs(z) = 1 */ + + r__1 = t2 * 6.2831853071795864769252867663f; + q__2.r = 0.f, q__2.i = r__1; + c_exp(&q__1, &q__2); + ret_val->r = q__1.r, ret_val->i = q__1.i; + } + return *ret_val; + +/* End of CLARND */ + +} /* clarnd_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/claror.c b/lapack-netlib/TESTING/MATGEN/claror.c new file mode 100644 index 000000000..aac2f819f --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/claror.c @@ -0,0 +1,783 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLAROR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) */ + +/* CHARACTER INIT, SIDE */ +/* INTEGER INFO, LDA, M, N */ +/* INTEGER ISEED( 4 ) */ +/* COMPLEX A( LDA, * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAROR pre- or post-multiplies an M by N matrix A by a random */ +/* > unitary matrix U, overwriting A. A may optionally be */ +/* > initialized to the identity matrix before multiplying by U. */ +/* > U is generated using the method of G.W. Stewart */ +/* > ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ). */ +/* > (BLAS-2 version) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > SIDE specifies whether A is multiplied on the left or right */ +/* > by U. */ +/* > SIDE = 'L' Multiply A on the left (premultiply) by U */ +/* > SIDE = 'R' Multiply A on the right (postmultiply) by UC> SIDE = 'C' Multiply A on the lef +t by U and the right by UC> SIDE = 'T' Multiply A on the left by U and the right by U' */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INIT */ +/* > \verbatim */ +/* > INIT is CHARACTER*1 */ +/* > INIT specifies whether or not A should be initialized to */ +/* > the identity matrix. */ +/* > INIT = 'I' Initialize A to (a section of) the */ +/* > identity matrix before applying U. */ +/* > INIT = 'N' No initialization. Apply U to the */ +/* > input matrix A. */ +/* > */ +/* > INIT = 'I' may be used to generate square (i.e., unitary) */ +/* > or rectangular orthogonal matrices (orthogonality being */ +/* > in the sense of CDOTC): */ +/* > */ +/* > For square matrices, M=N, and SIDE many be either 'L' or */ +/* > 'R'; the rows will be orthogonal to each other, as will the */ +/* > columns. */ +/* > For rectangular matrices where M < N, SIDE = 'R' will */ +/* > produce a dense matrix whose rows will be orthogonal and */ +/* > whose columns will not, while SIDE = 'L' will produce a */ +/* > matrix whose rows will be orthogonal, and whose first M */ +/* > columns will be orthogonal, the remaining columns being */ +/* > zero. */ +/* > For matrices where M > N, just use the previous */ +/* > explanation, interchanging 'L' and 'R' and "rows" and */ +/* > "columns". */ +/* > */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( LDA, N ) */ +/* > Input and output array. Overwritten by U A ( if SIDE = 'L' ) */ +/* > or by A U ( if SIDE = 'R' ) */ +/* > or by U A U* ( if SIDE = 'C') */ +/* > or by U A U' ( if SIDE = 'T') on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > Leading dimension of A. Must be at least MAX ( 1, M ). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. The array elements should be between 0 and 4095; */ +/* > if not they will be reduced mod 4096. Also, ISEED(4) must */ +/* > be odd. The random number generator uses a linear */ +/* > congruential sequence limited to small integers, and so */ +/* > should produce machine independent random numbers. The */ +/* > values of ISEED are changed on exit, and can be used in the */ +/* > next call to CLAROR to continue the same random number */ +/* > sequence. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension ( 3*MAX( M, N ) ) */ +/* > Workspace. Of length: */ +/* > 2*M + N if SIDE = 'L', */ +/* > 2*N + M if SIDE = 'R', */ +/* > 3*N if SIDE = 'C' or 'T'. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > An error flag. It is set to: */ +/* > 0 if no error. */ +/* > 1 if CLARND returned a bad random number (installation */ +/* > problem) */ +/* > -1 if SIDE is not L, R, C, or T. */ +/* > -3 if M is negative. */ +/* > -4 if N is negative or if SIDE is C or T and N is not equal */ +/* > to M. */ +/* > -6 if LDA is less than M. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int claror_(char *side, char *init, integer *m, integer *n, + complex *a, integer *lda, integer *iseed, complex *x, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + complex q__1, q__2; + + /* Local variables */ + integer kbeg, jcol; + real xabs; + integer irow, j; + extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *), + cscal_(integer *, complex *, complex *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + complex csign; + integer ixfrm, itype, nxfrm; + real xnorm; + extern real scnrm2_(integer *, complex *, integer *); + extern /* Subroutine */ int clacgv_(integer *, complex *, integer *); + //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); + extern complex clarnd_(integer *, integer *); + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *), xerbla_(char *, + integer *); + real factor; + complex xnorms; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --x; + + /* Function Body */ + *info = 0; + if (*n == 0 || *m == 0) { + return 0; + } + + itype = 0; + if (lsame_(side, "L")) { + itype = 1; + } else if (lsame_(side, "R")) { + itype = 2; + } else if (lsame_(side, "C")) { + itype = 3; + } else if (lsame_(side, "T")) { + itype = 4; + } + +/* Check for argument errors. */ + + if (itype == 0) { + *info = -1; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0 || itype == 3 && *n != *m) { + *info = -4; + } else if (*lda < *m) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLAROR", &i__1); + return 0; + } + + if (itype == 1) { + nxfrm = *m; + } else { + nxfrm = *n; + } + +/* Initialize A to the identity matrix if desired */ + + if (lsame_(init, "I")) { + claset_("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda); + } + +/* If no rotation possible, still multiply by */ +/* a random complex number from the circle |x| = 1 */ + +/* 2) Compute Rotation by computing Householder */ +/* Transformations H(2), H(3), ..., H(n). Note that the */ +/* order in which they are computed is irrelevant. */ + + i__1 = nxfrm; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + x[i__2].r = 0.f, x[i__2].i = 0.f; +/* L40: */ + } + + i__1 = nxfrm; + for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) { + kbeg = nxfrm - ixfrm + 1; + +/* Generate independent normal( 0, 1 ) random numbers */ + + i__2 = nxfrm; + for (j = kbeg; j <= i__2; ++j) { + i__3 = j; + //clarnd_(&q__1, &c__3, &iseed[1]); + q__1=clarnd_(&c__3, &iseed[1]); + x[i__3].r = q__1.r, x[i__3].i = q__1.i; +/* L50: */ + } + +/* Generate a Householder transformation from the random vector X */ + + xnorm = scnrm2_(&ixfrm, &x[kbeg], &c__1); + xabs = c_abs(&x[kbeg]); + if (xabs != 0.f) { + i__2 = kbeg; + q__1.r = x[i__2].r / xabs, q__1.i = x[i__2].i / xabs; + csign.r = q__1.r, csign.i = q__1.i; + } else { + csign.r = 1.f, csign.i = 0.f; + } + q__1.r = xnorm * csign.r, q__1.i = xnorm * csign.i; + xnorms.r = q__1.r, xnorms.i = q__1.i; + i__2 = nxfrm + kbeg; + q__1.r = -csign.r, q__1.i = -csign.i; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + factor = xnorm * (xnorm + xabs); + if (abs(factor) < 1e-20f) { + *info = 1; + i__2 = -(*info); + xerbla_("CLAROR", &i__2); + return 0; + } else { + factor = 1.f / factor; + } + i__2 = kbeg; + i__3 = kbeg; + q__1.r = x[i__3].r + xnorms.r, q__1.i = x[i__3].i + xnorms.i; + x[i__2].r = q__1.r, x[i__2].i = q__1.i; + +/* Apply Householder transformation to A */ + + if (itype == 1 || itype == 3 || itype == 4) { + +/* Apply H(k) on the left of A */ + + cgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], & + c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1); + q__2.r = factor, q__2.i = 0.f; + q__1.r = -q__2.r, q__1.i = -q__2.i; + cgerc_(&ixfrm, n, &q__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], & + c__1, &a[kbeg + a_dim1], lda); + + } + + if (itype >= 2 && itype <= 4) { + +/* Apply H(k)* (or H(k)') on the right of A */ + + if (itype == 4) { + clacgv_(&ixfrm, &x[kbeg], &c__1); + } + + cgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg] + , &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1); + q__2.r = factor, q__2.i = 0.f; + q__1.r = -q__2.r, q__1.i = -q__2.i; + cgerc_(m, &ixfrm, &q__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], & + c__1, &a[kbeg * a_dim1 + 1], lda); + + } +/* L60: */ + } + + //clarnd_(&q__1, &c__3, &iseed[1]); + q__1=clarnd_(&c__3, &iseed[1]); + x[1].r = q__1.r, x[1].i = q__1.i; + xabs = c_abs(&x[1]); + if (xabs != 0.f) { + q__1.r = x[1].r / xabs, q__1.i = x[1].i / xabs; + csign.r = q__1.r, csign.i = q__1.i; + } else { + csign.r = 1.f, csign.i = 0.f; + } + i__1 = nxfrm << 1; + x[i__1].r = csign.r, x[i__1].i = csign.i; + +/* Scale the matrix A by D. */ + + if (itype == 1 || itype == 3 || itype == 4) { + i__1 = *m; + for (irow = 1; irow <= i__1; ++irow) { + r_cnjg(&q__1, &x[nxfrm + irow]); + cscal_(n, &q__1, &a[irow + a_dim1], lda); +/* L70: */ + } + } + + if (itype == 2 || itype == 3) { + i__1 = *n; + for (jcol = 1; jcol <= i__1; ++jcol) { + cscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1); +/* L80: */ + } + } + + if (itype == 4) { + i__1 = *n; + for (jcol = 1; jcol <= i__1; ++jcol) { + r_cnjg(&q__1, &x[nxfrm + jcol]); + cscal_(m, &q__1, &a[jcol * a_dim1 + 1], &c__1); +/* L90: */ + } + } + return 0; + +/* End of CLAROR */ + +} /* claror_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clarot.c b/lapack-netlib/TESTING/MATGEN/clarot.c new file mode 100644 index 000000000..dd745ba49 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clarot.c @@ -0,0 +1,771 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLAROT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, */ +/* XRIGHT ) */ + +/* LOGICAL LLEFT, LRIGHT, LROWS */ +/* INTEGER LDA, NL */ +/* COMPLEX C, S, XLEFT, XRIGHT */ +/* COMPLEX A( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLAROT applies a (Givens) rotation to two adjacent rows or */ +/* > columns, where one element of the first and/or last column/row */ +/* > for use on matrices stored in some format other than GE, so */ +/* > that elements of the matrix may be used or modified for which */ +/* > no array element is provided. */ +/* > */ +/* > One example is a symmetric matrix in SB format (bandwidth=4), for */ +/* > which UPLO='L': Two adjacent rows will have the format: */ +/* > */ +/* > row j: C> C> C> C> C> . . . . */ +/* > row j+1: C> C> C> C> C> . . . . */ +/* > */ +/* > '*' indicates elements for which storage is provided, */ +/* > '.' indicates elements for which no storage is provided, but */ +/* > are not necessarily zero; their values are determined by */ +/* > symmetry. ' ' indicates elements which are necessarily zero, */ +/* > and have no storage provided. */ +/* > */ +/* > Those columns which have two '*'s can be handled by SROT. */ +/* > Those columns which have no '*'s can be ignored, since as long */ +/* > as the Givens rotations are carefully applied to preserve */ +/* > symmetry, their values are determined. */ +/* > Those columns which have one '*' have to be handled separately, */ +/* > by using separate variables "p" and "q": */ +/* > */ +/* > row j: C> C> C> C> C> p . . . */ +/* > row j+1: q C> C> C> C> C> . . . . */ +/* > */ +/* > The element p would have to be set correctly, then that column */ +/* > is rotated, setting p to its new value. The next call to */ +/* > CLAROT would rotate columns j and j+1, using p, and restore */ +/* > symmetry. The element q would start out being zero, and be */ +/* > made non-zero by the rotation. Later, rotations would presumably */ +/* > be chosen to zero q out. */ +/* > */ +/* > Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */ +/* > ------- ------- --------- */ +/* > */ +/* > General dense matrix: */ +/* > */ +/* > CALL CLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */ +/* > A(i,1),LDA, DUMMY, DUMMY) */ +/* > */ +/* > General banded matrix in GB format: */ +/* > */ +/* > j = MAX(1, i-KL ) */ +/* > NL = MIN( N, i+KU+1 ) + 1-j */ +/* > CALL CLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */ +/* > A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > [ note that i+1-j is just MIN(i,KL+1) ] */ +/* > */ +/* > Symmetric banded matrix in SY format, bandwidth K, */ +/* > lower triangle only: */ +/* > */ +/* > j = MAX(1, i-K ) */ +/* > NL = MIN( K+1, i ) + 1 */ +/* > CALL CLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */ +/* > A(i,j), LDA, XLEFT, XRIGHT ) */ +/* > */ +/* > Same, but upper triangle only: */ +/* > */ +/* > NL = MIN( K+1, N-i ) + 1 */ +/* > CALL CLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */ +/* > A(i,i), LDA, XLEFT, XRIGHT ) */ +/* > */ +/* > Symmetric banded matrix in SB format, bandwidth K, */ +/* > lower triangle only: */ +/* > */ +/* > [ same as for SY, except:] */ +/* > . . . . */ +/* > A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > [ note that i+1-j is just MIN(i,K+1) ] */ +/* > */ +/* > Same, but upper triangle only: */ +/* > . . . */ +/* > A(K+1,i), LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > Rotating columns is just the transpose of rotating rows, except */ +/* > for GB and SB: (rotating columns i and i+1) */ +/* > */ +/* > GB: */ +/* > j = MAX(1, i-KU ) */ +/* > NL = MIN( N, i+KL+1 ) + 1-j */ +/* > CALL CLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */ +/* > A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ +/* > */ +/* > [note that KU+j+1-i is just MAX(1,KU+2-i)] */ +/* > */ +/* > SB: (upper triangle) */ +/* > */ +/* > . . . . . . */ +/* > A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ +/* > */ +/* > SB: (lower triangle) */ +/* > */ +/* > . . . . . . */ +/* > A(1,i),LDA-1, XTOP, XBOTTM ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > LROWS - LOGICAL */ +/* > If .TRUE., then CLAROT will rotate two rows. If .FALSE., */ +/* > then it will rotate two columns. */ +/* > Not modified. */ +/* > */ +/* > LLEFT - LOGICAL */ +/* > If .TRUE., then XLEFT will be used instead of the */ +/* > corresponding element of A for the first element in the */ +/* > second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */ +/* > If .FALSE., then the corresponding element of A will be */ +/* > used. */ +/* > Not modified. */ +/* > */ +/* > LRIGHT - LOGICAL */ +/* > If .TRUE., then XRIGHT will be used instead of the */ +/* > corresponding element of A for the last element in the */ +/* > first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */ +/* > .FALSE., then the corresponding element of A will be used. */ +/* > Not modified. */ +/* > */ +/* > NL - INTEGER */ +/* > The length of the rows (if LROWS=.TRUE.) or columns (if */ +/* > LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are */ +/* > used, the columns/rows they are in should be included in */ +/* > NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */ +/* > least 2. The number of rows/columns to be rotated */ +/* > exclusive of those involving XLEFT and/or XRIGHT may */ +/* > not be negative, i.e., NL minus how many of LLEFT and */ +/* > LRIGHT are .TRUE. must be at least zero; if not, XERBLA */ +/* > will be called. */ +/* > Not modified. */ +/* > */ +/* > C, S - COMPLEX */ +/* > Specify the Givens rotation to be applied. If LROWS is */ +/* > true, then the matrix ( c s ) */ +/* > ( _ _ ) */ +/* > (-s c ) is applied from the left; */ +/* > if false, then the transpose (not conjugated) thereof is */ +/* > applied from the right. Note that in contrast to the */ +/* > output of CROTG or to most versions of CROT, both C and S */ +/* > are complex. For a Givens rotation, |C|**2 + |S|**2 should */ +/* > be 1, but this is not checked. */ +/* > Not modified. */ +/* > */ +/* > A - COMPLEX array. */ +/* > The array containing the rows/columns to be rotated. The */ +/* > first element of A should be the upper left element to */ +/* > be rotated. */ +/* > Read and modified. */ +/* > */ +/* > LDA - INTEGER */ +/* > The "effective" leading dimension of A. If A contains */ +/* > a matrix stored in GE, HE, or SY format, then this is just */ +/* > the leading dimension of A as dimensioned in the calling */ +/* > routine. If A contains a matrix stored in band (GB, HB, or */ +/* > SB) format, then this should be *one less* than the leading */ +/* > dimension used in the calling routine. Thus, if A were */ +/* > dimensioned A(LDA,*) in CLAROT, then A(1,j) would be the */ +/* > j-th element in the first of the two rows to be rotated, */ +/* > and A(2,j) would be the j-th in the second, regardless of */ +/* > how the array may be stored in the calling routine. [A */ +/* > cannot, however, actually be dimensioned thus, since for */ +/* > band format, the row number may exceed LDA, which is not */ +/* > legal FORTRAN.] */ +/* > If LROWS=.TRUE., then LDA must be at least 1, otherwise */ +/* > it must be at least NL minus the number of .TRUE. values */ +/* > in XLEFT and XRIGHT. */ +/* > Not modified. */ +/* > */ +/* > XLEFT - COMPLEX */ +/* > If LLEFT is .TRUE., then XLEFT will be used and modified */ +/* > instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */ +/* > (if LROWS=.FALSE.). */ +/* > Read and modified. */ +/* > */ +/* > XRIGHT - COMPLEX */ +/* > If LRIGHT is .TRUE., then XRIGHT will be used and modified */ +/* > instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */ +/* > (if LROWS=.FALSE.). */ +/* > Read and modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clarot_(logical *lrows, logical *lleft, logical *lright, + integer *nl, complex *c__, complex *s, complex *a, integer *lda, + complex *xleft, complex *xright) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + complex q__1, q__2, q__3, q__4, q__5, q__6; + + /* Local variables */ + integer iinc, j, inext; + complex tempx; + integer ix, iy, nt; + complex xt[2], yt[2]; + extern /* Subroutine */ int xerbla_(char *, integer *); + integer iyt; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Set up indices, arrays for ends */ + + /* Parameter adjustments */ + --a; + + /* Function Body */ + if (*lrows) { + iinc = *lda; + inext = 1; + } else { + iinc = 1; + inext = *lda; + } + + if (*lleft) { + nt = 1; + ix = iinc + 1; + iy = *lda + 2; + xt[0].r = a[1].r, xt[0].i = a[1].i; + yt[0].r = xleft->r, yt[0].i = xleft->i; + } else { + nt = 0; + ix = 1; + iy = inext + 1; + } + + if (*lright) { + iyt = inext + 1 + (*nl - 1) * iinc; + ++nt; + i__1 = nt - 1; + xt[i__1].r = xright->r, xt[i__1].i = xright->i; + i__1 = nt - 1; + i__2 = iyt; + yt[i__1].r = a[i__2].r, yt[i__1].i = a[i__2].i; + } + +/* Check for errors */ + + if (*nl < nt) { + xerbla_("CLAROT", &c__4); + return 0; + } + if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) { + xerbla_("CLAROT", &c__8); + return 0; + } + +/* Rotate */ + +/* CROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S */ + + i__1 = *nl - nt - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = ix + j * iinc; + q__2.r = c__->r * a[i__2].r - c__->i * a[i__2].i, q__2.i = c__->r * a[ + i__2].i + c__->i * a[i__2].r; + i__3 = iy + j * iinc; + q__3.r = s->r * a[i__3].r - s->i * a[i__3].i, q__3.i = s->r * a[i__3] + .i + s->i * a[i__3].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + tempx.r = q__1.r, tempx.i = q__1.i; + i__2 = iy + j * iinc; + r_cnjg(&q__4, s); + q__3.r = -q__4.r, q__3.i = -q__4.i; + i__3 = ix + j * iinc; + q__2.r = q__3.r * a[i__3].r - q__3.i * a[i__3].i, q__2.i = q__3.r * a[ + i__3].i + q__3.i * a[i__3].r; + r_cnjg(&q__6, c__); + i__4 = iy + j * iinc; + q__5.r = q__6.r * a[i__4].r - q__6.i * a[i__4].i, q__5.i = q__6.r * a[ + i__4].i + q__6.i * a[i__4].r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + i__2 = ix + j * iinc; + a[i__2].r = tempx.r, a[i__2].i = tempx.i; +/* L10: */ + } + +/* CROT( NT, XT,1, YT,1, C, S ) with complex C, S */ + + i__1 = nt; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + q__2.r = c__->r * xt[i__2].r - c__->i * xt[i__2].i, q__2.i = c__->r * + xt[i__2].i + c__->i * xt[i__2].r; + i__3 = j - 1; + q__3.r = s->r * yt[i__3].r - s->i * yt[i__3].i, q__3.i = s->r * yt[ + i__3].i + s->i * yt[i__3].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + tempx.r = q__1.r, tempx.i = q__1.i; + i__2 = j - 1; + r_cnjg(&q__4, s); + q__3.r = -q__4.r, q__3.i = -q__4.i; + i__3 = j - 1; + q__2.r = q__3.r * xt[i__3].r - q__3.i * xt[i__3].i, q__2.i = q__3.r * + xt[i__3].i + q__3.i * xt[i__3].r; + r_cnjg(&q__6, c__); + i__4 = j - 1; + q__5.r = q__6.r * yt[i__4].r - q__6.i * yt[i__4].i, q__5.i = q__6.r * + yt[i__4].i + q__6.i * yt[i__4].r; + q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; + yt[i__2].r = q__1.r, yt[i__2].i = q__1.i; + i__2 = j - 1; + xt[i__2].r = tempx.r, xt[i__2].i = tempx.i; +/* L20: */ + } + +/* Stuff values back into XLEFT, XRIGHT, etc. */ + + if (*lleft) { + a[1].r = xt[0].r, a[1].i = xt[0].i; + xleft->r = yt[0].r, xleft->i = yt[0].i; + } + + if (*lright) { + i__1 = nt - 1; + xright->r = xt[i__1].r, xright->i = xt[i__1].i; + i__1 = iyt; + i__2 = nt - 1; + a[i__1].r = yt[i__2].r, a[i__1].i = yt[i__2].i; + } + + return 0; + +/* End of CLAROT */ + +} /* clarot_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clatm1.c b/lapack-netlib/TESTING/MATGEN/clatm1.c new file mode 100644 index 000000000..cc035b705 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clatm1.c @@ -0,0 +1,732 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATM1 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) */ + +/* INTEGER IDIST, INFO, IRSIGN, MODE, N */ +/* REAL COND */ +/* INTEGER ISEED( 4 ) */ +/* COMPLEX D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATM1 computes the entries of D(1..N) as specified by */ +/* > MODE, COND and IRSIGN. IDIST and ISEED determine the generation */ +/* > of random numbers. CLATM1 is called by CLATMR to generate */ +/* > random test matrices for LAPACK programs. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry describes how D is to be computed: */ +/* > MODE = 0 means do not change D. */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is REAL */ +/* > On entry, used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IRSIGN */ +/* > \verbatim */ +/* > IRSIGN is INTEGER */ +/* > On entry, if MODE neither -6, 0 nor 6, determines sign of */ +/* > entries of D */ +/* > 0 => leave entries of D unchanged */ +/* > 1 => multiply each entry of D by random complex number */ +/* > uniformly distributed with absolute value 1 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => real and imaginary parts each UNIFORM( 0, 1 ) */ +/* > 2 => real and imaginary parts each UNIFORM( -1, 1 ) */ +/* > 3 => real and imaginary parts each NORMAL( 0, 1 ) */ +/* > 4 => complex number uniform in DISK( 0, 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. The random number generator uses a */ +/* > linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to CLATM1 */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is COMPLEX array, dimension ( N ) */ +/* > Array to be computed according to MODE, COND and IRSIGN. */ +/* > May be changed on exit if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of entries of D. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > 0 => normal termination */ +/* > -1 => if MODE not in range -6 to 6 */ +/* > -2 => if MODE neither -6, 0 nor 6, and */ +/* > IRSIGN neither 0 nor 1 */ +/* > -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */ +/* > -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 4 */ +/* > -7 => if N negative */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clatm1_(integer *mode, real *cond, integer *irsign, + integer *idist, integer *iseed, complex *d__, integer *n, integer * + info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + real r__1; + doublereal d__1, d__2; + complex q__1, q__2; + + /* Local variables */ + real temp; + integer i__; + real alpha; + complex ctemp; + //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); + extern complex clarnd_(integer *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *); + extern real slaran_(integer *); + extern /* Subroutine */ int clarnv_(integer *, integer *, integer *, + complex *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and Test the input parameters. Initialize flags & seed. */ + + /* Parameter adjustments */ + --d__; + --iseed; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Set INFO if an error */ + + if (*mode < -6 || *mode > 6) { + *info = -1; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && * + irsign != 1)) { + *info = -2; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) { + *info = -3; + } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 4)) { + *info = -4; + } else if (*n < 0) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLATM1", &i__1); + return 0; + } + +/* Compute D according to COND and MODE */ + + if (*mode != 0) { + switch (abs(*mode)) { + case 1: goto L10; + case 2: goto L30; + case 3: goto L50; + case 4: goto L70; + case 5: goto L90; + case 6: goto L110; + } + +/* One large D value: */ + +L10: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + r__1 = 1.f / *cond; + d__[i__2].r = r__1, d__[i__2].i = 0.f; +/* L20: */ + } + d__[1].r = 1.f, d__[1].i = 0.f; + goto L120; + +/* One small D value: */ + +L30: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d__[i__2].r = 1.f, d__[i__2].i = 0.f; +/* L40: */ + } + i__1 = *n; + r__1 = 1.f / *cond; + d__[i__1].r = r__1, d__[i__1].i = 0.f; + goto L120; + +/* Exponentially distributed D values: */ + +L50: + d__[1].r = 1.f, d__[1].i = 0.f; + if (*n > 1) { + d__1 = (doublereal) (*cond); + d__2 = (doublereal) (-1.f / (real) (*n - 1)); + alpha = pow_dd(&d__1, &d__2); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__ - 1; + r__1 = pow_ri(&alpha, &i__3); + d__[i__2].r = r__1, d__[i__2].i = 0.f; +/* L60: */ + } + } + goto L120; + +/* Arithmetically distributed D values: */ + +L70: + d__[1].r = 1.f, d__[1].i = 0.f; + if (*n > 1) { + temp = 1.f / *cond; + alpha = (1.f - temp) / (real) (*n - 1); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__; + r__1 = (real) (*n - i__) * alpha + temp; + d__[i__2].r = r__1, d__[i__2].i = 0.f; +/* L80: */ + } + } + goto L120; + +/* Randomly distributed D values on ( 1/COND , 1): */ + +L90: + alpha = log(1.f / *cond); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + r__1 = exp(alpha * slaran_(&iseed[1])); + d__[i__2].r = r__1, d__[i__2].i = 0.f; +/* L100: */ + } + goto L120; + +/* Randomly distributed D values from IDIST */ + +L110: + clarnv_(idist, &iseed[1], n, &d__[1]); + +L120: + +/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */ +/* random signs to D */ + + if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + //clarnd_(&q__1, &c__3, &iseed[1]); + q__1=clarnd_(&c__3, &iseed[1]); + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__2 = i__; + i__3 = i__; + r__1 = c_abs(&ctemp); + q__2.r = ctemp.r / r__1, q__2.i = ctemp.i / r__1; + q__1.r = d__[i__3].r * q__2.r - d__[i__3].i * q__2.i, q__1.i = + d__[i__3].r * q__2.i + d__[i__3].i * q__2.r; + d__[i__2].r = q__1.r, d__[i__2].i = q__1.i; +/* L130: */ + } + } + +/* Reverse if MODE < 0 */ + + if (*mode < 0) { + i__1 = *n / 2; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + ctemp.r = d__[i__2].r, ctemp.i = d__[i__2].i; + i__2 = i__; + i__3 = *n + 1 - i__; + d__[i__2].r = d__[i__3].r, d__[i__2].i = d__[i__3].i; + i__2 = *n + 1 - i__; + d__[i__2].r = ctemp.r, d__[i__2].i = ctemp.i; +/* L140: */ + } + } + + } + + return 0; + +/* End of CLATM1 */ + +} /* clatm1_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clatm2.c b/lapack-netlib/TESTING/MATGEN/clatm2.c new file mode 100644 index 000000000..dae8ed1cf --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clatm2.c @@ -0,0 +1,740 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATM2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* COMPLEX FUNCTION CLATM2( M, N, I, J, KL, KU, IDIST, ISEED, D, */ +/* IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) */ + + +/* INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N */ +/* REAL SPARSE */ + + +/* INTEGER ISEED( 4 ), IWORK( * ) */ +/* COMPLEX D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATM2 returns the (I,J) entry of a random matrix of dimension */ +/* > (M, N) described by the other parameters. It is called by the */ +/* > CLATMR routine in order to build random test matrices. No error */ +/* > checking on parameters is done, because this routine is called in */ +/* > a tight loop by CLATMR which has already checked the parameters. */ +/* > */ +/* > Use of CLATM2 differs from CLATM3 in the order in which the random */ +/* > number generator is called to fill in random matrix entries. */ +/* > With CLATM2, the generator is called to fill in the pivoted matrix */ +/* > columnwise. With CLATM3, the generator is called to fill in the */ +/* > matrix columnwise, after which it is pivoted. Thus, CLATM3 can */ +/* > be used to construct random matrices which differ only in their */ +/* > order of rows and/or columns. CLATM2 is used to construct band */ +/* > matrices while avoiding calling the random number generator for */ +/* > entries outside the band (and therefore generating random numbers */ +/* > */ +/* > The matrix whose (I,J) entry is returned is constructed as */ +/* > follows (this routine only computes one entry): */ +/* > */ +/* > If I is outside (1..M) or J is outside (1..N), return zero */ +/* > (this is convenient for generating matrices in band format). */ +/* > */ +/* > Generate a matrix A with random entries of distribution IDIST. */ +/* > */ +/* > Set the diagonal to D. */ +/* > */ +/* > Grade the matrix, if desired, from the left (by DL) and/or */ +/* > from the right (by DR or DL) as specified by IGRADE. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > IPVTNG and IWORK. */ +/* > */ +/* > Band the matrix to have lower bandwidth KL and upper */ +/* > bandwidth KU. */ +/* > */ +/* > Set random entries to zero as specified by SPARSE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > Row of entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J */ +/* > \verbatim */ +/* > J is INTEGER */ +/* > Column of entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > Lower bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > Upper bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => real and imaginary parts each UNIFORM( 0, 1 ) */ +/* > 2 => real and imaginary parts each UNIFORM( -1, 1 ) */ +/* > 3 => real and imaginary parts each NORMAL( 0, 1 ) */ +/* > 4 => complex number uniform in DISK( 0 , 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array of dimension ( 4 ) */ +/* > Seed for random number generator. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is COMPLEX array of dimension ( MIN( I , J ) ) */ +/* > Diagonal entries of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGRADE */ +/* > \verbatim */ +/* > IGRADE is INTEGER */ +/* > Specifies grading of matrix as follows: */ +/* > 0 => no grading */ +/* > 1 => matrix premultiplied by diag( DL ) */ +/* > 2 => matrix postmultiplied by diag( DR ) */ +/* > 3 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > 4 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > 5 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( CONJG(DL) ) */ +/* > 6 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is COMPLEX array ( I or J, as appropriate ) */ +/* > Left scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DR */ +/* > \verbatim */ +/* > DR is COMPLEX array ( I or J, as appropriate ) */ +/* > Right scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPVTNG */ +/* > \verbatim */ +/* > IPVTNG is INTEGER */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 0 => none. */ +/* > 1 => row pivoting. */ +/* > 2 => column pivoting. */ +/* > 3 => full pivoting, i.e., on both sides. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array ( I or J, as appropriate ) */ +/* > This array specifies the permutation used. The */ +/* > row (or column) in position K was originally in */ +/* > position IWORK( K ). */ +/* > This differs from IWORK for CLATM3. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is REAL */ +/* > Value between 0. and 1. */ +/* > On entry specifies the sparsity of the matrix */ +/* > if sparse matrix is to be generated. */ +/* > SPARSE should lie between 0 and 1. */ +/* > A uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Complex */ VOID clatm2_(complex * ret_val, integer *m, integer *n, integer + *i__, integer *j, integer *kl, integer *ku, integer *idist, integer * + iseed, complex *d__, integer *igrade, complex *dl, complex *dr, + integer *ipvtng, integer *iwork, real *sparse) +{ + /* System generated locals */ + integer i__1, i__2; + complex q__1, q__2, q__3; + + /* Local variables */ + integer isub, jsub; + complex ctemp; + //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); + extern complex clarnd_(integer *, integer *); + extern real slaran_(integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + + + + +/* ===================================================================== */ + + + + + + + + + +/* ----------------------------------------------------------------------- */ + + + +/* Check for I and J in range */ + + /* Parameter adjustments */ + --iwork; + --dr; + --dl; + --d__; + --iseed; + + /* Function Body */ + if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) { + ret_val->r = 0.f, ret_val->i = 0.f; + return ; + } + +/* Check for banding */ + + if (*j > *i__ + *ku || *j < *i__ - *kl) { + ret_val->r = 0.f, ret_val->i = 0.f; + return ; + } + +/* Check for sparsity */ + + if (*sparse > 0.f) { + if (slaran_(&iseed[1]) < *sparse) { + ret_val->r = 0.f, ret_val->i = 0.f; + return ; + } + } + +/* Compute subscripts depending on IPVTNG */ + + if (*ipvtng == 0) { + isub = *i__; + jsub = *j; + } else if (*ipvtng == 1) { + isub = iwork[*i__]; + jsub = *j; + } else if (*ipvtng == 2) { + isub = *i__; + jsub = iwork[*j]; + } else if (*ipvtng == 3) { + isub = iwork[*i__]; + jsub = iwork[*j]; + } + +/* Compute entry and grade it according to IGRADE */ + + if (isub == jsub) { + i__1 = isub; + ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i; + } else { + //clarnd_(&q__1, idist, &iseed[1]); + q__1=clarnd_(idist, &iseed[1]); + ctemp.r = q__1.r, ctemp.i = q__1.i; + } + if (*igrade == 1) { + i__1 = isub; + q__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__1.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + ctemp.r = q__1.r, ctemp.i = q__1.i; + } else if (*igrade == 2) { + i__1 = jsub; + q__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, q__1.i = + ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r; + ctemp.r = q__1.r, ctemp.i = q__1.i; + } else if (*igrade == 3) { + i__1 = isub; + q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + i__2 = jsub; + q__1.r = q__2.r * dr[i__2].r - q__2.i * dr[i__2].i, q__1.i = q__2.r * + dr[i__2].i + q__2.i * dr[i__2].r; + ctemp.r = q__1.r, ctemp.i = q__1.i; + } else if (*igrade == 4 && isub != jsub) { + i__1 = isub; + q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + c_div(&q__1, &q__2, &dl[jsub]); + ctemp.r = q__1.r, ctemp.i = q__1.i; + } else if (*igrade == 5) { + i__1 = isub; + q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + r_cnjg(&q__3, &dl[jsub]); + q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i + + q__2.i * q__3.r; + ctemp.r = q__1.r, ctemp.i = q__1.i; + } else if (*igrade == 6) { + i__1 = isub; + q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + i__2 = jsub; + q__1.r = q__2.r * dl[i__2].r - q__2.i * dl[i__2].i, q__1.i = q__2.r * + dl[i__2].i + q__2.i * dl[i__2].r; + ctemp.r = q__1.r, ctemp.i = q__1.i; + } + ret_val->r = ctemp.r, ret_val->i = ctemp.i; + return ; + +/* End of CLATM2 */ + +} /* clatm2_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clatm3.c b/lapack-netlib/TESTING/MATGEN/clatm3.c new file mode 100644 index 000000000..018f07965 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clatm3.c @@ -0,0 +1,758 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATM3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* COMPLEX FUNCTION CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, */ +/* ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, */ +/* SPARSE ) */ + + +/* INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, */ +/* $ KU, M, N */ +/* REAL SPARSE */ + + +/* INTEGER ISEED( 4 ), IWORK( * ) */ +/* COMPLEX D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATM3 returns the (ISUB,JSUB) entry of a random matrix of */ +/* > dimension (M, N) described by the other parameters. (ISUB,JSUB) */ +/* > is the final position of the (I,J) entry after pivoting */ +/* > according to IPVTNG and IWORK. CLATM3 is called by the */ +/* > CLATMR routine in order to build random test matrices. No error */ +/* > checking on parameters is done, because this routine is called in */ +/* > a tight loop by CLATMR which has already checked the parameters. */ +/* > */ +/* > Use of CLATM3 differs from CLATM2 in the order in which the random */ +/* > number generator is called to fill in random matrix entries. */ +/* > With CLATM2, the generator is called to fill in the pivoted matrix */ +/* > columnwise. With CLATM3, the generator is called to fill in the */ +/* > matrix columnwise, after which it is pivoted. Thus, CLATM3 can */ +/* > be used to construct random matrices which differ only in their */ +/* > order of rows and/or columns. CLATM2 is used to construct band */ +/* > matrices while avoiding calling the random number generator for */ +/* > entries outside the band (and therefore generating random numbers */ +/* > in different orders for different pivot orders). */ +/* > */ +/* > The matrix whose (ISUB,JSUB) entry is returned is constructed as */ +/* > follows (this routine only computes one entry): */ +/* > */ +/* > If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */ +/* > (this is convenient for generating matrices in band format). */ +/* > */ +/* > Generate a matrix A with random entries of distribution IDIST. */ +/* > */ +/* > Set the diagonal to D. */ +/* > */ +/* > Grade the matrix, if desired, from the left (by DL) and/or */ +/* > from the right (by DR or DL) as specified by IGRADE. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > IPVTNG and IWORK. */ +/* > */ +/* > Band the matrix to have lower bandwidth KL and upper */ +/* > bandwidth KU. */ +/* > */ +/* > Set random entries to zero as specified by SPARSE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > Row of unpivoted entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J */ +/* > \verbatim */ +/* > J is INTEGER */ +/* > Column of unpivoted entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISUB */ +/* > \verbatim */ +/* > ISUB is INTEGER */ +/* > Row of pivoted entry to be returned. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JSUB */ +/* > \verbatim */ +/* > JSUB is INTEGER */ +/* > Column of pivoted entry to be returned. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > Lower bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > Upper bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => real and imaginary parts each UNIFORM( 0, 1 ) */ +/* > 2 => real and imaginary parts each UNIFORM( -1, 1 ) */ +/* > 3 => real and imaginary parts each NORMAL( 0, 1 ) */ +/* > 4 => complex number uniform in DISK( 0 , 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array of dimension ( 4 ) */ +/* > Seed for random number generator. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is COMPLEX array of dimension ( MIN( I , J ) ) */ +/* > Diagonal entries of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGRADE */ +/* > \verbatim */ +/* > IGRADE is INTEGER */ +/* > Specifies grading of matrix as follows: */ +/* > 0 => no grading */ +/* > 1 => matrix premultiplied by diag( DL ) */ +/* > 2 => matrix postmultiplied by diag( DR ) */ +/* > 3 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > 4 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > 5 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( CONJG(DL) ) */ +/* > 6 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is COMPLEX array ( I or J, as appropriate ) */ +/* > Left scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DR */ +/* > \verbatim */ +/* > DR is COMPLEX array ( I or J, as appropriate ) */ +/* > Right scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPVTNG */ +/* > \verbatim */ +/* > IPVTNG is INTEGER */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 0 => none. */ +/* > 1 => row pivoting. */ +/* > 2 => column pivoting. */ +/* > 3 => full pivoting, i.e., on both sides. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array ( I or J, as appropriate ) */ +/* > This array specifies the permutation used. The */ +/* > row (or column) originally in position K is in */ +/* > position IWORK( K ) after pivoting. */ +/* > This differs from IWORK for CLATM2. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is REAL between 0. and 1. */ +/* > On entry specifies the sparsity of the matrix */ +/* > if sparse matrix is to be generated. */ +/* > SPARSE should lie between 0 and 1. */ +/* > A uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Complex */ VOID clatm3_(complex * ret_val, integer *m, integer *n, integer + *i__, integer *j, integer *isub, integer *jsub, integer *kl, integer * + ku, integer *idist, integer *iseed, complex *d__, integer *igrade, + complex *dl, complex *dr, integer *ipvtng, integer *iwork, real * + sparse) +{ + /* System generated locals */ + integer i__1, i__2; + complex q__1, q__2, q__3; + + /* Local variables */ + complex ctemp; + //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); + extern complex clarnd_(integer *, integer *); + extern real slaran_(integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + + + + +/* ===================================================================== */ + + + + + + + + + +/* ----------------------------------------------------------------------- */ + + + +/* Check for I and J in range */ + + /* Parameter adjustments */ + --iwork; + --dr; + --dl; + --d__; + --iseed; + + /* Function Body */ + if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) { + *isub = *i__; + *jsub = *j; + ret_val->r = 0.f, ret_val->i = 0.f; + return ; + } + +/* Compute subscripts depending on IPVTNG */ + + if (*ipvtng == 0) { + *isub = *i__; + *jsub = *j; + } else if (*ipvtng == 1) { + *isub = iwork[*i__]; + *jsub = *j; + } else if (*ipvtng == 2) { + *isub = *i__; + *jsub = iwork[*j]; + } else if (*ipvtng == 3) { + *isub = iwork[*i__]; + *jsub = iwork[*j]; + } + +/* Check for banding */ + + if (*jsub > *isub + *ku || *jsub < *isub - *kl) { + ret_val->r = 0.f, ret_val->i = 0.f; + return ; + } + +/* Check for sparsity */ + + if (*sparse > 0.f) { + if (slaran_(&iseed[1]) < *sparse) { + ret_val->r = 0.f, ret_val->i = 0.f; + return ; + } + } + +/* Compute entry and grade it according to IGRADE */ + + if (*i__ == *j) { + i__1 = *i__; + ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i; + } else { + //clarnd_(&q__1, idist, &iseed[1]); + q__1=clarnd_(idist, &iseed[1]); + ctemp.r = q__1.r, ctemp.i = q__1.i; + } + if (*igrade == 1) { + i__1 = *i__; + q__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__1.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + ctemp.r = q__1.r, ctemp.i = q__1.i; + } else if (*igrade == 2) { + i__1 = *j; + q__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, q__1.i = + ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r; + ctemp.r = q__1.r, ctemp.i = q__1.i; + } else if (*igrade == 3) { + i__1 = *i__; + q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + i__2 = *j; + q__1.r = q__2.r * dr[i__2].r - q__2.i * dr[i__2].i, q__1.i = q__2.r * + dr[i__2].i + q__2.i * dr[i__2].r; + ctemp.r = q__1.r, ctemp.i = q__1.i; + } else if (*igrade == 4 && *i__ != *j) { + i__1 = *i__; + q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + c_div(&q__1, &q__2, &dl[*j]); + ctemp.r = q__1.r, ctemp.i = q__1.i; + } else if (*igrade == 5) { + i__1 = *i__; + q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + r_cnjg(&q__3, &dl[*j]); + q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i + + q__2.i * q__3.r; + ctemp.r = q__1.r, ctemp.i = q__1.i; + } else if (*igrade == 6) { + i__1 = *i__; + q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + i__2 = *j; + q__1.r = q__2.r * dl[i__2].r - q__2.i * dl[i__2].i, q__1.i = q__2.r * + dl[i__2].i + q__2.i * dl[i__2].r; + ctemp.r = q__1.r, ctemp.i = q__1.i; + } + ret_val->r = ctemp.r, ret_val->i = ctemp.i; + return ; + +/* End of CLATM3 */ + +} /* clatm3_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clatm5.c b/lapack-netlib/TESTING/MATGEN/clatm5.c new file mode 100644 index 000000000..ae2613689 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clatm5.c @@ -0,0 +1,1158 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATM5 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, */ +/* E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, */ +/* QBLCKB ) */ + +/* INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, */ +/* $ PRTYPE, QBLCKA, QBLCKB */ +/* REAL ALPHA */ +/* COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), */ +/* $ D( LDD, * ), E( LDE, * ), F( LDF, * ), */ +/* $ L( LDL, * ), R( LDR, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATM5 generates matrices involved in the Generalized Sylvester */ +/* > equation: */ +/* > */ +/* > A * R - L * B = C */ +/* > D * R - L * E = F */ +/* > */ +/* > They also satisfy (the diagonalization condition) */ +/* > */ +/* > [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] ) */ +/* > [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] ) */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PRTYPE */ +/* > \verbatim */ +/* > PRTYPE is INTEGER */ +/* > "Points" to a certain type of the matrices to generate */ +/* > (see further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Specifies the order of A and D and the number of rows in */ +/* > C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Specifies the order of B and E and the number of columns in */ +/* > C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA, M). */ +/* > On exit A M-by-M is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDB, N). */ +/* > On exit B N-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is COMPLEX array, dimension (LDC, N). */ +/* > On exit C M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of C. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is COMPLEX array, dimension (LDD, M). */ +/* > On exit D M-by-M is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDD */ +/* > \verbatim */ +/* > LDD is INTEGER */ +/* > The leading dimension of D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is COMPLEX array, dimension (LDE, N). */ +/* > On exit E N-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDE */ +/* > \verbatim */ +/* > LDE is INTEGER */ +/* > The leading dimension of E. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] F */ +/* > \verbatim */ +/* > F is COMPLEX array, dimension (LDF, N). */ +/* > On exit F M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of F. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is COMPLEX array, dimension (LDR, N). */ +/* > On exit R M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDR */ +/* > \verbatim */ +/* > LDR is INTEGER */ +/* > The leading dimension of R. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is COMPLEX array, dimension (LDL, N). */ +/* > On exit L M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDL */ +/* > \verbatim */ +/* > LDL is INTEGER */ +/* > The leading dimension of L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > Parameter used in generating PRTYPE = 1 and 5 matrices. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QBLCKA */ +/* > \verbatim */ +/* > QBLCKA is INTEGER */ +/* > When PRTYPE = 3, specifies the distance between 2-by-2 */ +/* > blocks on the diagonal in A. Otherwise, QBLCKA is not */ +/* > referenced. QBLCKA > 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QBLCKB */ +/* > \verbatim */ +/* > QBLCKB is INTEGER */ +/* > When PRTYPE = 3, specifies the distance between 2-by-2 */ +/* > blocks on the diagonal in B. Otherwise, QBLCKB is not */ +/* > referenced. QBLCKB > 1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex_matgen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */ +/* > */ +/* > A : if (i == j) then A(i, j) = 1.0 */ +/* > if (j == i + 1) then A(i, j) = -1.0 */ +/* > else A(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > B : if (i == j) then B(i, j) = 1.0 - ALPHA */ +/* > if (j == i + 1) then B(i, j) = 1.0 */ +/* > else B(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > D : if (i == j) then D(i, j) = 1.0 */ +/* > else D(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > E : if (i == j) then E(i, j) = 1.0 */ +/* > else E(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > L = R are chosen from [-10...10], */ +/* > which specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */ +/* > */ +/* > A : if (i <= j) then A(i, j) = [-1...1] */ +/* > else A(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > if (PRTYPE = 3) then */ +/* > A(k + 1, k + 1) = A(k, k) */ +/* > A(k + 1, k) = [-1...1] */ +/* > sign(A(k, k + 1) = -(sin(A(k + 1, k)) */ +/* > k = 1, M - 1, QBLCKA */ +/* > */ +/* > B : if (i <= j) then B(i, j) = [-1...1] */ +/* > else B(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > if (PRTYPE = 3) then */ +/* > B(k + 1, k + 1) = B(k, k) */ +/* > B(k + 1, k) = [-1...1] */ +/* > sign(B(k, k + 1) = -(sign(B(k + 1, k)) */ +/* > k = 1, N - 1, QBLCKB */ +/* > */ +/* > D : if (i <= j) then D(i, j) = [-1...1]. */ +/* > else D(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > */ +/* > E : if (i <= j) then D(i, j) = [-1...1] */ +/* > else E(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > L, R are chosen from [-10...10], */ +/* > which specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 4 Full */ +/* > A(i, j) = [-10...10] */ +/* > D(i, j) = [-1...1] i,j = 1...M */ +/* > B(i, j) = [-10...10] */ +/* > E(i, j) = [-1...1] i,j = 1...N */ +/* > R(i, j) = [-10...10] */ +/* > L(i, j) = [-1...1] i = 1..M ,j = 1...N */ +/* > */ +/* > L, R specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 5 special case common and/or close eigs. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int clatm5_(integer *prtype, integer *m, integer *n, complex + *a, integer *lda, complex *b, integer *ldb, complex *c__, integer * + ldc, complex *d__, integer *ldd, complex *e, integer *lde, complex *f, + integer *ldf, complex *r__, integer *ldr, complex *l, integer *ldl, + real *alpha, integer *qblcka, integer *qblckb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset, + r_dim1, r_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + complex q__1, q__2, q__3, q__4, q__5; + + /* Local variables */ + integer i__, j, k; + extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, + integer *, complex *, complex *, integer *, complex *, integer *, + complex *, complex *, integer *); + complex imeps, reeps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + r_dim1 = *ldr; + r_offset = 1 + r_dim1 * 1; + r__ -= r_offset; + l_dim1 = *ldl; + l_offset = 1 + l_dim1 * 1; + l -= l_offset; + + /* Function Body */ + if (*prtype == 1) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + if (i__ == j) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 1.f, a[i__3].i = 0.f; + i__3 = i__ + j * d_dim1; + d__[i__3].r = 1.f, d__[i__3].i = 0.f; + } else if (i__ == j - 1) { + i__3 = i__ + j * a_dim1; + q__1.r = -1.f, q__1.i = 0.f; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + i__3 = i__ + j * d_dim1; + d__[i__3].r = 0.f, d__[i__3].i = 0.f; + } else { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + i__3 = i__ + j * d_dim1; + d__[i__3].r = 0.f, d__[i__3].i = 0.f; + } +/* L10: */ + } +/* L20: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (i__ == j) { + i__3 = i__ + j * b_dim1; + q__1.r = 1.f - *alpha, q__1.i = 0.f; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + i__3 = i__ + j * e_dim1; + e[i__3].r = 1.f, e[i__3].i = 0.f; + } else if (i__ == j - 1) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 1.f, b[i__3].i = 0.f; + i__3 = i__ + j * e_dim1; + e[i__3].r = 0.f, e[i__3].i = 0.f; + } else { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; + i__3 = i__ + j * e_dim1; + e[i__3].r = 0.f, e[i__3].i = 0.f; + } +/* L30: */ + } +/* L40: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * r_dim1; + i__4 = i__ / j; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + + q__2.i * 20.f; + r__[i__3].r = q__1.r, r__[i__3].i = q__1.i; + i__3 = i__ + j * l_dim1; + i__4 = i__ + j * r_dim1; + l[i__3].r = r__[i__4].r, l[i__3].i = r__[i__4].i; +/* L50: */ + } +/* L60: */ + } + + } else if (*prtype == 2 || *prtype == 3) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + if (i__ <= j) { + i__3 = i__ + j * a_dim1; + q__4.r = (real) i__, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * + 0.f + q__2.i * 2.f; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + i__3 = i__ + j * d_dim1; + i__4 = i__ * j; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * + 0.f + q__2.i * 2.f; + d__[i__3].r = q__1.r, d__[i__3].i = q__1.i; + } else { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + i__3 = i__ + j * d_dim1; + d__[i__3].r = 0.f, d__[i__3].i = 0.f; + } +/* L70: */ + } +/* L80: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (i__ <= j) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * + 0.f + q__2.i * 2.f; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + i__3 = i__ + j * e_dim1; + q__4.r = (real) j, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * + 0.f + q__2.i * 2.f; + e[i__3].r = q__1.r, e[i__3].i = q__1.i; + } else { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; + i__3 = i__ + j * e_dim1; + e[i__3].r = 0.f, e[i__3].i = 0.f; + } +/* L90: */ + } +/* L100: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * r_dim1; + i__4 = i__ * j; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + + q__2.i * 20.f; + r__[i__3].r = q__1.r, r__[i__3].i = q__1.i; + i__3 = i__ + j * l_dim1; + i__4 = i__ + j; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + + q__2.i * 20.f; + l[i__3].r = q__1.r, l[i__3].i = q__1.i; +/* L110: */ + } +/* L120: */ + } + + if (*prtype == 3) { + if (*qblcka <= 1) { + *qblcka = 2; + } + i__1 = *m - 1; + i__2 = *qblcka; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { + i__3 = k + 1 + (k + 1) * a_dim1; + i__4 = k + k * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + i__3 = k + 1 + k * a_dim1; + c_sin(&q__2, &a[k + (k + 1) * a_dim1]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L130: */ + } + + if (*qblckb <= 1) { + *qblckb = 2; + } + i__2 = *n - 1; + i__1 = *qblckb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { + i__3 = k + 1 + (k + 1) * b_dim1; + i__4 = k + k * b_dim1; + b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i; + i__3 = k + 1 + k * b_dim1; + c_sin(&q__2, &b[k + (k + 1) * b_dim1]); + q__1.r = -q__2.r, q__1.i = -q__2.i; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; +/* L140: */ + } + } + + } else if (*prtype == 4) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + i__4 = i__ * j; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + + q__2.i * 20.f; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + i__3 = i__ + j * d_dim1; + i__4 = i__ + j; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + + q__2.i * 2.f; + d__[i__3].r = q__1.r, d__[i__3].i = q__1.i; +/* L150: */ + } +/* L160: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + + q__2.i * 20.f; + b[i__3].r = q__1.r, b[i__3].i = q__1.i; + i__3 = i__ + j * e_dim1; + i__4 = i__ * j; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + + q__2.i * 2.f; + e[i__3].r = q__1.r, e[i__3].i = q__1.i; +/* L170: */ + } +/* L180: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * r_dim1; + i__4 = j / i__; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 20.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + + q__2.i * 20.f; + r__[i__3].r = q__1.r, r__[i__3].i = q__1.i; + i__3 = i__ + j * l_dim1; + i__4 = i__ * j; + q__4.r = (real) i__4, q__4.i = 0.f; + c_sin(&q__3, &q__4); + q__2.r = .5f - q__3.r, q__2.i = 0.f - q__3.i; + q__1.r = q__2.r * 2.f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + + q__2.i * 2.f; + l[i__3].r = q__1.r, l[i__3].i = q__1.i; +/* L190: */ + } +/* L200: */ + } + + } else if (*prtype >= 5) { + q__3.r = 1.f, q__3.i = 0.f; + q__2.r = q__3.r * 20.f - q__3.i * 0.f, q__2.i = q__3.r * 0.f + q__3.i + * 20.f; + q__1.r = q__2.r / *alpha, q__1.i = q__2.i / *alpha; + reeps.r = q__1.r, reeps.i = q__1.i; + q__2.r = -1.5f, q__2.i = 0.f; + q__1.r = q__2.r / *alpha, q__1.i = q__2.i / *alpha; + imeps.r = q__1.r, imeps.i = q__1.i; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * r_dim1; + i__4 = i__ * j; + q__5.r = (real) i__4, q__5.i = 0.f; + c_sin(&q__4, &q__5); + q__3.r = .5f - q__4.r, q__3.i = 0.f - q__4.i; + q__2.r = *alpha * q__3.r, q__2.i = *alpha * q__3.i; + c_div(&q__1, &q__2, &c_b5); + r__[i__3].r = q__1.r, r__[i__3].i = q__1.i; + i__3 = i__ + j * l_dim1; + i__4 = i__ + j; + q__5.r = (real) i__4, q__5.i = 0.f; + c_sin(&q__4, &q__5); + q__3.r = .5f - q__4.r, q__3.i = 0.f - q__4.i; + q__2.r = *alpha * q__3.r, q__2.i = *alpha * q__3.i; + c_div(&q__1, &q__2, &c_b5); + l[i__3].r = q__1.r, l[i__3].i = q__1.i; +/* L210: */ + } +/* L220: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * d_dim1; + d__[i__2].r = 1.f, d__[i__2].i = 0.f; +/* L230: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ <= 4) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + if (i__ > 2) { + i__2 = i__ + i__ * a_dim1; + q__1.r = reeps.r + 1.f, q__1.i = reeps.i + 0.f; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + if (i__ % 2 != 0 && i__ < *m) { + i__2 = i__ + (i__ + 1) * a_dim1; + a[i__2].r = imeps.r, a[i__2].i = imeps.i; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * a_dim1; + q__1.r = -imeps.r, q__1.i = -imeps.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + } else if (i__ <= 8) { + if (i__ <= 6) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = reeps.r, a[i__2].i = reeps.i; + } else { + i__2 = i__ + i__ * a_dim1; + q__1.r = -reeps.r, q__1.i = -reeps.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + if (i__ % 2 != 0 && i__ < *m) { + i__2 = i__ + (i__ + 1) * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * a_dim1; + q__1.r = -1.f, q__1.i = 0.f; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + } else { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1.f, a[i__2].i = 0.f; + if (i__ % 2 != 0 && i__ < *m) { + i__2 = i__ + (i__ + 1) * a_dim1; + d__1 = 2.; + q__1.r = d__1 * imeps.r, q__1.i = d__1 * imeps.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * a_dim1; + q__2.r = -imeps.r, q__2.i = -imeps.i; + d__1 = 2.; + q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; + } + } +/* L240: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * e_dim1; + e[i__2].r = 1.f, e[i__2].i = 0.f; + if (i__ <= 4) { + i__2 = i__ + i__ * b_dim1; + q__1.r = -1.f, q__1.i = 0.f; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + if (i__ > 2) { + i__2 = i__ + i__ * b_dim1; + q__1.r = 1.f - reeps.r, q__1.i = 0.f - reeps.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + } + if (i__ % 2 != 0 && i__ < *n) { + i__2 = i__ + (i__ + 1) * b_dim1; + b[i__2].r = imeps.r, b[i__2].i = imeps.i; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * b_dim1; + q__1.r = -imeps.r, q__1.i = -imeps.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + } + } else if (i__ <= 8) { + if (i__ <= 6) { + i__2 = i__ + i__ * b_dim1; + b[i__2].r = reeps.r, b[i__2].i = reeps.i; + } else { + i__2 = i__ + i__ * b_dim1; + q__1.r = -reeps.r, q__1.i = -reeps.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + } + if (i__ % 2 != 0 && i__ < *n) { + i__2 = i__ + (i__ + 1) * b_dim1; + q__1.r = imeps.r + 1.f, q__1.i = imeps.i + 0.f; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * b_dim1; + q__2.r = -1.f, q__2.i = 0.f; + q__1.r = q__2.r - imeps.r, q__1.i = q__2.i - imeps.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + } + } else { + i__2 = i__ + i__ * b_dim1; + q__1.r = 1.f - reeps.r, q__1.i = 0.f - reeps.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + if (i__ % 2 != 0 && i__ < *n) { + i__2 = i__ + (i__ + 1) * b_dim1; + d__1 = 2.; + q__1.r = d__1 * imeps.r, q__1.i = d__1 * imeps.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * b_dim1; + q__2.r = -imeps.r, q__2.i = -imeps.i; + d__1 = 2.; + q__1.r = d__1 * q__2.r, q__1.i = d__1 * q__2.i; + b[i__2].r = q__1.r, b[i__2].i = q__1.i; + } + } +/* L250: */ + } + } + +/* Compute rhs (C, F) */ + + cgemm_("N", "N", m, n, m, &c_b1, &a[a_offset], lda, &r__[r_offset], ldr, & + c_b3, &c__[c_offset], ldc); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, n, n, &q__1, &l[l_offset], ldl, &b[b_offset], ldb, & + c_b1, &c__[c_offset], ldc); + cgemm_("N", "N", m, n, m, &c_b1, &d__[d_offset], ldd, &r__[r_offset], ldr, + &c_b3, &f[f_offset], ldf); + q__1.r = -1.f, q__1.i = 0.f; + cgemm_("N", "N", m, n, n, &q__1, &l[l_offset], ldl, &e[e_offset], lde, & + c_b1, &f[f_offset], ldf); + +/* End of CLATM5 */ + + return 0; +} /* clatm5_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clatm6.c b/lapack-netlib/TESTING/MATGEN/clatm6.c new file mode 100644 index 000000000..b2ddc74be --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clatm6.c @@ -0,0 +1,815 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATM6 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, */ +/* BETA, WX, WY, S, DIF ) */ + +/* INTEGER LDA, LDX, LDY, N, TYPE */ +/* COMPLEX ALPHA, BETA, WX, WY */ +/* REAL DIF( * ), S( * ) */ +/* COMPLEX A( LDA, * ), B( LDA, * ), X( LDX, * ), */ +/* $ Y( LDY, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATM6 generates test matrices for the generalized eigenvalue */ +/* > problem, their corresponding right and left eigenvector matrices, */ +/* > and also reciprocal condition numbers for all eigenvalues and */ +/* > the reciprocal condition numbers of eigenvectors corresponding to */ +/* > the 1th and 5th eigenvalues. */ +/* > */ +/* > Test Matrices */ +/* > ============= */ +/* > */ +/* > Two kinds of test matrix pairs */ +/* > (A, B) = inverse(YH) * (Da, Db) * inverse(X) */ +/* > are used in the tests: */ +/* > */ +/* > Type 1: */ +/* > Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */ +/* > 0 2+a 0 0 0 0 1 0 0 0 */ +/* > 0 0 3+a 0 0 0 0 1 0 0 */ +/* > 0 0 0 4+a 0 0 0 0 1 0 */ +/* > 0 0 0 0 5+a , 0 0 0 0 1 */ +/* > and Type 2: */ +/* > Da = 1+i 0 0 0 0 Db = 1 0 0 0 0 */ +/* > 0 1-i 0 0 0 0 1 0 0 0 */ +/* > 0 0 1 0 0 0 0 1 0 0 */ +/* > 0 0 0 (1+a)+(1+b)i 0 0 0 0 1 0 */ +/* > 0 0 0 0 (1+a)-(1+b)i, 0 0 0 0 1 . */ +/* > */ +/* > In both cases the same inverse(YH) and inverse(X) are used to compute */ +/* > (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */ +/* > */ +/* > YH: = 1 0 -y y -y X = 1 0 -x -x x */ +/* > 0 1 -y y -y 0 1 x -x -x */ +/* > 0 0 1 0 0 0 0 1 0 0 */ +/* > 0 0 0 1 0 0 0 0 1 0 */ +/* > 0 0 0 0 1, 0 0 0 0 1 , where */ +/* > */ +/* > a, b, x and y will have all values independently of each other. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TYPE */ +/* > \verbatim */ +/* > TYPE is INTEGER */ +/* > Specifies the problem type (see further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Size of the matrices A and B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA, N). */ +/* > On exit A N-by-N is initialized according to TYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A and of B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is COMPLEX array, dimension (LDA, N). */ +/* > On exit B N-by-N is initialized according to TYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX, N). */ +/* > On exit X is the N-by-N matrix of right eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of X. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX array, dimension (LDY, N). */ +/* > On exit Y is the N-by-N matrix of left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is COMPLEX */ +/* > */ +/* > Weighting constants for matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WX */ +/* > \verbatim */ +/* > WX is COMPLEX */ +/* > Constant for right eigenvector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WY */ +/* > \verbatim */ +/* > WY is COMPLEX */ +/* > Constant for left eigenvector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > S(i) is the reciprocal condition number for eigenvalue i. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is REAL array, dimension (N) */ +/* > DIF(i) is the reciprocal condition number for eigenvector i. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clatm6_(integer *type__, integer *n, complex *a, integer + *lda, complex *b, complex *x, integer *ldx, complex *y, integer *ldy, + complex *alpha, complex *beta, complex *wx, complex *wy, real *s, + real *dif) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1, + y_offset, i__1, i__2, i__3; + real r__1, r__2; + complex q__1, q__2, q__3, q__4; + + /* Local variables */ + integer info; + complex work[26]; + integer i__, j; + complex z__[64] /* was [8][8] */; + extern /* Subroutine */ int clakf2_(integer *, integer *, complex *, + integer *, complex *, complex *, complex *, complex *, integer *); + real rwork[50]; + extern /* Subroutine */ int cgesvd_(char *, char *, integer *, integer *, + complex *, integer *, real *, complex *, integer *, complex *, + integer *, complex *, integer *, real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer + *, complex *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Generate test problem ... */ +/* (Da, Db) ... */ + + /* Parameter adjustments */ + b_dim1 = *lda; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --s; + --dif; + + /* Function Body */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + + if (i__ == j) { + i__3 = i__ + i__ * a_dim1; + q__2.r = (real) i__, q__2.i = 0.f; + q__1.r = q__2.r + alpha->r, q__1.i = q__2.i + alpha->i; + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + i__3 = i__ + i__ * b_dim1; + b[i__3].r = 1.f, b[i__3].i = 0.f; + } else { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + i__3 = i__ + j * b_dim1; + b[i__3].r = 0.f, b[i__3].i = 0.f; + } + +/* L10: */ + } +/* L20: */ + } + if (*type__ == 2) { + i__1 = a_dim1 + 1; + a[i__1].r = 1.f, a[i__1].i = 1.f; + i__1 = (a_dim1 << 1) + 2; + r_cnjg(&q__1, &a[a_dim1 + 1]); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = a_dim1 * 3 + 3; + a[i__1].r = 1.f, a[i__1].i = 0.f; + i__1 = (a_dim1 << 2) + 4; + q__2.r = alpha->r + 1.f, q__2.i = alpha->i + 0.f; + r__1 = q__2.r; + q__3.r = beta->r + 1.f, q__3.i = beta->i + 0.f; + r__2 = q__3.r; + q__1.r = r__1, q__1.i = r__2; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = a_dim1 * 5 + 5; + r_cnjg(&q__1, &a[(a_dim1 << 2) + 4]); + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + } + +/* Form X and Y */ + + clacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy); + i__1 = y_dim1 + 3; + r_cnjg(&q__2, wy); + q__1.r = -q__2.r, q__1.i = -q__2.i; + y[i__1].r = q__1.r, y[i__1].i = q__1.i; + i__1 = y_dim1 + 4; + r_cnjg(&q__1, wy); + y[i__1].r = q__1.r, y[i__1].i = q__1.i; + i__1 = y_dim1 + 5; + r_cnjg(&q__2, wy); + q__1.r = -q__2.r, q__1.i = -q__2.i; + y[i__1].r = q__1.r, y[i__1].i = q__1.i; + i__1 = (y_dim1 << 1) + 3; + r_cnjg(&q__2, wy); + q__1.r = -q__2.r, q__1.i = -q__2.i; + y[i__1].r = q__1.r, y[i__1].i = q__1.i; + i__1 = (y_dim1 << 1) + 4; + r_cnjg(&q__1, wy); + y[i__1].r = q__1.r, y[i__1].i = q__1.i; + i__1 = (y_dim1 << 1) + 5; + r_cnjg(&q__2, wy); + q__1.r = -q__2.r, q__1.i = -q__2.i; + y[i__1].r = q__1.r, y[i__1].i = q__1.i; + + clacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx); + i__1 = x_dim1 * 3 + 1; + q__1.r = -wx->r, q__1.i = -wx->i; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + i__1 = (x_dim1 << 2) + 1; + q__1.r = -wx->r, q__1.i = -wx->i; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + i__1 = x_dim1 * 5 + 1; + x[i__1].r = wx->r, x[i__1].i = wx->i; + i__1 = x_dim1 * 3 + 2; + x[i__1].r = wx->r, x[i__1].i = wx->i; + i__1 = (x_dim1 << 2) + 2; + q__1.r = -wx->r, q__1.i = -wx->i; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + i__1 = x_dim1 * 5 + 2; + q__1.r = -wx->r, q__1.i = -wx->i; + x[i__1].r = q__1.r, x[i__1].i = q__1.i; + +/* Form (A, B) */ + + i__1 = b_dim1 * 3 + 1; + q__1.r = wx->r + wy->r, q__1.i = wx->i + wy->i; + b[i__1].r = q__1.r, b[i__1].i = q__1.i; + i__1 = b_dim1 * 3 + 2; + q__2.r = -wx->r, q__2.i = -wx->i; + q__1.r = q__2.r + wy->r, q__1.i = q__2.i + wy->i; + b[i__1].r = q__1.r, b[i__1].i = q__1.i; + i__1 = (b_dim1 << 2) + 1; + q__1.r = wx->r - wy->r, q__1.i = wx->i - wy->i; + b[i__1].r = q__1.r, b[i__1].i = q__1.i; + i__1 = (b_dim1 << 2) + 2; + q__1.r = wx->r - wy->r, q__1.i = wx->i - wy->i; + b[i__1].r = q__1.r, b[i__1].i = q__1.i; + i__1 = b_dim1 * 5 + 1; + q__2.r = -wx->r, q__2.i = -wx->i; + q__1.r = q__2.r + wy->r, q__1.i = q__2.i + wy->i; + b[i__1].r = q__1.r, b[i__1].i = q__1.i; + i__1 = b_dim1 * 5 + 2; + q__1.r = wx->r + wy->r, q__1.i = wx->i + wy->i; + b[i__1].r = q__1.r, b[i__1].i = q__1.i; + i__1 = a_dim1 * 3 + 1; + i__2 = a_dim1 + 1; + q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2] + .i + wx->i * a[i__2].r; + i__3 = a_dim1 * 3 + 3; + q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = a_dim1 * 3 + 2; + q__3.r = -wx->r, q__3.i = -wx->i; + i__2 = (a_dim1 << 1) + 2; + q__2.r = q__3.r * a[i__2].r - q__3.i * a[i__2].i, q__2.i = q__3.r * a[ + i__2].i + q__3.i * a[i__2].r; + i__3 = a_dim1 * 3 + 3; + q__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__4.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = (a_dim1 << 2) + 1; + i__2 = a_dim1 + 1; + q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2] + .i + wx->i * a[i__2].r; + i__3 = (a_dim1 << 2) + 4; + q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = (a_dim1 << 2) + 2; + i__2 = (a_dim1 << 1) + 2; + q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2] + .i + wx->i * a[i__2].r; + i__3 = (a_dim1 << 2) + 4; + q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = a_dim1 * 5 + 1; + q__3.r = -wx->r, q__3.i = -wx->i; + i__2 = a_dim1 + 1; + q__2.r = q__3.r * a[i__2].r - q__3.i * a[i__2].i, q__2.i = q__3.r * a[ + i__2].i + q__3.i * a[i__2].r; + i__3 = a_dim1 * 5 + 5; + q__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__4.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + i__1 = a_dim1 * 5 + 2; + i__2 = (a_dim1 << 1) + 2; + q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2] + .i + wx->i * a[i__2].r; + i__3 = a_dim1 * 5 + 5; + q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; + a[i__1].r = q__1.r, a[i__1].i = q__1.i; + +/* Compute condition numbers */ + + s[1] = 1.f / sqrt((c_abs(wy) * 3.f * c_abs(wy) + 1.f) / (c_abs(&a[a_dim1 + + 1]) * c_abs(&a[a_dim1 + 1]) + 1.f)); + s[2] = 1.f / sqrt((c_abs(wy) * 3.f * c_abs(wy) + 1.f) / (c_abs(&a[(a_dim1 + << 1) + 2]) * c_abs(&a[(a_dim1 << 1) + 2]) + 1.f)); + s[3] = 1.f / sqrt((c_abs(wx) * 2.f * c_abs(wx) + 1.f) / (c_abs(&a[a_dim1 * + 3 + 3]) * c_abs(&a[a_dim1 * 3 + 3]) + 1.f)); + s[4] = 1.f / sqrt((c_abs(wx) * 2.f * c_abs(wx) + 1.f) / (c_abs(&a[(a_dim1 + << 2) + 4]) * c_abs(&a[(a_dim1 << 2) + 4]) + 1.f)); + s[5] = 1.f / sqrt((c_abs(wx) * 2.f * c_abs(wx) + 1.f) / (c_abs(&a[a_dim1 * + 5 + 5]) * c_abs(&a[a_dim1 * 5 + 5]) + 1.f)); + + clakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[ + b_offset], &b[(b_dim1 << 1) + 2], z__, &c__8); + cgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1], + &c__1, &work[2], &c__24, &rwork[8], &info); + dif[1] = rwork[7]; + + clakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[b_offset], + &b[b_dim1 * 5 + 5], z__, &c__8); + cgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1], + &c__1, &work[2], &c__24, &rwork[8], &info); + dif[5] = rwork[7]; + + return 0; + +/* End of CLATM6 */ + +} /* clatm6_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clatme.c b/lapack-netlib/TESTING/MATGEN/clatme.c new file mode 100644 index 000000000..5d379dc55 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clatme.c @@ -0,0 +1,1094 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATME */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATME( N, DIST, ISEED, D, MODE, COND, DMAX, */ +/* RSIGN, */ +/* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, */ +/* A, */ +/* LDA, WORK, INFO ) */ + +/* CHARACTER DIST, RSIGN, SIM, UPPER */ +/* INTEGER INFO, KL, KU, LDA, MODE, MODES, N */ +/* REAL ANORM, COND, CONDS */ +/* COMPLEX DMAX */ +/* INTEGER ISEED( 4 ) */ +/* REAL DS( * ) */ +/* COMPLEX A( LDA, * ), D( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATME generates random non-symmetric square matrices with */ +/* > specified eigenvalues for testing LAPACK programs. */ +/* > */ +/* > CLATME operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > 1. Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and RSIGN */ +/* > as described below. */ +/* > */ +/* > 2. If UPPER='T', the upper triangle of A is set to random values */ +/* > out of distribution DIST. */ +/* > */ +/* > 3. If SIM='T', A is multiplied on the left by a random matrix */ +/* > X, whose singular values are specified by DS, MODES, and */ +/* > CONDS, and on the right by X inverse. */ +/* > */ +/* > 4. If KL < N-1, the lower bandwidth is reduced to KL using */ +/* > Householder transformations. If KU < N-1, the upper */ +/* > bandwidth is reduced to KU. */ +/* > */ +/* > 5. If ANORM is not negative, the matrix is scaled to have */ +/* > maximum-element-norm ANORM. */ +/* > */ +/* > (Note: since the matrix cannot be reduced beyond Hessenberg form, */ +/* > no packing options are available.) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns (or rows) of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values, and on the */ +/* > upper triangle (see UPPER). */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > 'D' => uniform on the complex disc |z| < 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to CLATME */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is COMPLEX array, dimension ( N ) */ +/* > This array is used to specify the eigenvalues of A. If */ +/* > MODE=0, then D is assumed to contain the eigenvalues */ +/* > otherwise they will be computed according to MODE, COND, */ +/* > DMAX, and RSIGN and placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is between 1 and 4, D has entries ranging */ +/* > from 1 to 1/COND, if between -1 and -4, D has entries */ +/* > ranging from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is REAL */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is COMPLEX */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))). Note that DMAX need not be */ +/* > positive or real: if DMAX is negative or complex (or zero), */ +/* > D will be scaled by a negative or complex number (or zero). */ +/* > If RSIGN='F' then the largest (absolute) eigenvalue will be */ +/* > equal to DMAX. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RSIGN */ +/* > \verbatim */ +/* > RSIGN is CHARACTER*1 */ +/* > If MODE is not 0, 6, or -6, and RSIGN='T', then the */ +/* > elements of D, as computed according to MODE and COND, will */ +/* > be multiplied by a random complex number from the unit */ +/* > circle |z| = 1. If RSIGN='F', they will not be. RSIGN may */ +/* > only have the values 'T' or 'F'. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPPER */ +/* > \verbatim */ +/* > UPPER is CHARACTER*1 */ +/* > If UPPER='T', then the elements of A above the diagonal */ +/* > will be set to random numbers out of DIST. If UPPER='F', */ +/* > they will not. UPPER may only have the values 'T' or 'F'. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIM */ +/* > \verbatim */ +/* > SIM is CHARACTER*1 */ +/* > If SIM='T', then A will be operated on by a "similarity */ +/* > transform", i.e., multiplied on the left by a matrix X and */ +/* > on the right by X inverse. X = U S V, where U and V are */ +/* > random unitary matrices and S is a (diagonal) matrix of */ +/* > singular values specified by DS, MODES, and CONDS. If */ +/* > SIM='F', then A will not be transformed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DS */ +/* > \verbatim */ +/* > DS is REAL array, dimension ( N ) */ +/* > This array is used to specify the singular values of X, */ +/* > in the same way that D specifies the eigenvalues of A. */ +/* > If MODE=0, the DS contains the singular values, which */ +/* > may not be zero. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODES */ +/* > \verbatim */ +/* > MODES is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDS */ +/* > \verbatim */ +/* > CONDS is REAL */ +/* > Similar to MODE and COND, but for specifying the diagonal */ +/* > of S. MODES=-6 and +6 are not allowed (since they would */ +/* > result in randomly ill-conditioned eigenvalues.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. KL=1 */ +/* > specifies upper Hessenberg form. If KL is at least N-1, */ +/* > then A will have full lower bandwidth. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. KU=1 */ +/* > specifies lower Hessenberg form. If KU is at least N-1, */ +/* > then A will have full upper bandwidth; if KU and KL */ +/* > are both at least N-1, then A will be dense. Only one of */ +/* > KU and KL may be less than N-1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > If ANORM is not negative, then A will be scaled by a non- */ +/* > negative real number to make the maximum-element-norm of A */ +/* > to be ANORM. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. LDA must be at least M. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension ( 3*N ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => N negative */ +/* > -2 => DIST illegal string */ +/* > -5 => MODE not in range -6 to 6 */ +/* > -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -9 => RSIGN is not 'T' or 'F' */ +/* > -10 => UPPER is not 'T' or 'F' */ +/* > -11 => SIM is not 'T' or 'F' */ +/* > -12 => MODES=0 and DS has a zero singular value. */ +/* > -13 => MODES is not in the range -5 to 5. */ +/* > -14 => MODES is nonzero and CONDS is less than 1. */ +/* > -15 => KL is less than 1. */ +/* > -16 => KU is less than 1, or KL and KU are both less than */ +/* > N-1. */ +/* > -19 => LDA is less than M. */ +/* > 1 => Error return from CLATM1 (computing D) */ +/* > 2 => Cannot scale to DMAX (f2cmax. eigenvalue is 0) */ +/* > 3 => Error return from SLATM1 (computing DS) */ +/* > 4 => Error return from CLARGE */ +/* > 5 => Zero singular value from SLATM1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clatme_(integer *n, char *dist, integer *iseed, complex * + d__, integer *mode, real *cond, complex *dmax__, char *rsign, char * + upper, char *sim, real *ds, integer *modes, real *conds, integer *kl, + integer *ku, real *anorm, complex *a, integer *lda, complex *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real r__1, r__2; + complex q__1, q__2; + + /* Local variables */ + logical bads; + integer isim; + real temp; + integer i__, j; + extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, + complex *, integer *, complex *, integer *, complex *, integer *); + complex alpha; + extern /* Subroutine */ int cscal_(integer *, complex *, complex *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex * + , complex *, integer *, complex *, integer *, complex *, complex * + , integer *); + integer iinfo; + real tempa[1]; + integer icols, idist; + extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, + complex *, integer *); + integer irows; + extern /* Subroutine */ int clatm1_(integer *, real *, integer *, integer + *, integer *, complex *, integer *, integer *), slatm1_(integer *, + real *, integer *, integer *, integer *, real *, integer *, + integer *); + integer ic, jc; + extern real clange_(char *, integer *, integer *, complex *, integer *, + real *); + integer ir; + extern /* Subroutine */ int clarge_(integer *, complex *, integer *, + integer *, complex *, integer *), clarfg_(integer *, complex *, + complex *, integer *, complex *), clacgv_(integer *, complex *, + integer *); + //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); + extern complex clarnd_(integer *, integer *); + real ralpha; + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *), claset_(char *, integer *, integer *, complex *, complex *, + complex *, integer *), xerbla_(char *, integer *), + clarnv_(integer *, integer *, integer *, complex *); + integer irsign, iupper; + complex xnorms; + integer jcr; + complex tau; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + --ds; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else if (lsame_(dist, "D")) { + idist = 4; + } else { + idist = -1; + } + +/* Decode RSIGN */ + + if (lsame_(rsign, "T")) { + irsign = 1; + } else if (lsame_(rsign, "F")) { + irsign = 0; + } else { + irsign = -1; + } + +/* Decode UPPER */ + + if (lsame_(upper, "T")) { + iupper = 1; + } else if (lsame_(upper, "F")) { + iupper = 0; + } else { + iupper = -1; + } + +/* Decode SIM */ + + if (lsame_(sim, "T")) { + isim = 1; + } else if (lsame_(sim, "F")) { + isim = 0; + } else { + isim = -1; + } + +/* Check DS, if MODES=0 and ISIM=1 */ + + bads = FALSE_; + if (*modes == 0 && isim == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (ds[j] == 0.f) { + bads = TRUE_; + } +/* L10: */ + } + } + +/* Set INFO if an error */ + + if (*n < 0) { + *info = -1; + } else if (idist == -1) { + *info = -2; + } else if (abs(*mode) > 6) { + *info = -5; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) { + *info = -6; + } else if (irsign == -1) { + *info = -9; + } else if (iupper == -1) { + *info = -10; + } else if (isim == -1) { + *info = -11; + } else if (bads) { + *info = -12; + } else if (isim == 1 && abs(*modes) > 5) { + *info = -13; + } else if (isim == 1 && *modes != 0 && *conds < 1.f) { + *info = -14; + } else if (*kl < 1) { + *info = -15; + } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) { + *info = -16; + } else if (*lda < f2cmax(1,*n)) { + *info = -19; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLATME", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L20: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up diagonal of A */ + +/* Compute D according to COND and MODE */ + + clatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = c_abs(&d__[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__1 = temp, r__2 = c_abs(&d__[i__]); + temp = f2cmax(r__1,r__2); +/* L30: */ + } + + if (temp > 0.f) { + q__1.r = dmax__->r / temp, q__1.i = dmax__->i / temp; + alpha.r = q__1.r, alpha.i = q__1.i; + } else { + *info = 2; + return 0; + } + + cscal_(n, &alpha, &d__[1], &c__1); + + } + + claset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda); + i__1 = *lda + 1; + ccopy_(n, &d__[1], &c__1, &a[a_offset], &i__1); + +/* 3) If UPPER='T', set upper triangle of A to random numbers. */ + + if (iupper != 0) { + i__1 = *n; + for (jc = 2; jc <= i__1; ++jc) { + i__2 = jc - 1; + clarnv_(&idist, &iseed[1], &i__2, &a[jc * a_dim1 + 1]); +/* L40: */ + } + } + +/* 4) If SIM='T', apply similarity transformation. */ + +/* -1 */ +/* Transform is X A X , where X = U S V, thus */ + +/* it is U S V A V' (1/S) U' */ + + if (isim != 0) { + +/* Compute S (singular values of the eigenvector matrix) */ +/* according to CONDS and MODES */ + + slatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo); + if (iinfo != 0) { + *info = 3; + return 0; + } + +/* Multiply by V and V' */ + + clarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo); + if (iinfo != 0) { + *info = 4; + return 0; + } + +/* Multiply by S and (1/S) */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + csscal_(n, &ds[j], &a[j + a_dim1], lda); + if (ds[j] != 0.f) { + r__1 = 1.f / ds[j]; + csscal_(n, &r__1, &a[j * a_dim1 + 1], &c__1); + } else { + *info = 5; + return 0; + } +/* L50: */ + } + +/* Multiply by U and U' */ + + clarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo); + if (iinfo != 0) { + *info = 4; + return 0; + } + } + +/* 5) Reduce the bandwidth. */ + + if (*kl < *n - 1) { + +/* Reduce bandwidth -- kill column */ + + i__1 = *n - 1; + for (jcr = *kl + 1; jcr <= i__1; ++jcr) { + ic = jcr - *kl; + irows = *n + 1 - jcr; + icols = *n + *kl - jcr; + + ccopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1); + xnorms.r = work[1].r, xnorms.i = work[1].i; + clarfg_(&irows, &xnorms, &work[2], &c__1, &tau); + r_cnjg(&q__1, &tau); + tau.r = q__1.r, tau.i = q__1.i; + work[1].r = 1.f, work[1].i = 0.f; + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + alpha.r = q__1.r, alpha.i = q__1.i; + + cgemv_("C", &irows, &icols, &c_b2, &a[jcr + (ic + 1) * a_dim1], + lda, &work[1], &c__1, &c_b1, &work[irows + 1], &c__1); + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&irows, &icols, &q__1, &work[1], &c__1, &work[irows + 1], & + c__1, &a[jcr + (ic + 1) * a_dim1], lda); + + cgemv_("N", n, &irows, &c_b2, &a[jcr * a_dim1 + 1], lda, &work[1], + &c__1, &c_b1, &work[irows + 1], &c__1); + r_cnjg(&q__2, &tau); + q__1.r = -q__2.r, q__1.i = -q__2.i; + cgerc_(n, &irows, &q__1, &work[irows + 1], &c__1, &work[1], &c__1, + &a[jcr * a_dim1 + 1], lda); + + i__2 = jcr + ic * a_dim1; + a[i__2].r = xnorms.r, a[i__2].i = xnorms.i; + i__2 = irows - 1; + claset_("Full", &i__2, &c__1, &c_b1, &c_b1, &a[jcr + 1 + ic * + a_dim1], lda); + + i__2 = icols + 1; + cscal_(&i__2, &alpha, &a[jcr + ic * a_dim1], lda); + r_cnjg(&q__1, &alpha); + cscal_(n, &q__1, &a[jcr * a_dim1 + 1], &c__1); +/* L60: */ + } + } else if (*ku < *n - 1) { + +/* Reduce upper bandwidth -- kill a row at a time. */ + + i__1 = *n - 1; + for (jcr = *ku + 1; jcr <= i__1; ++jcr) { + ir = jcr - *ku; + irows = *n + *ku - jcr; + icols = *n + 1 - jcr; + + ccopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1); + xnorms.r = work[1].r, xnorms.i = work[1].i; + clarfg_(&icols, &xnorms, &work[2], &c__1, &tau); + r_cnjg(&q__1, &tau); + tau.r = q__1.r, tau.i = q__1.i; + work[1].r = 1.f, work[1].i = 0.f; + i__2 = icols - 1; + clacgv_(&i__2, &work[2], &c__1); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + alpha.r = q__1.r, alpha.i = q__1.i; + + cgemv_("N", &irows, &icols, &c_b2, &a[ir + 1 + jcr * a_dim1], lda, + &work[1], &c__1, &c_b1, &work[icols + 1], &c__1); + q__1.r = -tau.r, q__1.i = -tau.i; + cgerc_(&irows, &icols, &q__1, &work[icols + 1], &c__1, &work[1], & + c__1, &a[ir + 1 + jcr * a_dim1], lda); + + cgemv_("C", &icols, n, &c_b2, &a[jcr + a_dim1], lda, &work[1], & + c__1, &c_b1, &work[icols + 1], &c__1); + r_cnjg(&q__2, &tau); + q__1.r = -q__2.r, q__1.i = -q__2.i; + cgerc_(&icols, n, &q__1, &work[1], &c__1, &work[icols + 1], &c__1, + &a[jcr + a_dim1], lda); + + i__2 = ir + jcr * a_dim1; + a[i__2].r = xnorms.r, a[i__2].i = xnorms.i; + i__2 = icols - 1; + claset_("Full", &c__1, &i__2, &c_b1, &c_b1, &a[ir + (jcr + 1) * + a_dim1], lda); + + i__2 = irows + 1; + cscal_(&i__2, &alpha, &a[ir + jcr * a_dim1], &c__1); + r_cnjg(&q__1, &alpha); + cscal_(n, &q__1, &a[jcr + a_dim1], lda); +/* L70: */ + } + } + +/* Scale the matrix to have norm ANORM */ + + if (*anorm >= 0.f) { + temp = clange_("M", n, n, &a[a_offset], lda, tempa); + if (temp > 0.f) { + ralpha = *anorm / temp; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + csscal_(n, &ralpha, &a[j * a_dim1 + 1], &c__1); +/* L80: */ + } + } + } + + return 0; + +/* End of CLATME */ + +} /* clatme_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clatmr.c b/lapack-netlib/TESTING/MATGEN/clatmr.c new file mode 100644 index 000000000..15b17d8ee --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clatmr.c @@ -0,0 +1,1980 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATMR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, */ +/* CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, */ +/* PACK, A, LDA, IWORK, INFO ) */ + +/* CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N */ +/* REAL ANORM, COND, CONDL, CONDR, SPARSE */ +/* COMPLEX DMAX */ +/* INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) */ +/* COMPLEX A( LDA, * ), D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATMR generates random matrices of various types for testing */ +/* > LAPACK programs. */ +/* > */ +/* > CLATMR operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Generate a matrix A with random entries of distribution DIST */ +/* > which is symmetric if SYM='S', Hermitian if SYM='H', and */ +/* > nonsymmetric if SYM='N'. */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX and RSIGN */ +/* > as described below. */ +/* > */ +/* > Grade the matrix, if desired, from the left and/or right */ +/* > as specified by GRADE. The inputs DL, MODEL, CONDL, DR, */ +/* > MODER and CONDR also determine the grading as described */ +/* > below. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > PIVTNG and IPIVOT. */ +/* > */ +/* > Set random entries to zero, if desired, to get a random sparse */ +/* > matrix as specified by SPARSE. */ +/* > */ +/* > Make A a band matrix, if desired, by zeroing out the matrix */ +/* > outside a band of lower bandwidth KL and upper bandwidth KU. */ +/* > */ +/* > Scale A, if desired, to have maximum entry ANORM. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if symmetric or Hermitian) */ +/* > zero out lower half (if symmetric or Hermitian) */ +/* > store the upper half columnwise (if symmetric or Hermitian */ +/* > or square upper triangular) */ +/* > store the lower half columnwise (if symmetric or Hermitian */ +/* > or square lower triangular) */ +/* > same as upper half rowwise if symmetric */ +/* > same as conjugate upper half rowwise if Hermitian */ +/* > store the lower triangle in banded format */ +/* > (if symmetric or Hermitian) */ +/* > store the upper triangle in banded format */ +/* > (if symmetric or Hermitian) */ +/* > store the entire matrix in banded format */ +/* > */ +/* > Note: If two calls to CLATMR differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > */ +/* > If two calls to CLATMR both have full bandwidth (KL = M-1 */ +/* > and KU = N-1), and differ only in the PIVTNG and PACK */ +/* > parameters, then the matrices generated will differ only */ +/* > in the order of the rows and/or columns, and otherwise */ +/* > contain the same data. This consistency cannot be and */ +/* > is not maintained with less than full bandwidth. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate a random matrix . */ +/* > 'U' => real and imaginary parts are independent */ +/* > UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => real and imaginary parts are independent */ +/* > UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => real and imaginary parts are independent */ +/* > NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > 'D' => uniform on interior of unit disk ( 'D' for disk ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to CLATMR */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='S', generated matrix is symmetric. */ +/* > If SYM='H', generated matrix is Hermitian. */ +/* > If SYM='N', generated matrix is nonsymmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is COMPLEX array, dimension (f2cmin(M,N)) */ +/* > On entry this array specifies the diagonal entries */ +/* > of the diagonal of A. D may either be specified */ +/* > on entry, or set according to MODE and COND as described */ +/* > below. If the matrix is Hermitian, the real part of D */ +/* > will be taken. May be changed on exit if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry describes how D is to be used: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is REAL */ +/* > On entry, used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is COMPLEX */ +/* > If MODE neither -6, 0 nor 6, the diagonal is scaled by */ +/* > DMAX / f2cmax(abs(D(i))), so that maximum absolute entry */ +/* > of diagonal is abs(DMAX). If DMAX is complex (or zero), */ +/* > diagonal will be scaled by a complex number (or zero). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RSIGN */ +/* > \verbatim */ +/* > RSIGN is CHARACTER*1 */ +/* > If MODE neither -6, 0 nor 6, specifies sign of diagonal */ +/* > as follows: */ +/* > 'T' => diagonal entries are multiplied by a random complex */ +/* > number uniformly distributed with absolute value 1 */ +/* > 'F' => diagonal unchanged */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GRADE */ +/* > \verbatim */ +/* > GRADE is CHARACTER*1 */ +/* > Specifies grading of matrix as follows: */ +/* > 'N' => no grading */ +/* > 'L' => matrix premultiplied by diag( DL ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'R' => matrix postmultiplied by diag( DR ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'B' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'H' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( CONJG(DL) ) */ +/* > (only if matrix Hermitian or nonsymmetric) */ +/* > 'S' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > (only if matrix symmetric or nonsymmetric) */ +/* > 'E' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > ( 'S' for similarity ) */ +/* > (only if matrix nonsymmetric) */ +/* > Note: if GRADE='S', then M must equal N. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DL */ +/* > \verbatim */ +/* > DL is COMPLEX array, dimension (M) */ +/* > If MODEL=0, then on entry this array specifies the diagonal */ +/* > entries of a diagonal matrix used as described under GRADE */ +/* > above. If MODEL is not zero, then DL will be set according */ +/* > to MODEL and CONDL, analogous to the way D is set according */ +/* > to MODE and COND (except there is no DMAX parameter for DL). */ +/* > If GRADE='E', then DL cannot have zero entries. */ +/* > Not referenced if GRADE = 'N' or 'R'. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODEL */ +/* > \verbatim */ +/* > MODEL is INTEGER */ +/* > This specifies how the diagonal array DL is to be computed, */ +/* > just as MODE specifies how D is to be computed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDL */ +/* > \verbatim */ +/* > CONDL is REAL */ +/* > When MODEL is not zero, this specifies the condition number */ +/* > of the computed DL. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DR */ +/* > \verbatim */ +/* > DR is COMPLEX array, dimension (N) */ +/* > If MODER=0, then on entry this array specifies the diagonal */ +/* > entries of a diagonal matrix used as described under GRADE */ +/* > above. If MODER is not zero, then DR will be set according */ +/* > to MODER and CONDR, analogous to the way D is set according */ +/* > to MODE and COND (except there is no DMAX parameter for DR). */ +/* > Not referenced if GRADE = 'N', 'L', 'H' or 'S'. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODER */ +/* > \verbatim */ +/* > MODER is INTEGER */ +/* > This specifies how the diagonal array DR is to be computed, */ +/* > just as MODE specifies how D is to be computed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDR */ +/* > \verbatim */ +/* > CONDR is REAL */ +/* > When MODER is not zero, this specifies the condition number */ +/* > of the computed DR. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVTNG */ +/* > \verbatim */ +/* > PIVTNG is CHARACTER*1 */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 'N' or ' ' => none. */ +/* > 'L' => left or row pivoting (matrix must be nonsymmetric). */ +/* > 'R' => right or column pivoting (matrix must be */ +/* > nonsymmetric). */ +/* > 'B' or 'F' => both or full pivoting, i.e., on both sides. */ +/* > In this case, M must equal N */ +/* > */ +/* > If two calls to CLATMR both have full bandwidth (KL = M-1 */ +/* > and KU = N-1), and differ only in the PIVTNG and PACK */ +/* > parameters, then the matrices generated will differ only */ +/* > in the order of the rows and/or columns, and otherwise */ +/* > contain the same data. This consistency cannot be */ +/* > maintained with less than full bandwidth. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIVOT */ +/* > \verbatim */ +/* > IPIVOT is INTEGER array, dimension (N or M) */ +/* > This array specifies the permutation used. After the */ +/* > basic matrix is generated, the rows, columns, or both */ +/* > are permuted. If, say, row pivoting is selected, CLATMR */ +/* > starts with the *last* row and interchanges the M-th and */ +/* > IPIVOT(M)-th rows, then moves to the next-to-last row, */ +/* > interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, */ +/* > and so on. In terms of "2-cycles", the permutation is */ +/* > (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) */ +/* > where the rightmost cycle is applied first. This is the */ +/* > *inverse* of the effect of pivoting in LINPACK. The idea */ +/* > is that factoring (with pivoting) an identity matrix */ +/* > which has been inverse-pivoted in this way should */ +/* > result in a pivot vector identical to IPIVOT. */ +/* > Not referenced if PIVTNG = 'N'. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > On entry specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL at least M-1 implies the matrix is not */ +/* > banded. Must equal KU if matrix is symmetric or Hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > On entry specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU at least N-1 implies the matrix is not */ +/* > banded. Must equal KL if matrix is symmetric or Hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is REAL */ +/* > On entry specifies the sparsity of the matrix if a sparse */ +/* > matrix is to be generated. SPARSE should lie between */ +/* > 0 and 1. To generate a sparse matrix, for each matrix entry */ +/* > a uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > On entry specifies maximum entry of output matrix */ +/* > (output matrix will by multiplied by a constant so that */ +/* > its largest absolute entry equal ANORM) */ +/* > if ANORM is nonnegative. If ANORM is negative no scaling */ +/* > is done. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > On entry specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries */ +/* > (if symmetric or Hermitian) */ +/* > 'L' => zero out all superdiagonal entries */ +/* > (if symmetric or Hermitian) */ +/* > 'C' => store the upper triangle columnwise */ +/* > (only if matrix symmetric or Hermitian or */ +/* > square upper triangular) */ +/* > 'R' => store the lower triangle columnwise */ +/* > (only if matrix symmetric or Hermitian or */ +/* > square lower triangular) */ +/* > (same as upper half rowwise if symmetric) */ +/* > (same as conjugate upper half rowwise if Hermitian) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if matrix symmetric or Hermitian) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if matrix symmetric or Hermitian) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, HB or TB - use 'B' or 'Q' */ +/* > PP, HP or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to CLATMR differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > On exit A is the desired test matrix. Only those */ +/* > entries of A which are significant on output */ +/* > will be referenced (even if A is in packed or band */ +/* > storage format). The 'unoccupied corners' of A in */ +/* > band format will be zeroed out. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > on entry LDA specifies the first dimension of A as */ +/* > declared in the calling program. */ +/* > If PACK='N', 'U' or 'L', LDA must be at least f2cmax ( 1, M ). */ +/* > If PACK='C' or 'R', LDA must be at least 1. */ +/* > If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) */ +/* > If PACK='Z', LDA must be at least KUU+KLL+1, where */ +/* > KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, M-1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N or M) */ +/* > Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error parameter on exit: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S' or 'H' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string */ +/* > -11 => GRADE illegal string, or GRADE='E' and */ +/* > M not equal to N, or GRADE='L', 'R', 'B', 'S' or 'E' */ +/* > and SYM = 'H', or GRADE='L', 'R', 'B', 'H' or 'E' */ +/* > and SYM = 'S' */ +/* > -12 => GRADE = 'E' and DL contains zero */ +/* > -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', */ +/* > 'S' or 'E' */ +/* > -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', */ +/* > and MODEL neither -6, 0 nor 6 */ +/* > -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' */ +/* > -17 => CONDR less than 1.0, GRADE='R' or 'B', and */ +/* > MODER neither -6, 0 nor 6 */ +/* > -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and */ +/* > M not equal to N, or PIVTNG='L' or 'R' and SYM='S' */ +/* > or 'H' */ +/* > -19 => IPIVOT contains out of range number and */ +/* > PIVTNG not equal to 'N' */ +/* > -20 => KL negative */ +/* > -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL */ +/* > -22 => SPARSE not in range 0. to 1. */ +/* > -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' */ +/* > and SYM='N', or PACK='C' and SYM='N' and either KL */ +/* > not equal to 0 or N not equal to M, or PACK='R' and */ +/* > SYM='N', and either KU not equal to 0 or N not equal */ +/* > to M */ +/* > -26 => LDA too small */ +/* > 1 => Error return from CLATM1 (computing D) */ +/* > 2 => Cannot scale diagonal to DMAX (f2cmax. entry is 0) */ +/* > 3 => Error return from CLATM1 (computing DL) */ +/* > 4 => Error return from CLATM1 (computing DR) */ +/* > 5 => ANORM is positive, but matrix constructed prior to */ +/* > attempting to scale it to have norm ANORM, is zero */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clatmr_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, complex *d__, integer *mode, real *cond, complex * + dmax__, char *rsign, char *grade, complex *dl, integer *model, real * + condl, complex *dr, integer *moder, real *condr, char *pivtng, + integer *ipivot, integer *kl, integer *ku, real *sparse, real *anorm, + char *pack, complex *a, integer *lda, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + real r__1, r__2; + complex q__1, q__2; + + /* Local variables */ + integer isub, jsub; + real temp; + integer isym, i__, j, k, ipack; + extern logical lsame_(char *, char *); + real tempa[1]; + complex ctemp; + integer iisub, idist, jjsub, mnmin; + logical dzero; + integer mnsub; + real onorm; + integer mxsub, npvts; + extern /* Subroutine */ int clatm1_(integer *, real *, integer *, integer + *, integer *, complex *, integer *, integer *); + extern /* Complex */ VOID clatm2_(complex *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + complex *, integer *, complex *, complex *, integer *, integer *, + real *), clatm3_(complex *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, complex *, integer *, complex *, complex *, integer *, + integer *, real *); + complex calpha; + extern real clangb_(char *, integer *, integer *, integer *, complex *, + integer *, real *), clange_(char *, integer *, integer *, + complex *, integer *, real *); + integer igrade; + extern real clansb_(char *, char *, integer *, integer *, complex *, + integer *, real *); + extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer + *); + logical fulbnd; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical badpvt; + extern real clansp_(char *, char *, integer *, complex *, real *), clansy_(char *, char *, integer *, complex *, integer *, + real *); + integer irsign, ipvtng, kll, kuu; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + --dl; + --dr; + --ipivot; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iwork; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else if (lsame_(dist, "D")) { + idist = 4; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "H")) { + isym = 0; + } else if (lsame_(sym, "N")) { + isym = 1; + } else if (lsame_(sym, "S")) { + isym = 2; + } else { + isym = -1; + } + +/* Decode RSIGN */ + + if (lsame_(rsign, "F")) { + irsign = 0; + } else if (lsame_(rsign, "T")) { + irsign = 1; + } else { + irsign = -1; + } + +/* Decode PIVTNG */ + + if (lsame_(pivtng, "N")) { + ipvtng = 0; + } else if (lsame_(pivtng, " ")) { + ipvtng = 0; + } else if (lsame_(pivtng, "L")) { + ipvtng = 1; + npvts = *m; + } else if (lsame_(pivtng, "R")) { + ipvtng = 2; + npvts = *n; + } else if (lsame_(pivtng, "B")) { + ipvtng = 3; + npvts = f2cmin(*n,*m); + } else if (lsame_(pivtng, "F")) { + ipvtng = 3; + npvts = f2cmin(*n,*m); + } else { + ipvtng = -1; + } + +/* Decode GRADE */ + + if (lsame_(grade, "N")) { + igrade = 0; + } else if (lsame_(grade, "L")) { + igrade = 1; + } else if (lsame_(grade, "R")) { + igrade = 2; + } else if (lsame_(grade, "B")) { + igrade = 3; + } else if (lsame_(grade, "E")) { + igrade = 4; + } else if (lsame_(grade, "H")) { + igrade = 5; + } else if (lsame_(grade, "S")) { + igrade = 6; + } else { + igrade = -1; + } + +/* Decode PACK */ + + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + } else if (lsame_(pack, "C")) { + ipack = 3; + } else if (lsame_(pack, "R")) { + ipack = 4; + } else if (lsame_(pack, "B")) { + ipack = 5; + } else if (lsame_(pack, "Q")) { + ipack = 6; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + kll = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + kuu = f2cmin(i__1,i__2); + +/* If inv(DL) is used, check to see if DL has a zero entry. */ + + dzero = FALSE_; + if (igrade == 4 && *model == 0) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + if (dl[i__2].r == 0.f && dl[i__2].i == 0.f) { + dzero = TRUE_; + } +/* L10: */ + } + } + +/* Check values in IPIVOT */ + + badpvt = FALSE_; + if (ipvtng > 0) { + i__1 = npvts; + for (j = 1; j <= i__1; ++j) { + if (ipivot[j] <= 0 || ipivot[j] > npvts) { + badpvt = TRUE_; + } +/* L20: */ + } + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && (isym == 0 || isym == 2)) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (*mode < -6 || *mode > 6) { + *info = -7; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) { + *info = -8; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) { + *info = -10; + } else if (igrade == -1 || igrade == 4 && *m != *n || (igrade == 1 || + igrade == 2 || igrade == 3 || igrade == 4 || igrade == 6) && isym + == 0 || (igrade == 1 || igrade == 2 || igrade == 3 || igrade == 4 + || igrade == 5) && isym == 2) { + *info = -11; + } else if (igrade == 4 && dzero) { + *info = -12; + } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 || + igrade == 6) && (*model < -6 || *model > 6)) { + *info = -13; + } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 || + igrade == 6) && (*model != -6 && *model != 0 && *model != 6) && * + condl < 1.f) { + *info = -14; + } else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) { + *info = -16; + } else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 && + *moder != 6) && *condr < 1.f) { + *info = -17; + } else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 || + ipvtng == 2) && (isym == 0 || isym == 2)) { + *info = -18; + } else if (ipvtng != 0 && badpvt) { + *info = -19; + } else if (*kl < 0) { + *info = -20; + } else if (*ku < 0 || (isym == 0 || isym == 2) && *kl != *ku) { + *info = -21; + } else if (*sparse < 0.f || *sparse > 1.f) { + *info = -22; + } else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 || + ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0 + || *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n)) + { + *info = -24; + } else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < f2cmax(1,*m) || + (ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack == + 6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) { + *info = -26; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLATMR", &i__1); + return 0; + } + +/* Decide if we can pivot consistently */ + + fulbnd = FALSE_; + if (kuu == *n - 1 && kll == *m - 1) { + fulbnd = TRUE_; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L30: */ + } + + iseed[4] = (iseed[4] / 2 << 1) + 1; + +/* 2) Set up D, DL, and DR, if indicated. */ + +/* Compute D according to COND and MODE */ + + clatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info); + if (*info != 0) { + *info = 1; + return 0; + } + if (*mode != 0 && *mode != -6 && *mode != 6) { + +/* Scale by DMAX */ + + temp = c_abs(&d__[1]); + i__1 = mnmin; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__1 = temp, r__2 = c_abs(&d__[i__]); + temp = f2cmax(r__1,r__2); +/* L40: */ + } + if (temp == 0.f && (dmax__->r != 0.f || dmax__->i != 0.f)) { + *info = 2; + return 0; + } + if (temp != 0.f) { + q__1.r = dmax__->r / temp, q__1.i = dmax__->i / temp; + calpha.r = q__1.r, calpha.i = q__1.i; + } else { + calpha.r = 1.f, calpha.i = 0.f; + } + i__1 = mnmin; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + q__1.r = calpha.r * d__[i__3].r - calpha.i * d__[i__3].i, q__1.i = + calpha.r * d__[i__3].i + calpha.i * d__[i__3].r; + d__[i__2].r = q__1.r, d__[i__2].i = q__1.i; +/* L50: */ + } + + } + +/* If matrix Hermitian, make D real */ + + if (isym == 0) { + i__1 = mnmin; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + r__1 = d__[i__3].r; + d__[i__2].r = r__1, d__[i__2].i = 0.f; +/* L60: */ + } + } + +/* Compute DL if grading set */ + + if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 || igrade == + 6) { + clatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info); + if (*info != 0) { + *info = 3; + return 0; + } + } + +/* Compute DR if grading set */ + + if (igrade == 2 || igrade == 3) { + clatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info); + if (*info != 0) { + *info = 4; + return 0; + } + } + +/* 3) Generate IWORK if pivoting */ + + if (ipvtng > 0) { + i__1 = npvts; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = i__; +/* L70: */ + } + if (fulbnd) { + i__1 = npvts; + for (i__ = 1; i__ <= i__1; ++i__) { + k = ipivot[i__]; + j = iwork[i__]; + iwork[i__] = iwork[k]; + iwork[k] = j; +/* L80: */ + } + } else { + for (i__ = npvts; i__ >= 1; --i__) { + k = ipivot[i__]; + j = iwork[i__]; + iwork[i__] = iwork[k]; + iwork[k] = j; +/* L90: */ + } + } + } + +/* 4) Generate matrices for each kind of PACKing */ +/* Always sweep matrix columnwise (if symmetric, upper */ +/* half only) so that matrix generated does not depend */ +/* on PACK */ + + if (fulbnd) { + +/* Use CLATM3 so matrices generated with differing PIVOTing only */ +/* differ only in the order of their rows and/or columns. */ + + if (ipack == 0) { + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__3 = isub + jsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + i__3 = jsub + isub * a_dim1; + r_cnjg(&q__1, &ctemp); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L100: */ + } +/* L110: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__3 = isub + jsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; +/* L120: */ + } +/* L130: */ + } + } else if (isym == 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__3 = isub + jsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + i__3 = jsub + isub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; +/* L140: */ + } +/* L150: */ + } + } + + } else if (ipack == 1) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mxsub == isub && isym == 0) { + i__3 = mnsub + mxsub * a_dim1; + r_cnjg(&q__1, &ctemp); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = mnsub + mxsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } + if (mnsub != mxsub) { + i__3 = mxsub + mnsub * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } +/* L160: */ + } +/* L170: */ + } + + } else if (ipack == 2) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mxsub == jsub && isym == 0) { + i__3 = mxsub + mnsub * a_dim1; + r_cnjg(&q__1, &ctemp); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = mxsub + mnsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } + if (mnsub != mxsub) { + i__3 = mnsub + mxsub * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } +/* L180: */ + } +/* L190: */ + } + + } else if (ipack == 3) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + +/* Compute K = location of (ISUB,JSUB) entry in packed */ +/* array */ + + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + k = mxsub * (mxsub - 1) / 2 + mnsub; + +/* Convert K to (IISUB,JJSUB) location */ + + jjsub = (k - 1) / *lda + 1; + iisub = k - *lda * (jjsub - 1); + + if (mxsub == isub && isym == 0) { + i__3 = iisub + jjsub * a_dim1; + r_cnjg(&q__1, &ctemp); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = iisub + jjsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } +/* L200: */ + } +/* L210: */ + } + + } else if (ipack == 4) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + +/* Compute K = location of (I,J) entry in packed array */ + + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mnsub == 1) { + k = mxsub; + } else { + k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n - + mnsub + 2) / 2 + mxsub - mnsub + 1; + } + +/* Convert K to (IISUB,JJSUB) location */ + + jjsub = (k - 1) / *lda + 1; + iisub = k - *lda * (jjsub - 1); + + if (mxsub == jsub && isym == 0) { + i__3 = iisub + jjsub * a_dim1; + r_cnjg(&q__1, &ctemp); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = iisub + jjsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } +/* L220: */ + } +/* L230: */ + } + + } else if (ipack == 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + if (i__ < 1) { + i__3 = j - i__ + 1 + (i__ + *n) * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } else { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mxsub == jsub && isym == 0) { + i__3 = mxsub - mnsub + 1 + mnsub * a_dim1; + r_cnjg(&q__1, &ctemp); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = mxsub - mnsub + 1 + mnsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } + } +/* L240: */ + } +/* L250: */ + } + + } else if (ipack == 6) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mxsub == isub && isym == 0) { + i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1; + r_cnjg(&q__1, &ctemp); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } +/* L260: */ + } +/* L270: */ + } + + } else if (ipack == 7) { + + if (isym != 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (i__ < 1) { + i__3 = j - i__ + 1 + kuu + (i__ + *n) * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } + if (mxsub == isub && isym == 0) { + i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1; + r_cnjg(&q__1, &ctemp); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } + if (i__ >= 1 && mnsub != mxsub) { + if (mnsub == isub && isym == 0) { + i__3 = mxsub - mnsub + 1 + kuu + mnsub * + a_dim1; + r_cnjg(&q__1, &ctemp); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = mxsub - mnsub + 1 + kuu + mnsub * + a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } + } +/* L280: */ + } +/* L290: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + kll; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + clatm3_(&q__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = q__1.r, ctemp.i = q__1.i; + i__3 = isub - jsub + kuu + 1 + jsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; +/* L300: */ + } +/* L310: */ + } + } + + } + + } else { + +/* Use CLATM2 */ + + if (ipack == 0) { + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + i__3 = j + i__ * a_dim1; + r_cnjg(&q__1, &a[i__ + j * a_dim1]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L320: */ + } +/* L330: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L340: */ + } +/* L350: */ + } + } else if (isym == 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + i__3 = j + i__ * a_dim1; + i__4 = i__ + j * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; +/* L360: */ + } +/* L370: */ + } + } + + } else if (ipack == 1) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1], + &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[ + 1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + if (i__ != j) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } +/* L380: */ + } +/* L390: */ + } + + } else if (ipack == 2) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + if (isym == 0) { + i__3 = j + i__ * a_dim1; + clatm2_(&q__2, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + r_cnjg(&q__1, &q__2); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = j + i__ * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + if (i__ != j) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } +/* L400: */ + } +/* L410: */ + } + + } else if (ipack == 3) { + + isub = 0; + jsub = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++isub; + if (isub > *lda) { + isub = 1; + ++jsub; + } + i__3 = isub + jsub * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1], + &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[ + 1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L420: */ + } +/* L430: */ + } + + } else if (ipack == 4) { + + if (isym == 0 || isym == 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + +/* Compute K = location of (I,J) entry in packed array */ + + if (i__ == 1) { + k = j; + } else { + k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n - + i__ + 2) / 2 + j - i__ + 1; + } + +/* Convert K to (ISUB,JSUB) location */ + + jsub = (k - 1) / *lda + 1; + isub = k - *lda * (jsub - 1); + + i__3 = isub + jsub * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + if (isym == 0) { + i__3 = isub + jsub * a_dim1; + r_cnjg(&q__1, &a[isub + jsub * a_dim1]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } +/* L440: */ + } +/* L450: */ + } + } else { + isub = 0; + jsub = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++isub; + if (isub > *lda) { + isub = 1; + ++jsub; + } + i__3 = isub + jsub * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L460: */ + } +/* L470: */ + } + } + + } else if (ipack == 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + if (i__ < 1) { + i__3 = j - i__ + 1 + (i__ + *n) * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } else { + if (isym == 0) { + i__3 = j - i__ + 1 + i__ * a_dim1; + clatm2_(&q__2, m, n, &i__, &j, kl, ku, &idist, & + iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + r_cnjg(&q__1, &q__2); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = j - i__ + 1 + i__ * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, & + iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } + } +/* L480: */ + } +/* L490: */ + } + + } else if (ipack == 6) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + i__3 = i__ - j + kuu + 1 + j * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1], + &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[ + 1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L500: */ + } +/* L510: */ + } + + } else if (ipack == 7) { + + if (isym != 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + i__3 = i__ - j + kuu + 1 + j * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + if (i__ < 1) { + i__3 = j - i__ + 1 + kuu + (i__ + *n) * a_dim1; + a[i__3].r = 0.f, a[i__3].i = 0.f; + } + if (i__ >= 1 && i__ != j) { + if (isym == 0) { + i__3 = j - i__ + 1 + kuu + i__ * a_dim1; + r_cnjg(&q__1, &a[i__ - j + kuu + 1 + j * + a_dim1]); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; + } else { + i__3 = j - i__ + 1 + kuu + i__ * a_dim1; + i__4 = i__ - j + kuu + 1 + j * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + } + } +/* L520: */ + } +/* L530: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + kll; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + i__3 = i__ - j + kuu + 1 + j * a_dim1; + clatm2_(&q__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = q__1.r, a[i__3].i = q__1.i; +/* L540: */ + } +/* L550: */ + } + } + + } + + } + +/* 5) Scaling the norm */ + + if (ipack == 0) { + onorm = clange_("M", m, n, &a[a_offset], lda, tempa); + } else if (ipack == 1) { + onorm = clansy_("M", "U", n, &a[a_offset], lda, tempa); + } else if (ipack == 2) { + onorm = clansy_("M", "L", n, &a[a_offset], lda, tempa); + } else if (ipack == 3) { + onorm = clansp_("M", "U", n, &a[a_offset], tempa); + } else if (ipack == 4) { + onorm = clansp_("M", "L", n, &a[a_offset], tempa); + } else if (ipack == 5) { + onorm = clansb_("M", "L", n, &kll, &a[a_offset], lda, tempa); + } else if (ipack == 6) { + onorm = clansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa); + } else if (ipack == 7) { + onorm = clangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa); + } + + if (*anorm >= 0.f) { + + if (*anorm > 0.f && onorm == 0.f) { + +/* Desired scaling impossible */ + + *info = 5; + return 0; + + } else if (*anorm > 1.f && onorm < 1.f || *anorm < 1.f && onorm > 1.f) + { + +/* Scale carefully to avoid over / underflow */ + + if (ipack <= 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + r__1 = 1.f / onorm; + csscal_(m, &r__1, &a[j * a_dim1 + 1], &c__1); + csscal_(m, anorm, &a[j * a_dim1 + 1], &c__1); +/* L560: */ + } + + } else if (ipack == 3 || ipack == 4) { + + i__1 = *n * (*n + 1) / 2; + r__1 = 1.f / onorm; + csscal_(&i__1, &r__1, &a[a_offset], &c__1); + i__1 = *n * (*n + 1) / 2; + csscal_(&i__1, anorm, &a[a_offset], &c__1); + + } else if (ipack >= 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = kll + kuu + 1; + r__1 = 1.f / onorm; + csscal_(&i__2, &r__1, &a[j * a_dim1 + 1], &c__1); + i__2 = kll + kuu + 1; + csscal_(&i__2, anorm, &a[j * a_dim1 + 1], &c__1); +/* L570: */ + } + + } + + } else { + +/* Scale straightforwardly */ + + if (ipack <= 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + r__1 = *anorm / onorm; + csscal_(m, &r__1, &a[j * a_dim1 + 1], &c__1); +/* L580: */ + } + + } else if (ipack == 3 || ipack == 4) { + + i__1 = *n * (*n + 1) / 2; + r__1 = *anorm / onorm; + csscal_(&i__1, &r__1, &a[a_offset], &c__1); + + } else if (ipack >= 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = kll + kuu + 1; + r__1 = *anorm / onorm; + csscal_(&i__2, &r__1, &a[j * a_dim1 + 1], &c__1); +/* L590: */ + } + } + + } + + } + +/* End of CLATMR */ + + return 0; +} /* clatmr_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clatms.c b/lapack-netlib/TESTING/MATGEN/clatms.c new file mode 100644 index 000000000..d7512721c --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clatms.c @@ -0,0 +1,2092 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATMS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* KL, KU, PACK, A, LDA, WORK, INFO ) */ + +/* CHARACTER DIST, PACK, SYM */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, N */ +/* REAL COND, DMAX */ +/* INTEGER ISEED( 4 ) */ +/* REAL D( * ) */ +/* COMPLEX A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATMS generates random matrices with specified singular values */ +/* > (or hermitian with specified eigenvalues) */ +/* > for testing LAPACK programs. */ +/* > */ +/* > CLATMS operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and SYM */ +/* > as described below. */ +/* > */ +/* > Generate a matrix with the appropriate band structure, by one */ +/* > of two methods: */ +/* > */ +/* > Method A: */ +/* > Generate a dense M x N matrix by multiplying D on the left */ +/* > and the right by random unitary matrices, then: */ +/* > */ +/* > Reduce the bandwidth according to KL and KU, using */ +/* > Householder transformations. */ +/* > */ +/* > Method B: */ +/* > Convert the bandwidth-0 (i.e., diagonal) matrix to a */ +/* > bandwidth-1 matrix using Givens rotations, "chasing" */ +/* > out-of-band elements back, much as in QR; then convert */ +/* > the bandwidth-1 to a bandwidth-2 matrix, etc. Note */ +/* > that for reasonably small bandwidths (relative to M and */ +/* > N) this requires less storage, as a dense matrix is not */ +/* > generated. Also, for hermitian or symmetric matrices, */ +/* > only one triangle is generated. */ +/* > */ +/* > Method A is chosen if the bandwidth is a large fraction of the */ +/* > order of the matrix, and LDA is at least M (so a dense */ +/* > matrix can be stored.) Method B is chosen if the bandwidth */ +/* > is small (< 1/2 N for hermitian or symmetric, < .3 N+M for */ +/* > non-symmetric), or LDA is less than M and not less than the */ +/* > bandwidth. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if hermitian) */ +/* > zero out lower half (if hermitian) */ +/* > store the upper half columnwise (if hermitian or upper */ +/* > triangular) */ +/* > store the lower half columnwise (if hermitian or lower */ +/* > triangular) */ +/* > store the lower triangle in banded format (if hermitian or */ +/* > lower triangular) */ +/* > store the upper triangle in banded format (if hermitian or */ +/* > upper triangular) */ +/* > store the entire matrix in banded format */ +/* > If Method B is chosen, and band format is specified, then the */ +/* > matrix will be generated in the band format, so no repacking */ +/* > will be necessary. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of A. N must equal M if the matrix */ +/* > is symmetric or hermitian (i.e., if SYM is not 'N') */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values. */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to CLATMS */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='H', the generated matrix is hermitian, with */ +/* > eigenvalues specified by D, COND, MODE, and DMAX; they */ +/* > may be positive, negative, or zero. */ +/* > If SYM='P', the generated matrix is hermitian, with */ +/* > eigenvalues (= singular values) specified by D, COND, */ +/* > MODE, and DMAX; they will not be negative. */ +/* > If SYM='N', the generated matrix is nonsymmetric, with */ +/* > singular values specified by D, COND, MODE, and DMAX; */ +/* > they will not be negative. */ +/* > If SYM='S', the generated matrix is (complex) symmetric, */ +/* > with singular values specified by D, COND, MODE, and */ +/* > DMAX; they will not be negative. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension ( MIN( M, N ) ) */ +/* > This array is used to specify the singular values or */ +/* > eigenvalues of A (see SYM, above.) If MODE=0, then D is */ +/* > assumed to contain the singular/eigenvalues, otherwise */ +/* > they will be computed according to MODE, COND, and DMAX, */ +/* > and placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the singular/eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > If SYM='H', and MODE is neither 0, 6, nor -6, then */ +/* > the elements of D will also be multiplied by a random */ +/* > sign (i.e., +1 or -1.) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is REAL */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is REAL */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))); thus, the maximum absolute eigen- or */ +/* > singular value (which is to say the norm) will be abs(DMAX). */ +/* > Note that DMAX need not be positive: if DMAX is negative */ +/* > (or zero), D will be scaled by a negative number (or zero). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL being at least M-1 means that the matrix */ +/* > has full lower bandwidth. KL must equal KU if the matrix */ +/* > is symmetric or hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU being at least N-1 means that the matrix */ +/* > has full upper bandwidth. KL must equal KU if the matrix */ +/* > is symmetric or hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > This specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries (if symmetric */ +/* > or hermitian) */ +/* > 'L' => zero out all superdiagonal entries (if symmetric */ +/* > or hermitian) */ +/* > 'C' => store the upper triangle columnwise (only if the */ +/* > matrix is symmetric, hermitian, or upper triangular) */ +/* > 'R' => store the lower triangle columnwise (only if the */ +/* > matrix is symmetric, hermitian, or lower triangular) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if the matrix is symmetric, hermitian, or */ +/* > lower triangular) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if the matrix is symmetric, hermitian, or */ +/* > upper triangular) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, SB, HB, or TB - use 'B' or 'Q' */ +/* > PP, SP, HB, or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to CLATMS differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. A is first generated */ +/* > in full (unpacked) form, and then packed, if so specified */ +/* > by PACK. Thus, the first M elements of the first N */ +/* > columns will always be modified. If PACK specifies a */ +/* > packed or banded storage scheme, all LDA elements of the */ +/* > first N columns will be modified; the elements of the */ +/* > array which do not correspond to elements of the generated */ +/* > matrix are set to zero. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */ +/* > LDA must be at least M. If PACK='B' or 'Q', then LDA must */ +/* > be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */ +/* > If PACK='Z', LDA must be large enough to hold the packed */ +/* > array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension ( 3*MAX( N, M ) ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => KL negative */ +/* > -11 => KU negative, or SYM is not 'N' and KU is not equal to */ +/* > KL */ +/* > -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */ +/* > or PACK='C' or 'Q' and SYM='N' and KL is not zero; */ +/* > or PACK='R' or 'B' and SYM='N' and KU is not zero; */ +/* > or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */ +/* > N. */ +/* > -14 => LDA is less than M, or PACK='Z' and LDA is less than */ +/* > MIN(KU,N-1) + MIN(KL,M-1) + 1. */ +/* > 1 => Error return from SLATM1 */ +/* > 2 => Cannot scale to DMAX (f2cmax. sing. value is 0) */ +/* > 3 => Error return from CLAGGE, CLAGHE or CLAGSY */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clatms_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__, + integer *kl, integer *ku, char *pack, complex *a, integer *lda, + complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real r__1, r__2, r__3; + complex q__1, q__2, q__3; + logical L__1; + + /* Local variables */ + integer ilda, icol; + real temp; + logical csym; + integer irow, isym; + complex c__; + integer i__, j, k; + complex s; + real alpha, angle; + integer ipack; + real realc; + integer ioffg; + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + complex ctemp; + integer idist, mnmin, iskew; + complex extra, dummy; + extern /* Subroutine */ int slatm1_(integer *, real *, integer *, integer + *, integer *, real *, integer *, integer *); + integer ic, jc, nc; + extern /* Subroutine */ int clagge_(integer *, integer *, integer *, + integer *, real *, complex *, integer *, integer *, complex *, + integer *), claghe_(integer *, integer *, real *, complex *, + integer *, integer *, complex *, integer *); + integer il; + complex ct; + integer iendch, ir, jr, ipackg, mr; + //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); + extern complex clarnd_(integer *, integer *); + integer minlda; + complex st; + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *), clartg_(complex *, + complex *, real *, complex *, complex *), xerbla_(char *, integer + *), clagsy_(integer *, integer *, real *, complex *, + integer *, integer *, complex *, integer *); + extern real slarnd_(integer *, integer *); + extern /* Subroutine */ int clarot_(logical *, logical *, logical *, + integer *, complex *, complex *, complex *, integer *, complex *, + complex *); + logical iltemp, givens; + integer ioffst, irsign; + logical ilextr, topdwn; + integer ir1, ir2, isympk, jch, llb, jkl, jku, uub; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "N")) { + isym = 1; + irsign = 0; + csym = FALSE_; + } else if (lsame_(sym, "P")) { + isym = 2; + irsign = 0; + csym = FALSE_; + } else if (lsame_(sym, "S")) { + isym = 2; + irsign = 0; + csym = TRUE_; + } else if (lsame_(sym, "H")) { + isym = 2; + irsign = 1; + csym = FALSE_; + } else { + isym = -1; + } + +/* Decode PACK */ + + isympk = 0; + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + isympk = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + isympk = 1; + } else if (lsame_(pack, "C")) { + ipack = 3; + isympk = 2; + } else if (lsame_(pack, "R")) { + ipack = 4; + isympk = 3; + } else if (lsame_(pack, "B")) { + ipack = 5; + isympk = 3; + } else if (lsame_(pack, "Q")) { + ipack = 6; + isympk = 2; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + llb = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + uub = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *m, i__2 = *n + llb; + mr = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *n, i__2 = *m + uub; + nc = f2cmin(i__1,i__2); + + if (ipack == 5 || ipack == 6) { + minlda = uub + 1; + } else if (ipack == 7) { + minlda = llb + uub + 1; + } else { + minlda = *m; + } + +/* Use Givens rotation method if bandwidth small enough, */ +/* or if LDA is too small to store the matrix unpacked. */ + + givens = FALSE_; + if (isym == 1) { +/* Computing MAX */ + i__1 = 1, i__2 = mr + nc; + if ((real) (llb + uub) < (real) f2cmax(i__1,i__2) * .3f) { + givens = TRUE_; + } + } else { + if (llb << 1 < *m) { + givens = TRUE_; + } + } + if (*lda < *m && *lda >= minlda) { + givens = TRUE_; + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && isym != 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (abs(*mode) > 6) { + *info = -7; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) { + *info = -8; + } else if (*kl < 0) { + *info = -10; + } else if (*ku < 0 || isym != 1 && *kl != *ku) { + *info = -11; + } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym + == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk + != 0 && *m != *n) { + *info = -12; + } else if (*lda < f2cmax(1,minlda)) { + *info = -14; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLATMS", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L10: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up D if indicated. */ + +/* Compute D according to COND and MODE */ + + slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, &iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + +/* Choose Top-Down if D is (apparently) increasing, */ +/* Bottom-Up if D is (apparently) decreasing. */ + + if (abs(d__[1]) <= (r__1 = d__[mnmin], abs(r__1))) { + topdwn = TRUE_; + } else { + topdwn = FALSE_; + } + + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = mnmin; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = temp, r__3 = (r__1 = d__[i__], abs(r__1)); + temp = f2cmax(r__2,r__3); +/* L20: */ + } + + if (temp > 0.f) { + alpha = *dmax__ / temp; + } else { + *info = 2; + return 0; + } + + sscal_(&mnmin, &alpha, &d__[1], &c__1); + + } + + claset_("Full", lda, n, &c_b1, &c_b1, &a[a_offset], lda); + +/* 3) Generate Banded Matrix using Givens rotations. */ +/* Also the special case of UUB=LLB=0 */ + +/* Compute Addressing constants to cover all */ +/* storage formats. Whether GE, HE, SY, GB, HB, or SB, */ +/* upper or lower triangle or both, */ +/* the (i,j)-th element is in */ +/* A( i - ISKEW*j + IOFFST, j ) */ + + if (ipack > 4) { + ilda = *lda - 1; + iskew = 1; + if (ipack > 5) { + ioffst = uub + 1; + } else { + ioffst = 1; + } + } else { + ilda = *lda; + iskew = 0; + ioffst = 0; + } + +/* IPACKG is the format that the matrix is generated in. If this is */ +/* different from IPACK, then the matrix must be repacked at the */ +/* end. It also signals how to compute the norm, for scaling. */ + + ipackg = 0; + +/* Diagonal Matrix -- We are done, unless it */ +/* is to be stored HP/SP/PP/TP (PACK='R' or 'C') */ + + if (llb == 0 && uub == 0) { + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__2 = (1 - iskew) * j + ioffst + j * a_dim1; + i__3 = j; + q__1.r = d__[i__3], q__1.i = 0.f; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L30: */ + } + + if (ipack <= 2 || ipack >= 5) { + ipackg = ipack; + } + + } else if (givens) { + +/* Check whether to use Givens rotations, */ +/* Householder transformations, or nothing. */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + if (ipack > 4) { + ipackg = ipack; + } else { + ipackg = 0; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__2 = (1 - iskew) * j + ioffst + j * a_dim1; + i__3 = j; + q__1.r = d__[i__3], q__1.i = 0.f; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L40: */ + } + + if (topdwn) { + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* Last row actually rotated is M */ +/* Last column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__3 = *m + jku; + i__2 = f2cmin(i__3,*n) + jkl - 1; + for (jr = 1; jr <= i__2; ++jr) { + extra.r = 0.f, extra.i = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; +/* Computing MAX */ + i__3 = 1, i__4 = jr - jkl; + icol = f2cmax(i__3,i__4); + if (jr < *m) { +/* Computing MIN */ + i__3 = *n, i__4 = jr + jku; + il = f2cmin(i__3,i__4) + 1 - icol; + L__1 = jr > jkl; + clarot_(&c_true, &L__1, &c_false, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ir = jr; + ic = icol; + i__3 = -jkl - jku; + for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ir < *m) { + clartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &realc, + &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__2.r = realc * dummy.r, q__2.i = realc * + dummy.i; + r_cnjg(&q__1, &q__2); + c__.r = q__1.r, c__.i = q__1.i; + q__3.r = -s.r, q__3.i = -s.i; + q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, + q__2.i = q__3.r * dummy.i + q__3.i * + dummy.r; + r_cnjg(&q__1, &q__2); + s.r = q__1.r, s.i = q__1.i; + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + ctemp.r = 0.f, ctemp.i = 0.f; + iltemp = jch > jku; + clarot_(&c_false, &iltemp, &c_true, &il, &c__, &s, + &a[irow - iskew * ic + ioffst + ic * + a_dim1], &ilda, &ctemp, &extra); + if (iltemp) { + clartg_(&a[irow + 1 - iskew * (ic + 1) + + ioffst + (ic + 1) * a_dim1], &ctemp, & + realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__2.r = realc * dummy.r, q__2.i = realc * + dummy.i; + r_cnjg(&q__1, &q__2); + c__.r = q__1.r, c__.i = q__1.i; + q__3.r = -s.r, q__3.i = -s.i; + q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, + q__2.i = q__3.r * dummy.i + q__3.i * + dummy.r; + r_cnjg(&q__1, &q__2); + s.r = q__1.r, s.i = q__1.i; + +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + extra.r = 0.f, extra.i = 0.f; + L__1 = jch > jku + jkl; + clarot_(&c_true, &L__1, &c_true, &il, &c__, & + s, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, &ctemp) + ; + ic = icol; + ir = irow; + } +/* L50: */ + } +/* L60: */ + } +/* L70: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* Computing MIN */ + i__3 = *n + jkl; + i__2 = f2cmin(i__3,*m) + jku - 1; + for (jc = 1; jc <= i__2; ++jc) { + extra.r = 0.f, extra.i = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; +/* Computing MAX */ + i__3 = 1, i__4 = jc - jku; + irow = f2cmax(i__3,i__4); + if (jc < *n) { +/* Computing MIN */ + i__3 = *m, i__4 = jc + jkl; + il = f2cmin(i__3,i__4) + 1 - irow; + L__1 = jc > jku; + clarot_(&c_false, &L__1, &c_false, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ic = jc; + ir = irow; + i__3 = -jkl - jku; + for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ic < *n) { + clartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &realc, + &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__2.r = realc * dummy.r, q__2.i = realc * + dummy.i; + r_cnjg(&q__1, &q__2); + c__.r = q__1.r, c__.i = q__1.i; + q__3.r = -s.r, q__3.i = -s.i; + q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, + q__2.i = q__3.r * dummy.i + q__3.i * + dummy.r; + r_cnjg(&q__1, &q__2); + s.r = q__1.r, s.i = q__1.i; + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + ctemp.r = 0.f, ctemp.i = 0.f; + iltemp = jch > jkl; + clarot_(&c_true, &iltemp, &c_true, &il, &c__, &s, + &a[ir - iskew * icol + ioffst + icol * + a_dim1], &ilda, &ctemp, &extra); + if (iltemp) { + clartg_(&a[ir + 1 - iskew * (icol + 1) + + ioffst + (icol + 1) * a_dim1], &ctemp, + &realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__2.r = realc * dummy.r, q__2.i = realc * + dummy.i; + r_cnjg(&q__1, &q__2); + c__.r = q__1.r, c__.i = q__1.i; + q__3.r = -s.r, q__3.i = -s.i; + q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, + q__2.i = q__3.r * dummy.i + q__3.i * + dummy.r; + r_cnjg(&q__1, &q__2); + s.r = q__1.r, s.i = q__1.i; +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + extra.r = 0.f, extra.i = 0.f; + L__1 = jch > jkl + jku; + clarot_(&c_false, &L__1, &c_true, &il, &c__, & + s, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, &ctemp) + ; + ic = icol; + ir = irow; + } +/* L80: */ + } +/* L90: */ + } +/* L100: */ + } + + } else { + +/* Bottom-Up -- Start at the bottom right. */ + + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* First row actually rotated is M */ +/* First column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n + jkl; + iendch = f2cmin(i__2,i__3) - 1; +/* Computing MIN */ + i__2 = *m + jku; + i__3 = 1 - jkl; + for (jc = f2cmin(i__2,*n) - 1; jc >= i__3; --jc) { + extra.r = 0.f, extra.i = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; +/* Computing MAX */ + i__2 = 1, i__4 = jc - jku + 1; + irow = f2cmax(i__2,i__4); + if (jc > 0) { +/* Computing MIN */ + i__2 = *m, i__4 = jc + jkl + 1; + il = f2cmin(i__2,i__4) + 1 - irow; + L__1 = jc + jkl < *m; + clarot_(&c_false, &c_false, &L__1, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ic = jc; + i__2 = iendch; + i__4 = jkl + jku; + for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <= + i__2; jch += i__4) { + ilextr = ic > 0; + if (ilextr) { + clartg_(&a[jch - iskew * ic + ioffst + ic * + a_dim1], &extra, &realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__1.r = realc * dummy.r, q__1.i = realc * + dummy.i; + c__.r = q__1.r, c__.i = q__1.i; + q__1.r = s.r * dummy.r - s.i * dummy.i, + q__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = q__1.r, s.i = q__1.i; + } + ic = f2cmax(1,ic); +/* Computing MIN */ + i__5 = *n - 1, i__6 = jch + jku; + icol = f2cmin(i__5,i__6); + iltemp = jch + jku < *n; + ctemp.r = 0.f, ctemp.i = 0.f; + i__5 = icol + 2 - ic; + clarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, & + s, &a[jch - iskew * ic + ioffst + ic * + a_dim1], &ilda, &extra, &ctemp); + if (iltemp) { + clartg_(&a[jch - iskew * icol + ioffst + icol + * a_dim1], &ctemp, &realc, &s, &dummy) + ; + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__1.r = realc * dummy.r, q__1.i = realc * + dummy.i; + c__.r = q__1.r, c__.i = q__1.i; + q__1.r = s.r * dummy.r - s.i * dummy.i, + q__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = q__1.r, s.i = q__1.i; +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra.r = 0.f, extra.i = 0.f; + L__1 = jch + jkl + jku <= iendch; + clarot_(&c_false, &c_true, &L__1, &il, &c__, & + s, &a[jch - iskew * icol + ioffst + + icol * a_dim1], &ilda, &ctemp, &extra) + ; + ic = icol; + } +/* L110: */ + } +/* L120: */ + } +/* L130: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* First row actually rotated is MIN( N+JKL, M ) */ +/* First column actually rotated is N */ + +/* Computing MIN */ + i__3 = *n, i__4 = *m + jku; + iendch = f2cmin(i__3,i__4) - 1; +/* Computing MIN */ + i__3 = *n + jkl; + i__4 = 1 - jku; + for (jr = f2cmin(i__3,*m) - 1; jr >= i__4; --jr) { + extra.r = 0.f, extra.i = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; +/* Computing MAX */ + i__3 = 1, i__2 = jr - jkl + 1; + icol = f2cmax(i__3,i__2); + if (jr > 0) { +/* Computing MIN */ + i__3 = *n, i__2 = jr + jku + 1; + il = f2cmin(i__3,i__2) + 1 - icol; + L__1 = jr + jku < *n; + clarot_(&c_true, &c_false, &L__1, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ir = jr; + i__3 = iendch; + i__2 = jkl + jku; + for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <= + i__3; jch += i__2) { + ilextr = ir > 0; + if (ilextr) { + clartg_(&a[ir - iskew * jch + ioffst + jch * + a_dim1], &extra, &realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__1.r = realc * dummy.r, q__1.i = realc * + dummy.i; + c__.r = q__1.r, c__.i = q__1.i; + q__1.r = s.r * dummy.r - s.i * dummy.i, + q__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = q__1.r, s.i = q__1.i; + } + ir = f2cmax(1,ir); +/* Computing MIN */ + i__5 = *m - 1, i__6 = jch + jkl; + irow = f2cmin(i__5,i__6); + iltemp = jch + jkl < *m; + ctemp.r = 0.f, ctemp.i = 0.f; + i__5 = irow + 2 - ir; + clarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, & + s, &a[ir - iskew * jch + ioffst + jch * + a_dim1], &ilda, &extra, &ctemp); + if (iltemp) { + clartg_(&a[irow - iskew * jch + ioffst + jch * + a_dim1], &ctemp, &realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__1.r = realc * dummy.r, q__1.i = realc * + dummy.i; + c__.r = q__1.r, c__.i = q__1.i; + q__1.r = s.r * dummy.r - s.i * dummy.i, + q__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = q__1.r, s.i = q__1.i; +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra.r = 0.f, extra.i = 0.f; + L__1 = jch + jkl + jku <= iendch; + clarot_(&c_true, &c_true, &L__1, &il, &c__, & + s, &a[irow - iskew * jch + ioffst + + jch * a_dim1], &ilda, &ctemp, &extra); + ir = irow; + } +/* L140: */ + } +/* L150: */ + } +/* L160: */ + } + + } + + } else { + +/* Symmetric -- A = U D U' */ +/* Hermitian -- A = U D U* */ + + ipackg = ipack; + ioffg = ioffst; + + if (topdwn) { + +/* Top-Down -- Generate Upper triangle only */ + + if (ipack >= 5) { + ipackg = 6; + ioffg = uub + 1; + } else { + ipackg = 1; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__4 = (1 - iskew) * j + ioffg + j * a_dim1; + i__2 = j; + q__1.r = d__[i__2], q__1.i = 0.f; + a[i__4].r = q__1.r, a[i__4].i = q__1.i; +/* L170: */ + } + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + i__4 = *n - 1; + for (jc = 1; jc <= i__4; ++jc) { +/* Computing MAX */ + i__2 = 1, i__3 = jc - k; + irow = f2cmax(i__2,i__3); +/* Computing MIN */ + i__2 = jc + 1, i__3 = k + 2; + il = f2cmin(i__2,i__3); + extra.r = 0.f, extra.i = 0.f; + i__2 = jc - iskew * (jc + 1) + ioffg + (jc + 1) * + a_dim1; + ctemp.r = a[i__2].r, ctemp.i = a[i__2].i; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + r_cnjg(&q__1, &ctemp); + ctemp.r = q__1.r, ctemp.i = q__1.i; + r_cnjg(&q__1, &c__); + ct.r = q__1.r, ct.i = q__1.i; + r_cnjg(&q__1, &s); + st.r = q__1.r, st.i = q__1.i; + } + L__1 = jc > k; + clarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[ + irow - iskew * jc + ioffg + jc * a_dim1], & + ilda, &extra, &ctemp); +/* Computing MIN */ + i__3 = k, i__5 = *n - jc; + i__2 = f2cmin(i__3,i__5) + 1; + clarot_(&c_true, &c_true, &c_false, &i__2, &ct, &st, & + a[(1 - iskew) * jc + ioffg + jc * a_dim1], & + ilda, &ctemp, &dummy); + +/* Chase EXTRA back up the matrix */ + + icol = jc; + i__2 = -k; + for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1; + jch += i__2) { + clartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg + + (icol + 1) * a_dim1], &extra, &realc, &s, + &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__2.r = realc * dummy.r, q__2.i = realc * + dummy.i; + r_cnjg(&q__1, &q__2); + c__.r = q__1.r, c__.i = q__1.i; + q__3.r = -s.r, q__3.i = -s.i; + q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, + q__2.i = q__3.r * dummy.i + q__3.i * + dummy.r; + r_cnjg(&q__1, &q__2); + s.r = q__1.r, s.i = q__1.i; + i__3 = jch - iskew * (jch + 1) + ioffg + (jch + 1) + * a_dim1; + ctemp.r = a[i__3].r, ctemp.i = a[i__3].i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + r_cnjg(&q__1, &ctemp); + ctemp.r = q__1.r, ctemp.i = q__1.i; + r_cnjg(&q__1, &c__); + ct.r = q__1.r, ct.i = q__1.i; + r_cnjg(&q__1, &s); + st.r = q__1.r, st.i = q__1.i; + } + i__3 = k + 2; + clarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &ctemp, &extra); +/* Computing MAX */ + i__3 = 1, i__5 = jch - k; + irow = f2cmax(i__3,i__5); +/* Computing MIN */ + i__3 = jch + 1, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra.r = 0.f, extra.i = 0.f; + L__1 = jch > k; + clarot_(&c_false, &L__1, &c_true, &il, &ct, &st, & + a[irow - iskew * jch + ioffg + jch * + a_dim1], &ilda, &extra, &ctemp); + icol = jch; +/* L180: */ + } +/* L190: */ + } +/* L200: */ + } + +/* If we need lower triangle, copy from upper. Note that */ +/* the order of copying is chosen to work for 'q' -> 'b' */ + + if (ipack != ipackg && ipack != 3) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst - iskew * jc; + if (csym) { +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + i__2 = jr + irow + jc * a_dim1; + i__3 = jc - iskew * jr + ioffg + jr * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; +/* L210: */ + } + } else { +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + i__2 = jr + irow + jc * a_dim1; + r_cnjg(&q__1, &a[jc - iskew * jr + ioffg + jr + * a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L220: */ + } + } +/* L230: */ + } + if (ipack == 5) { + i__1 = *n; + for (jc = *n - uub + 1; jc <= i__1; ++jc) { + i__4 = uub + 1; + for (jr = *n + 2 - jc; jr <= i__4; ++jr) { + i__2 = jr + jc * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L240: */ + } +/* L250: */ + } + } + if (ipackg == 6) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } else { + +/* Bottom-Up -- Generate Lower triangle only */ + + if (ipack >= 5) { + ipackg = 5; + if (ipack == 6) { + ioffg = 1; + } + } else { + ipackg = 2; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__4 = (1 - iskew) * j + ioffg + j * a_dim1; + i__2 = j; + q__1.r = d__[i__2], q__1.i = 0.f; + a[i__4].r = q__1.r, a[i__4].i = q__1.i; +/* L260: */ + } + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + for (jc = *n - 1; jc >= 1; --jc) { +/* Computing MIN */ + i__4 = *n + 1 - jc, i__2 = k + 2; + il = f2cmin(i__4,i__2); + extra.r = 0.f, extra.i = 0.f; + i__4 = (1 - iskew) * jc + 1 + ioffg + jc * a_dim1; + ctemp.r = a[i__4].r, ctemp.i = a[i__4].i; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + r_cnjg(&q__1, &ctemp); + ctemp.r = q__1.r, ctemp.i = q__1.i; + r_cnjg(&q__1, &c__); + ct.r = q__1.r, ct.i = q__1.i; + r_cnjg(&q__1, &s); + st.r = q__1.r, st.i = q__1.i; + } + L__1 = *n - jc > k; + clarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[( + 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda, + &ctemp, &extra); +/* Computing MAX */ + i__4 = 1, i__2 = jc - k + 1; + icol = f2cmax(i__4,i__2); + i__4 = jc + 2 - icol; + clarot_(&c_true, &c_false, &c_true, &i__4, &ct, &st, & + a[jc - iskew * icol + ioffg + icol * a_dim1], + &ilda, &dummy, &ctemp); + +/* Chase EXTRA back down the matrix */ + + icol = jc; + i__4 = *n - 1; + i__2 = k; + for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <= + i__4; jch += i__2) { + clartg_(&a[jch - iskew * icol + ioffg + icol * + a_dim1], &extra, &realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__1.r = realc * dummy.r, q__1.i = realc * + dummy.i; + c__.r = q__1.r, c__.i = q__1.i; + q__1.r = s.r * dummy.r - s.i * dummy.i, q__1.i = + s.r * dummy.i + s.i * dummy.r; + s.r = q__1.r, s.i = q__1.i; + i__3 = (1 - iskew) * jch + 1 + ioffg + jch * + a_dim1; + ctemp.r = a[i__3].r, ctemp.i = a[i__3].i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + r_cnjg(&q__1, &ctemp); + ctemp.r = q__1.r, ctemp.i = q__1.i; + r_cnjg(&q__1, &c__); + ct.r = q__1.r, ct.i = q__1.i; + r_cnjg(&q__1, &s); + st.r = q__1.r, st.i = q__1.i; + } + i__3 = k + 2; + clarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[jch - iskew * icol + ioffg + icol * + a_dim1], &ilda, &extra, &ctemp); +/* Computing MIN */ + i__3 = *n + 1 - jch, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra.r = 0.f, extra.i = 0.f; + L__1 = *n - jch > k; + clarot_(&c_false, &c_true, &L__1, &il, &ct, &st, & + a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &ctemp, &extra); + icol = jch; +/* L270: */ + } +/* L280: */ + } +/* L290: */ + } + +/* If we need upper triangle, copy from lower. Note that */ +/* the order of copying is chosen to work for 'b' -> 'q' */ + + if (ipack != ipackg && ipack != 4) { + for (jc = *n; jc >= 1; --jc) { + irow = ioffst - iskew * jc; + if (csym) { +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + i__2 = jr + irow + jc * a_dim1; + i__4 = jc - iskew * jr + ioffg + jr * a_dim1; + a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i; +/* L300: */ + } + } else { +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + i__2 = jr + irow + jc * a_dim1; + r_cnjg(&q__1, &a[jc - iskew * jr + ioffg + jr + * a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L310: */ + } + } +/* L320: */ + } + if (ipack == 6) { + i__1 = uub; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L330: */ + } +/* L340: */ + } + } + if (ipackg == 5) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } + +/* Ensure that the diagonal is real if Hermitian */ + + if (! csym) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst + (1 - iskew) * jc; + i__2 = irow + jc * a_dim1; + i__4 = irow + jc * a_dim1; + r__1 = a[i__4].r; + q__1.r = r__1, q__1.i = 0.f; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L350: */ + } + } + + } + + } else { + +/* 4) Generate Banded Matrix by first */ +/* Rotating by random Unitary matrices, */ +/* then reducing the bandwidth using Householder */ +/* transformations. */ + +/* Note: we should get here only if LDA .ge. N */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + clagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[ + 1], &work[1], &iinfo); + } else { + +/* Symmetric -- A = U D U' or */ +/* Hermitian -- A = U D U* */ + + if (csym) { + clagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[ + 1], &iinfo); + } else { + claghe_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[ + 1], &iinfo); + } + } + + if (iinfo != 0) { + *info = 3; + return 0; + } + } + +/* 5) Pack the matrix */ + + if (ipack != ipackg) { + if (ipack == 1) { + +/* 'U' -- Upper triangular, not packed */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__4 = i__ + j * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L360: */ + } +/* L370: */ + } + + } else if (ipack == 2) { + +/* 'L' -- Lower triangular, not packed */ + + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__4 = i__ + j * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L380: */ + } +/* L390: */ + } + + } else if (ipack == 3) { + +/* 'C' -- Upper triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + i__4 = irow + icol * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L400: */ + } +/* L410: */ + } + + } else if (ipack == 4) { + +/* 'R' -- Lower triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + i__4 = irow + icol * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L420: */ + } +/* L430: */ + } + + } else if (ipack >= 5) { + +/* 'B' -- The lower triangle is packed as a band matrix. */ +/* 'Q' -- The upper triangle is packed as a band matrix. */ +/* 'Z' -- The whole matrix is packed as a band matrix. */ + + if (ipack == 5) { + uub = 0; + } + if (ipack == 6) { + llb = 0; + } + + i__1 = uub; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = j + llb; + for (i__ = f2cmin(i__2,*m); i__ >= 1; --i__) { + i__2 = i__ - j + uub + 1 + j * a_dim1; + i__4 = i__ + j * a_dim1; + a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i; +/* L440: */ + } +/* L450: */ + } + + i__1 = *n; + for (j = uub + 2; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = j + llb; + i__2 = f2cmin(i__4,*m); + for (i__ = j - uub; i__ <= i__2; ++i__) { + i__4 = i__ - j + uub + 1 + j * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L460: */ + } +/* L470: */ + } + } + +/* If packed, zero out extraneous elements. */ + +/* Symmetric/Triangular Packed -- */ +/* zero out everything after A(IROW,ICOL) */ + + if (ipack == 3 || ipack == 4) { + i__1 = *m; + for (jc = icol; jc <= i__1; ++jc) { + i__2 = *lda; + for (jr = irow + 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L480: */ + } + irow = 0; +/* L490: */ + } + + } else if (ipack >= 5) { + +/* Packed Band -- */ +/* 1st row is now in A( UUB+2-j, j), zero above it */ +/* m-th row is now in A( M+UUB-j,j), zero below it */ +/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */ +/* zero below it, too. */ + + ir1 = uub + llb + 2; + ir2 = uub + *m + 2; + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L500: */ + } +/* Computing MAX */ +/* Computing MIN */ + i__3 = ir1, i__5 = ir2 - jc; + i__2 = 1, i__4 = f2cmin(i__3,i__5); + i__6 = *lda; + for (jr = f2cmax(i__2,i__4); jr <= i__6; ++jr) { + i__2 = jr + jc * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L510: */ + } +/* L520: */ + } + } + } + + return 0; + +/* End of CLATMS */ + +} /* clatms_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/clatmt.c b/lapack-netlib/TESTING/MATGEN/clatmt.c new file mode 100644 index 000000000..415ff158f --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/clatmt.c @@ -0,0 +1,2100 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b CLATMT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE CLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* RANK, KL, KU, PACK, A, LDA, WORK, INFO ) */ + +/* REAL COND, DMAX */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK */ +/* CHARACTER DIST, PACK, SYM */ +/* COMPLEX A( LDA, * ), WORK( * ) */ +/* REAL D( * ) */ +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CLATMT generates random matrices with specified singular values */ +/* > (or hermitian with specified eigenvalues) */ +/* > for testing LAPACK programs. */ +/* > */ +/* > CLATMT operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and SYM */ +/* > as described below. */ +/* > */ +/* > Generate a matrix with the appropriate band structure, by one */ +/* > of two methods: */ +/* > */ +/* > Method A: */ +/* > Generate a dense M x N matrix by multiplying D on the left */ +/* > and the right by random unitary matrices, then: */ +/* > */ +/* > Reduce the bandwidth according to KL and KU, using */ +/* > Householder transformations. */ +/* > */ +/* > Method B: */ +/* > Convert the bandwidth-0 (i.e., diagonal) matrix to a */ +/* > bandwidth-1 matrix using Givens rotations, "chasing" */ +/* > out-of-band elements back, much as in QR; then convert */ +/* > the bandwidth-1 to a bandwidth-2 matrix, etc. Note */ +/* > that for reasonably small bandwidths (relative to M and */ +/* > N) this requires less storage, as a dense matrix is not */ +/* > generated. Also, for hermitian or symmetric matrices, */ +/* > only one triangle is generated. */ +/* > */ +/* > Method A is chosen if the bandwidth is a large fraction of the */ +/* > order of the matrix, and LDA is at least M (so a dense */ +/* > matrix can be stored.) Method B is chosen if the bandwidth */ +/* > is small (< 1/2 N for hermitian or symmetric, < .3 N+M for */ +/* > non-symmetric), or LDA is less than M and not less than the */ +/* > bandwidth. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if hermitian) */ +/* > zero out lower half (if hermitian) */ +/* > store the upper half columnwise (if hermitian or upper */ +/* > triangular) */ +/* > store the lower half columnwise (if hermitian or lower */ +/* > triangular) */ +/* > store the lower triangle in banded format (if hermitian or */ +/* > lower triangular) */ +/* > store the upper triangle in banded format (if hermitian or */ +/* > upper triangular) */ +/* > store the entire matrix in banded format */ +/* > If Method B is chosen, and band format is specified, then the */ +/* > matrix will be generated in the band format, so no repacking */ +/* > will be necessary. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of A. N must equal M if the matrix */ +/* > is symmetric or hermitian (i.e., if SYM is not 'N') */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values. */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to CLATMT */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='H', the generated matrix is hermitian, with */ +/* > eigenvalues specified by D, COND, MODE, and DMAX; they */ +/* > may be positive, negative, or zero. */ +/* > If SYM='P', the generated matrix is hermitian, with */ +/* > eigenvalues (= singular values) specified by D, COND, */ +/* > MODE, and DMAX; they will not be negative. */ +/* > If SYM='N', the generated matrix is nonsymmetric, with */ +/* > singular values specified by D, COND, MODE, and DMAX; */ +/* > they will not be negative. */ +/* > If SYM='S', the generated matrix is (complex) symmetric, */ +/* > with singular values specified by D, COND, MODE, and */ +/* > DMAX; they will not be negative. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension ( MIN( M, N ) ) */ +/* > This array is used to specify the singular values or */ +/* > eigenvalues of A (see SYM, above.) If MODE=0, then D is */ +/* > assumed to contain the singular/eigenvalues, otherwise */ +/* > they will be computed according to MODE, COND, and DMAX, */ +/* > and placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the singular/eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */ +/* > MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > If SYM='H', and MODE is neither 0, 6, nor -6, then */ +/* > the elements of D will also be multiplied by a random */ +/* > sign (i.e., +1 or -1.) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is REAL */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is REAL */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))); thus, the maximum absolute eigen- or */ +/* > singular value (which is to say the norm) will be abs(DMAX). */ +/* > Note that DMAX need not be positive: if DMAX is negative */ +/* > (or zero), D will be scaled by a negative number (or zero). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The rank of matrix to be generated for modes 1,2,3 only. */ +/* > D( RANK+1:N ) = 0. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL being at least M-1 means that the matrix */ +/* > has full lower bandwidth. KL must equal KU if the matrix */ +/* > is symmetric or hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU being at least N-1 means that the matrix */ +/* > has full upper bandwidth. KL must equal KU if the matrix */ +/* > is symmetric or hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > This specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries (if symmetric */ +/* > or hermitian) */ +/* > 'L' => zero out all superdiagonal entries (if symmetric */ +/* > or hermitian) */ +/* > 'C' => store the upper triangle columnwise (only if the */ +/* > matrix is symmetric, hermitian, or upper triangular) */ +/* > 'R' => store the lower triangle columnwise (only if the */ +/* > matrix is symmetric, hermitian, or lower triangular) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if the matrix is symmetric, hermitian, or */ +/* > lower triangular) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if the matrix is symmetric, hermitian, or */ +/* > upper triangular) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, SB, HB, or TB - use 'B' or 'Q' */ +/* > PP, SP, HB, or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to CLATMT differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. A is first generated */ +/* > in full (unpacked) form, and then packed, if so specified */ +/* > by PACK. Thus, the first M elements of the first N */ +/* > columns will always be modified. If PACK specifies a */ +/* > packed or banded storage scheme, all LDA elements of the */ +/* > first N columns will be modified; the elements of the */ +/* > array which do not correspond to elements of the generated */ +/* > matrix are set to zero. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */ +/* > LDA must be at least M. If PACK='B' or 'Q', then LDA must */ +/* > be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */ +/* > If PACK='Z', LDA must be large enough to hold the packed */ +/* > array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX array, dimension ( 3*MAX( N, M ) ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => KL negative */ +/* > -11 => KU negative, or SYM is not 'N' and KU is not equal to */ +/* > KL */ +/* > -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */ +/* > or PACK='C' or 'Q' and SYM='N' and KL is not zero; */ +/* > or PACK='R' or 'B' and SYM='N' and KU is not zero; */ +/* > or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */ +/* > N. */ +/* > -14 => LDA is less than M, or PACK='Z' and LDA is less than */ +/* > MIN(KU,N-1) + MIN(KL,M-1) + 1. */ +/* > 1 => Error return from SLATM7 */ +/* > 2 => Cannot scale to DMAX (f2cmax. sing. value is 0) */ +/* > 3 => Error return from CLAGGE, CLAGHE or CLAGSY */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int clatmt_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__, + integer *rank, integer *kl, integer *ku, char *pack, complex *a, + integer *lda, complex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real r__1, r__2, r__3; + complex q__1, q__2, q__3; + logical L__1; + + /* Local variables */ + integer ilda, icol; + real temp; + logical csym; + integer irow, isym; + complex c__; + integer i__, j, k; + complex s; + real alpha, angle, realc; + integer ipack, ioffg; + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + complex ctemp; + integer idist, mnmin; + complex extra; + integer iskew; + complex dummy; + extern /* Subroutine */ int slatm7_(integer *, real *, integer *, integer + *, integer *, real *, integer *, integer *, integer *); + integer ic, jc, nc; + extern /* Subroutine */ int clagge_(integer *, integer *, integer *, + integer *, real *, complex *, integer *, integer *, complex *, + integer *), claghe_(integer *, integer *, real *, complex *, + integer *, integer *, complex *, integer *); + integer il; + complex ct; + integer iendch, ir, jr, ipackg, mr; + //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *); + extern complex clarnd_(integer *, integer *); + integer minlda; + complex st; + extern /* Subroutine */ int claset_(char *, integer *, integer *, complex + *, complex *, complex *, integer *), clartg_(complex *, + complex *, real *, complex *, complex *), xerbla_(char *, integer + *), clagsy_(integer *, integer *, real *, complex *, + integer *, integer *, complex *, integer *); + extern real slarnd_(integer *, integer *); + extern /* Subroutine */ int clarot_(logical *, logical *, logical *, + integer *, complex *, complex *, complex *, integer *, complex *, + complex *); + integer ioffst, irsign; + logical givens, iltemp, ilextr, topdwn; + integer ir1, ir2, isympk, jch, llb, jkl, jku, uub; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "N")) { + isym = 1; + irsign = 0; + csym = FALSE_; + } else if (lsame_(sym, "P")) { + isym = 2; + irsign = 0; + csym = FALSE_; + } else if (lsame_(sym, "S")) { + isym = 2; + irsign = 0; + csym = TRUE_; + } else if (lsame_(sym, "H")) { + isym = 2; + irsign = 1; + csym = FALSE_; + } else { + isym = -1; + } + +/* Decode PACK */ + + isympk = 0; + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + isympk = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + isympk = 1; + } else if (lsame_(pack, "C")) { + ipack = 3; + isympk = 2; + } else if (lsame_(pack, "R")) { + ipack = 4; + isympk = 3; + } else if (lsame_(pack, "B")) { + ipack = 5; + isympk = 3; + } else if (lsame_(pack, "Q")) { + ipack = 6; + isympk = 2; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + llb = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + uub = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *m, i__2 = *n + llb; + mr = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *n, i__2 = *m + uub; + nc = f2cmin(i__1,i__2); + + if (ipack == 5 || ipack == 6) { + minlda = uub + 1; + } else if (ipack == 7) { + minlda = llb + uub + 1; + } else { + minlda = *m; + } + +/* Use Givens rotation method if bandwidth small enough, */ +/* or if LDA is too small to store the matrix unpacked. */ + + givens = FALSE_; + if (isym == 1) { +/* Computing MAX */ + i__1 = 1, i__2 = mr + nc; + if ((real) (llb + uub) < (real) f2cmax(i__1,i__2) * .3f) { + givens = TRUE_; + } + } else { + if (llb << 1 < *m) { + givens = TRUE_; + } + } + if (*lda < *m && *lda >= minlda) { + givens = TRUE_; + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && isym != 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (abs(*mode) > 6) { + *info = -7; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) { + *info = -8; + } else if (*kl < 0) { + *info = -10; + } else if (*ku < 0 || isym != 1 && *kl != *ku) { + *info = -11; + } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym + == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk + != 0 && *m != *n) { + *info = -12; + } else if (*lda < f2cmax(1,minlda)) { + *info = -14; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CLATMT", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L100: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up D if indicated. */ + +/* Compute D according to COND and MODE */ + + slatm7_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, rank, & + iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + +/* Choose Top-Down if D is (apparently) increasing, */ +/* Bottom-Up if D is (apparently) decreasing. */ + + if (abs(d__[1]) <= (r__1 = d__[*rank], abs(r__1))) { + topdwn = TRUE_; + } else { + topdwn = FALSE_; + } + + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = *rank; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = temp, r__3 = (r__1 = d__[i__], abs(r__1)); + temp = f2cmax(r__2,r__3); +/* L110: */ + } + + if (temp > 0.f) { + alpha = *dmax__ / temp; + } else { + *info = 2; + return 0; + } + + sscal_(rank, &alpha, &d__[1], &c__1); + + } + + claset_("Full", lda, n, &c_b1, &c_b1, &a[a_offset], lda); + +/* 3) Generate Banded Matrix using Givens rotations. */ +/* Also the special case of UUB=LLB=0 */ + +/* Compute Addressing constants to cover all */ +/* storage formats. Whether GE, HE, SY, GB, HB, or SB, */ +/* upper or lower triangle or both, */ +/* the (i,j)-th element is in */ +/* A( i - ISKEW*j + IOFFST, j ) */ + + if (ipack > 4) { + ilda = *lda - 1; + iskew = 1; + if (ipack > 5) { + ioffst = uub + 1; + } else { + ioffst = 1; + } + } else { + ilda = *lda; + iskew = 0; + ioffst = 0; + } + +/* IPACKG is the format that the matrix is generated in. If this is */ +/* different from IPACK, then the matrix must be repacked at the */ +/* end. It also signals how to compute the norm, for scaling. */ + + ipackg = 0; + +/* Diagonal Matrix -- We are done, unless it */ +/* is to be stored HP/SP/PP/TP (PACK='R' or 'C') */ + + if (llb == 0 && uub == 0) { + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__2 = (1 - iskew) * j + ioffst + j * a_dim1; + i__3 = j; + q__1.r = d__[i__3], q__1.i = 0.f; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L120: */ + } + + if (ipack <= 2 || ipack >= 5) { + ipackg = ipack; + } + + } else if (givens) { + +/* Check whether to use Givens rotations, */ +/* Householder transformations, or nothing. */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + if (ipack > 4) { + ipackg = ipack; + } else { + ipackg = 0; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__2 = (1 - iskew) * j + ioffst + j * a_dim1; + i__3 = j; + q__1.r = d__[i__3], q__1.i = 0.f; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L130: */ + } + + if (topdwn) { + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* Last row actually rotated is M */ +/* Last column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__3 = *m + jku; + i__2 = f2cmin(i__3,*n) + jkl - 1; + for (jr = 1; jr <= i__2; ++jr) { + extra.r = 0.f, extra.i = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; +/* Computing MAX */ + i__3 = 1, i__4 = jr - jkl; + icol = f2cmax(i__3,i__4); + if (jr < *m) { +/* Computing MIN */ + i__3 = *n, i__4 = jr + jku; + il = f2cmin(i__3,i__4) + 1 - icol; + L__1 = jr > jkl; + clarot_(&c_true, &L__1, &c_false, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ir = jr; + ic = icol; + i__3 = -jkl - jku; + for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ir < *m) { + clartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &realc, + &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__2.r = realc * dummy.r, q__2.i = realc * + dummy.i; + r_cnjg(&q__1, &q__2); + c__.r = q__1.r, c__.i = q__1.i; + q__3.r = -s.r, q__3.i = -s.i; + q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, + q__2.i = q__3.r * dummy.i + q__3.i * + dummy.r; + r_cnjg(&q__1, &q__2); + s.r = q__1.r, s.i = q__1.i; + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + ctemp.r = 0.f, ctemp.i = 0.f; + iltemp = jch > jku; + clarot_(&c_false, &iltemp, &c_true, &il, &c__, &s, + &a[irow - iskew * ic + ioffst + ic * + a_dim1], &ilda, &ctemp, &extra); + if (iltemp) { + clartg_(&a[irow + 1 - iskew * (ic + 1) + + ioffst + (ic + 1) * a_dim1], &ctemp, & + realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__2.r = realc * dummy.r, q__2.i = realc * + dummy.i; + r_cnjg(&q__1, &q__2); + c__.r = q__1.r, c__.i = q__1.i; + q__3.r = -s.r, q__3.i = -s.i; + q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, + q__2.i = q__3.r * dummy.i + q__3.i * + dummy.r; + r_cnjg(&q__1, &q__2); + s.r = q__1.r, s.i = q__1.i; + +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + extra.r = 0.f, extra.i = 0.f; + L__1 = jch > jku + jkl; + clarot_(&c_true, &L__1, &c_true, &il, &c__, & + s, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, &ctemp) + ; + ic = icol; + ir = irow; + } +/* L140: */ + } +/* L150: */ + } +/* L160: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* Computing MIN */ + i__3 = *n + jkl; + i__2 = f2cmin(i__3,*m) + jku - 1; + for (jc = 1; jc <= i__2; ++jc) { + extra.r = 0.f, extra.i = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; +/* Computing MAX */ + i__3 = 1, i__4 = jc - jku; + irow = f2cmax(i__3,i__4); + if (jc < *n) { +/* Computing MIN */ + i__3 = *m, i__4 = jc + jkl; + il = f2cmin(i__3,i__4) + 1 - irow; + L__1 = jc > jku; + clarot_(&c_false, &L__1, &c_false, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ic = jc; + ir = irow; + i__3 = -jkl - jku; + for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ic < *n) { + clartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &realc, + &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__2.r = realc * dummy.r, q__2.i = realc * + dummy.i; + r_cnjg(&q__1, &q__2); + c__.r = q__1.r, c__.i = q__1.i; + q__3.r = -s.r, q__3.i = -s.i; + q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, + q__2.i = q__3.r * dummy.i + q__3.i * + dummy.r; + r_cnjg(&q__1, &q__2); + s.r = q__1.r, s.i = q__1.i; + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + ctemp.r = 0.f, ctemp.i = 0.f; + iltemp = jch > jkl; + clarot_(&c_true, &iltemp, &c_true, &il, &c__, &s, + &a[ir - iskew * icol + ioffst + icol * + a_dim1], &ilda, &ctemp, &extra); + if (iltemp) { + clartg_(&a[ir + 1 - iskew * (icol + 1) + + ioffst + (icol + 1) * a_dim1], &ctemp, + &realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__2.r = realc * dummy.r, q__2.i = realc * + dummy.i; + r_cnjg(&q__1, &q__2); + c__.r = q__1.r, c__.i = q__1.i; + q__3.r = -s.r, q__3.i = -s.i; + q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, + q__2.i = q__3.r * dummy.i + q__3.i * + dummy.r; + r_cnjg(&q__1, &q__2); + s.r = q__1.r, s.i = q__1.i; +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + extra.r = 0.f, extra.i = 0.f; + L__1 = jch > jkl + jku; + clarot_(&c_false, &L__1, &c_true, &il, &c__, & + s, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, &ctemp) + ; + ic = icol; + ir = irow; + } +/* L170: */ + } +/* L180: */ + } +/* L190: */ + } + + } else { + +/* Bottom-Up -- Start at the bottom right. */ + + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* First row actually rotated is M */ +/* First column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n + jkl; + iendch = f2cmin(i__2,i__3) - 1; +/* Computing MIN */ + i__2 = *m + jku; + i__3 = 1 - jkl; + for (jc = f2cmin(i__2,*n) - 1; jc >= i__3; --jc) { + extra.r = 0.f, extra.i = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; +/* Computing MAX */ + i__2 = 1, i__4 = jc - jku + 1; + irow = f2cmax(i__2,i__4); + if (jc > 0) { +/* Computing MIN */ + i__2 = *m, i__4 = jc + jkl + 1; + il = f2cmin(i__2,i__4) + 1 - irow; + L__1 = jc + jkl < *m; + clarot_(&c_false, &c_false, &L__1, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ic = jc; + i__2 = iendch; + i__4 = jkl + jku; + for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <= + i__2; jch += i__4) { + ilextr = ic > 0; + if (ilextr) { + clartg_(&a[jch - iskew * ic + ioffst + ic * + a_dim1], &extra, &realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__1.r = realc * dummy.r, q__1.i = realc * + dummy.i; + c__.r = q__1.r, c__.i = q__1.i; + q__1.r = s.r * dummy.r - s.i * dummy.i, + q__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = q__1.r, s.i = q__1.i; + } + ic = f2cmax(1,ic); +/* Computing MIN */ + i__5 = *n - 1, i__6 = jch + jku; + icol = f2cmin(i__5,i__6); + iltemp = jch + jku < *n; + ctemp.r = 0.f, ctemp.i = 0.f; + i__5 = icol + 2 - ic; + clarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, & + s, &a[jch - iskew * ic + ioffst + ic * + a_dim1], &ilda, &extra, &ctemp); + if (iltemp) { + clartg_(&a[jch - iskew * icol + ioffst + icol + * a_dim1], &ctemp, &realc, &s, &dummy) + ; + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__1.r = realc * dummy.r, q__1.i = realc * + dummy.i; + c__.r = q__1.r, c__.i = q__1.i; + q__1.r = s.r * dummy.r - s.i * dummy.i, + q__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = q__1.r, s.i = q__1.i; +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra.r = 0.f, extra.i = 0.f; + L__1 = jch + jkl + jku <= iendch; + clarot_(&c_false, &c_true, &L__1, &il, &c__, & + s, &a[jch - iskew * icol + ioffst + + icol * a_dim1], &ilda, &ctemp, &extra) + ; + ic = icol; + } +/* L200: */ + } +/* L210: */ + } +/* L220: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* First row actually rotated is MIN( N+JKL, M ) */ +/* First column actually rotated is N */ + +/* Computing MIN */ + i__3 = *n, i__4 = *m + jku; + iendch = f2cmin(i__3,i__4) - 1; +/* Computing MIN */ + i__3 = *n + jkl; + i__4 = 1 - jku; + for (jr = f2cmin(i__3,*m) - 1; jr >= i__4; --jr) { + extra.r = 0.f, extra.i = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; +/* Computing MAX */ + i__3 = 1, i__2 = jr - jkl + 1; + icol = f2cmax(i__3,i__2); + if (jr > 0) { +/* Computing MIN */ + i__3 = *n, i__2 = jr + jku + 1; + il = f2cmin(i__3,i__2) + 1 - icol; + L__1 = jr + jku < *n; + clarot_(&c_true, &c_false, &L__1, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ir = jr; + i__3 = iendch; + i__2 = jkl + jku; + for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <= + i__3; jch += i__2) { + ilextr = ir > 0; + if (ilextr) { + clartg_(&a[ir - iskew * jch + ioffst + jch * + a_dim1], &extra, &realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__1.r = realc * dummy.r, q__1.i = realc * + dummy.i; + c__.r = q__1.r, c__.i = q__1.i; + q__1.r = s.r * dummy.r - s.i * dummy.i, + q__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = q__1.r, s.i = q__1.i; + } + ir = f2cmax(1,ir); +/* Computing MIN */ + i__5 = *m - 1, i__6 = jch + jkl; + irow = f2cmin(i__5,i__6); + iltemp = jch + jkl < *m; + ctemp.r = 0.f, ctemp.i = 0.f; + i__5 = irow + 2 - ir; + clarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, & + s, &a[ir - iskew * jch + ioffst + jch * + a_dim1], &ilda, &extra, &ctemp); + if (iltemp) { + clartg_(&a[irow - iskew * jch + ioffst + jch * + a_dim1], &ctemp, &realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__1.r = realc * dummy.r, q__1.i = realc * + dummy.i; + c__.r = q__1.r, c__.i = q__1.i; + q__1.r = s.r * dummy.r - s.i * dummy.i, + q__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = q__1.r, s.i = q__1.i; +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra.r = 0.f, extra.i = 0.f; + L__1 = jch + jkl + jku <= iendch; + clarot_(&c_true, &c_true, &L__1, &il, &c__, & + s, &a[irow - iskew * jch + ioffst + + jch * a_dim1], &ilda, &ctemp, &extra); + ir = irow; + } +/* L230: */ + } +/* L240: */ + } +/* L250: */ + } + + } + + } else { + +/* Symmetric -- A = U D U' */ +/* Hermitian -- A = U D U* */ + + ipackg = ipack; + ioffg = ioffst; + + if (topdwn) { + +/* Top-Down -- Generate Upper triangle only */ + + if (ipack >= 5) { + ipackg = 6; + ioffg = uub + 1; + } else { + ipackg = 1; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__4 = (1 - iskew) * j + ioffg + j * a_dim1; + i__2 = j; + q__1.r = d__[i__2], q__1.i = 0.f; + a[i__4].r = q__1.r, a[i__4].i = q__1.i; +/* L260: */ + } + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + i__4 = *n - 1; + for (jc = 1; jc <= i__4; ++jc) { +/* Computing MAX */ + i__2 = 1, i__3 = jc - k; + irow = f2cmax(i__2,i__3); +/* Computing MIN */ + i__2 = jc + 1, i__3 = k + 2; + il = f2cmin(i__2,i__3); + extra.r = 0.f, extra.i = 0.f; + i__2 = jc - iskew * (jc + 1) + ioffg + (jc + 1) * + a_dim1; + ctemp.r = a[i__2].r, ctemp.i = a[i__2].i; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + r_cnjg(&q__1, &ctemp); + ctemp.r = q__1.r, ctemp.i = q__1.i; + r_cnjg(&q__1, &c__); + ct.r = q__1.r, ct.i = q__1.i; + r_cnjg(&q__1, &s); + st.r = q__1.r, st.i = q__1.i; + } + L__1 = jc > k; + clarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[ + irow - iskew * jc + ioffg + jc * a_dim1], & + ilda, &extra, &ctemp); +/* Computing MIN */ + i__3 = k, i__5 = *n - jc; + i__2 = f2cmin(i__3,i__5) + 1; + clarot_(&c_true, &c_true, &c_false, &i__2, &ct, &st, & + a[(1 - iskew) * jc + ioffg + jc * a_dim1], & + ilda, &ctemp, &dummy); + +/* Chase EXTRA back up the matrix */ + + icol = jc; + i__2 = -k; + for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1; + jch += i__2) { + clartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg + + (icol + 1) * a_dim1], &extra, &realc, &s, + &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__2.r = realc * dummy.r, q__2.i = realc * + dummy.i; + r_cnjg(&q__1, &q__2); + c__.r = q__1.r, c__.i = q__1.i; + q__3.r = -s.r, q__3.i = -s.i; + q__2.r = q__3.r * dummy.r - q__3.i * dummy.i, + q__2.i = q__3.r * dummy.i + q__3.i * + dummy.r; + r_cnjg(&q__1, &q__2); + s.r = q__1.r, s.i = q__1.i; + i__3 = jch - iskew * (jch + 1) + ioffg + (jch + 1) + * a_dim1; + ctemp.r = a[i__3].r, ctemp.i = a[i__3].i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + r_cnjg(&q__1, &ctemp); + ctemp.r = q__1.r, ctemp.i = q__1.i; + r_cnjg(&q__1, &c__); + ct.r = q__1.r, ct.i = q__1.i; + r_cnjg(&q__1, &s); + st.r = q__1.r, st.i = q__1.i; + } + i__3 = k + 2; + clarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &ctemp, &extra); +/* Computing MAX */ + i__3 = 1, i__5 = jch - k; + irow = f2cmax(i__3,i__5); +/* Computing MIN */ + i__3 = jch + 1, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra.r = 0.f, extra.i = 0.f; + L__1 = jch > k; + clarot_(&c_false, &L__1, &c_true, &il, &ct, &st, & + a[irow - iskew * jch + ioffg + jch * + a_dim1], &ilda, &extra, &ctemp); + icol = jch; +/* L270: */ + } +/* L280: */ + } +/* L290: */ + } + +/* If we need lower triangle, copy from upper. Note that */ +/* the order of copying is chosen to work for 'q' -> 'b' */ + + if (ipack != ipackg && ipack != 3) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst - iskew * jc; + if (csym) { +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + i__2 = jr + irow + jc * a_dim1; + i__3 = jc - iskew * jr + ioffg + jr * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; +/* L300: */ + } + } else { +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + i__2 = jr + irow + jc * a_dim1; + r_cnjg(&q__1, &a[jc - iskew * jr + ioffg + jr + * a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L310: */ + } + } +/* L320: */ + } + if (ipack == 5) { + i__1 = *n; + for (jc = *n - uub + 1; jc <= i__1; ++jc) { + i__4 = uub + 1; + for (jr = *n + 2 - jc; jr <= i__4; ++jr) { + i__2 = jr + jc * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L330: */ + } +/* L340: */ + } + } + if (ipackg == 6) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } else { + +/* Bottom-Up -- Generate Lower triangle only */ + + if (ipack >= 5) { + ipackg = 5; + if (ipack == 6) { + ioffg = 1; + } + } else { + ipackg = 2; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__4 = (1 - iskew) * j + ioffg + j * a_dim1; + i__2 = j; + q__1.r = d__[i__2], q__1.i = 0.f; + a[i__4].r = q__1.r, a[i__4].i = q__1.i; +/* L350: */ + } + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + for (jc = *n - 1; jc >= 1; --jc) { +/* Computing MIN */ + i__4 = *n + 1 - jc, i__2 = k + 2; + il = f2cmin(i__4,i__2); + extra.r = 0.f, extra.i = 0.f; + i__4 = (1 - iskew) * jc + 1 + ioffg + jc * a_dim1; + ctemp.r = a[i__4].r, ctemp.i = a[i__4].i; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + r__1 = cos(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + c__.r = q__1.r, c__.i = q__1.i; + r__1 = sin(angle); + //clarnd_(&q__2, &c__5, &iseed[1]); + q__2=clarnd_(&c__5, &iseed[1]); + q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i; + s.r = q__1.r, s.i = q__1.i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + r_cnjg(&q__1, &ctemp); + ctemp.r = q__1.r, ctemp.i = q__1.i; + r_cnjg(&q__1, &c__); + ct.r = q__1.r, ct.i = q__1.i; + r_cnjg(&q__1, &s); + st.r = q__1.r, st.i = q__1.i; + } + L__1 = *n - jc > k; + clarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[( + 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda, + &ctemp, &extra); +/* Computing MAX */ + i__4 = 1, i__2 = jc - k + 1; + icol = f2cmax(i__4,i__2); + i__4 = jc + 2 - icol; + clarot_(&c_true, &c_false, &c_true, &i__4, &ct, &st, & + a[jc - iskew * icol + ioffg + icol * a_dim1], + &ilda, &dummy, &ctemp); + +/* Chase EXTRA back down the matrix */ + + icol = jc; + i__4 = *n - 1; + i__2 = k; + for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <= + i__4; jch += i__2) { + clartg_(&a[jch - iskew * icol + ioffg + icol * + a_dim1], &extra, &realc, &s, &dummy); + //clarnd_(&q__1, &c__5, &iseed[1]); + q__1=clarnd_(&c__5, &iseed[1]); + dummy.r = q__1.r, dummy.i = q__1.i; + q__1.r = realc * dummy.r, q__1.i = realc * + dummy.i; + c__.r = q__1.r, c__.i = q__1.i; + q__1.r = s.r * dummy.r - s.i * dummy.i, q__1.i = + s.r * dummy.i + s.i * dummy.r; + s.r = q__1.r, s.i = q__1.i; + i__3 = (1 - iskew) * jch + 1 + ioffg + jch * + a_dim1; + ctemp.r = a[i__3].r, ctemp.i = a[i__3].i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + r_cnjg(&q__1, &ctemp); + ctemp.r = q__1.r, ctemp.i = q__1.i; + r_cnjg(&q__1, &c__); + ct.r = q__1.r, ct.i = q__1.i; + r_cnjg(&q__1, &s); + st.r = q__1.r, st.i = q__1.i; + } + i__3 = k + 2; + clarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[jch - iskew * icol + ioffg + icol * + a_dim1], &ilda, &extra, &ctemp); +/* Computing MIN */ + i__3 = *n + 1 - jch, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra.r = 0.f, extra.i = 0.f; + L__1 = *n - jch > k; + clarot_(&c_false, &c_true, &L__1, &il, &ct, &st, & + a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &ctemp, &extra); + icol = jch; +/* L360: */ + } +/* L370: */ + } +/* L380: */ + } + +/* If we need upper triangle, copy from lower. Note that */ +/* the order of copying is chosen to work for 'b' -> 'q' */ + + if (ipack != ipackg && ipack != 4) { + for (jc = *n; jc >= 1; --jc) { + irow = ioffst - iskew * jc; + if (csym) { +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + i__2 = jr + irow + jc * a_dim1; + i__4 = jc - iskew * jr + ioffg + jr * a_dim1; + a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i; +/* L390: */ + } + } else { +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + i__2 = jr + irow + jc * a_dim1; + r_cnjg(&q__1, &a[jc - iskew * jr + ioffg + jr + * a_dim1]); + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L400: */ + } + } +/* L410: */ + } + if (ipack == 6) { + i__1 = uub; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L420: */ + } +/* L430: */ + } + } + if (ipackg == 5) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } + +/* Ensure that the diagonal is real if Hermitian */ + + if (! csym) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst + (1 - iskew) * jc; + i__2 = irow + jc * a_dim1; + i__4 = irow + jc * a_dim1; + r__1 = a[i__4].r; + q__1.r = r__1, q__1.i = 0.f; + a[i__2].r = q__1.r, a[i__2].i = q__1.i; +/* L440: */ + } + } + + } + + } else { + +/* 4) Generate Banded Matrix by first */ +/* Rotating by random Unitary matrices, */ +/* then reducing the bandwidth using Householder */ +/* transformations. */ + +/* Note: we should get here only if LDA .ge. N */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + clagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[ + 1], &work[1], &iinfo); + } else { + +/* Symmetric -- A = U D U' or */ +/* Hermitian -- A = U D U* */ + + if (csym) { + clagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[ + 1], &iinfo); + } else { + claghe_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[ + 1], &iinfo); + } + } + + if (iinfo != 0) { + *info = 3; + return 0; + } + } + +/* 5) Pack the matrix */ + + if (ipack != ipackg) { + if (ipack == 1) { + +/* 'U' -- Upper triangular, not packed */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__4 = i__ + j * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L450: */ + } +/* L460: */ + } + + } else if (ipack == 2) { + +/* 'L' -- Lower triangular, not packed */ + + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__4 = i__ + j * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L470: */ + } +/* L480: */ + } + + } else if (ipack == 3) { + +/* 'C' -- Upper triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + i__4 = irow + icol * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L490: */ + } +/* L500: */ + } + + } else if (ipack == 4) { + +/* 'R' -- Lower triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + i__4 = irow + icol * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L510: */ + } +/* L520: */ + } + + } else if (ipack >= 5) { + +/* 'B' -- The lower triangle is packed as a band matrix. */ +/* 'Q' -- The upper triangle is packed as a band matrix. */ +/* 'Z' -- The whole matrix is packed as a band matrix. */ + + if (ipack == 5) { + uub = 0; + } + if (ipack == 6) { + llb = 0; + } + + i__1 = uub; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = j + llb; + for (i__ = f2cmin(i__2,*m); i__ >= 1; --i__) { + i__2 = i__ - j + uub + 1 + j * a_dim1; + i__4 = i__ + j * a_dim1; + a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i; +/* L530: */ + } +/* L540: */ + } + + i__1 = *n; + for (j = uub + 2; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = j + llb; + i__2 = f2cmin(i__4,*m); + for (i__ = j - uub; i__ <= i__2; ++i__) { + i__4 = i__ - j + uub + 1 + j * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L550: */ + } +/* L560: */ + } + } + +/* If packed, zero out extraneous elements. */ + +/* Symmetric/Triangular Packed -- */ +/* zero out everything after A(IROW,ICOL) */ + + if (ipack == 3 || ipack == 4) { + i__1 = *m; + for (jc = icol; jc <= i__1; ++jc) { + i__2 = *lda; + for (jr = irow + 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L570: */ + } + irow = 0; +/* L580: */ + } + + } else if (ipack >= 5) { + +/* Packed Band -- */ +/* 1st row is now in A( UUB+2-j, j), zero above it */ +/* m-th row is now in A( M+UUB-j,j), zero below it */ +/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */ +/* zero below it, too. */ + + ir1 = uub + llb + 2; + ir2 = uub + *m + 2; + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0.f, a[i__4].i = 0.f; +/* L590: */ + } +/* Computing MAX */ +/* Computing MIN */ + i__3 = ir1, i__5 = ir2 - jc; + i__2 = 1, i__4 = f2cmin(i__3,i__5); + i__6 = *lda; + for (jr = f2cmax(i__2,i__4); jr <= i__6; ++jr) { + i__2 = jr + jc * a_dim1; + a[i__2].r = 0.f, a[i__2].i = 0.f; +/* L600: */ + } +/* L610: */ + } + } + } + + return 0; + +/* End of CLATMT */ + +} /* clatmt_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlagge.c b/lapack-netlib/TESTING/MATGEN/dlagge.c new file mode 100644 index 000000000..03e6a1658 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlagge.c @@ -0,0 +1,847 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAGGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, KL, KU, LDA, M, N */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAGGE generates a real general m by n matrix A, by pre- and post- */ +/* > multiplying a real diagonal matrix D with random orthogonal matrices: */ +/* > A = U*D*V. The lower and upper bandwidths may then be reduced to */ +/* > kl and ku by additional orthogonal transformations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of nonzero subdiagonals within the band of A. */ +/* > 0 <= KL <= M-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of nonzero superdiagonals within the band of A. */ +/* > 0 <= KU <= N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */ +/* > The diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The generated m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (M+N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlagge_(integer *m, integer *n, integer *kl, integer *ku, + doublereal *d__, doublereal *a, integer *lda, integer *iseed, + doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + extern doublereal dnrm2_(integer *, doublereal *, integer *); + integer i__, j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemv_(char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *); + doublereal wa, wb, wn; + extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_( + integer *, integer *, integer *, doublereal *); + doublereal tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0 || *kl > *m - 1) { + *info = -3; + } else if (*ku < 0 || *ku > *n - 1) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -7; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("DLAGGE", &i__1); + return 0; + } + +/* initialize A to diagonal matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + i__1 = f2cmin(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + i__ * a_dim1] = d__[i__]; +/* L30: */ + } + +/* Quick exit if the user wants a diagonal matrix */ + + if (*kl == 0 && *ku == 0) { + return 0; + } + +/* pre- and post-multiply A by random orthogonal matrices */ + + for (i__ = f2cmin(*m,*n); i__ >= 1; --i__) { + if (i__ < *m) { + +/* generate random reflection */ + + i__1 = *m - i__ + 1; + dlarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *m - i__ + 1; + wn = dnrm2_(&i__1, &work[1], &c__1); + wa = d_sign(&wn, &work[1]); + if (wn == 0.) { + tau = 0.; + } else { + wb = work[1] + wa; + i__1 = *m - i__; + d__1 = 1. / wb; + dscal_(&i__1, &d__1, &work[2], &c__1); + work[1] = 1.; + tau = wb / wa; + } + +/* multiply A(i:m,i:n) by random reflection from the left */ + + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + dgemv_("Transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * a_dim1], + lda, &work[1], &c__1, &c_b13, &work[*m + 1], &c__1); + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + d__1 = -tau; + dger_(&i__1, &i__2, &d__1, &work[1], &c__1, &work[*m + 1], &c__1, + &a[i__ + i__ * a_dim1], lda); + } + if (i__ < *n) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + dlarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = dnrm2_(&i__1, &work[1], &c__1); + wa = d_sign(&wn, &work[1]); + if (wn == 0.) { + tau = 0.; + } else { + wb = work[1] + wa; + i__1 = *n - i__; + d__1 = 1. / wb; + dscal_(&i__1, &d__1, &work[2], &c__1); + work[1] = 1.; + tau = wb / wa; + } + +/* multiply A(i:m,i:n) by random reflection from the right */ + + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + dgemv_("No transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * + a_dim1], lda, &work[1], &c__1, &c_b13, &work[*n + 1], & + c__1); + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + d__1 = -tau; + dger_(&i__1, &i__2, &d__1, &work[*n + 1], &c__1, &work[1], &c__1, + &a[i__ + i__ * a_dim1], lda); + } +/* L40: */ + } + +/* Reduce number of subdiagonals to KL and number of superdiagonals */ +/* to KU */ + +/* Computing MAX */ + i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku; + i__1 = f2cmax(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + if (*kl <= *ku) { + +/* annihilate subdiagonal elements first (necessary if KL = 0) */ + +/* Computing MIN */ + i__2 = *m - 1 - *kl; + if (i__ <= f2cmin(i__2,*n)) { + +/* generate reflection to annihilate A(kl+i+1:m,i) */ + + i__2 = *m - *kl - i__ + 1; + wn = dnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1); + wa = d_sign(&wn, &a[*kl + i__ + i__ * a_dim1]); + if (wn == 0.) { + tau = 0.; + } else { + wb = a[*kl + i__ + i__ * a_dim1] + wa; + i__2 = *m - *kl - i__; + d__1 = 1. / wb; + dscal_(&i__2, &d__1, &a[*kl + i__ + 1 + i__ * a_dim1], & + c__1); + a[*kl + i__ + i__ * a_dim1] = 1.; + tau = wb / wa; + } + +/* apply reflection to A(kl+i:m,i+1:n) from the left */ + + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + dgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__ + + 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], & + c__1, &c_b13, &work[1], &c__1); + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + d__1 = -tau; + dger_(&i__2, &i__3, &d__1, &a[*kl + i__ + i__ * a_dim1], & + c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * + a_dim1], lda); + a[*kl + i__ + i__ * a_dim1] = -wa; + } + +/* Computing MIN */ + i__2 = *n - 1 - *ku; + if (i__ <= f2cmin(i__2,*m)) { + +/* generate reflection to annihilate A(i,ku+i+1:n) */ + + i__2 = *n - *ku - i__ + 1; + wn = dnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + wa = d_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]); + if (wn == 0.) { + tau = 0.; + } else { + wb = a[i__ + (*ku + i__) * a_dim1] + wa; + i__2 = *n - *ku - i__; + d__1 = 1. / wb; + dscal_(&i__2, &d__1, &a[i__ + (*ku + i__ + 1) * a_dim1], + lda); + a[i__ + (*ku + i__) * a_dim1] = 1.; + tau = wb / wa; + } + +/* apply reflection to A(i+1:m,ku+i:n) from the right */ + + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + dgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (* + ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * + a_dim1], lda, &c_b13, &work[1], &c__1); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + d__1 = -tau; + dger_(&i__2, &i__3, &d__1, &work[1], &c__1, &a[i__ + (*ku + + i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * + a_dim1], lda); + a[i__ + (*ku + i__) * a_dim1] = -wa; + } + } else { + +/* annihilate superdiagonal elements first (necessary if */ +/* KU = 0) */ + +/* Computing MIN */ + i__2 = *n - 1 - *ku; + if (i__ <= f2cmin(i__2,*m)) { + +/* generate reflection to annihilate A(i,ku+i+1:n) */ + + i__2 = *n - *ku - i__ + 1; + wn = dnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + wa = d_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]); + if (wn == 0.) { + tau = 0.; + } else { + wb = a[i__ + (*ku + i__) * a_dim1] + wa; + i__2 = *n - *ku - i__; + d__1 = 1. / wb; + dscal_(&i__2, &d__1, &a[i__ + (*ku + i__ + 1) * a_dim1], + lda); + a[i__ + (*ku + i__) * a_dim1] = 1.; + tau = wb / wa; + } + +/* apply reflection to A(i+1:m,ku+i:n) from the right */ + + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + dgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (* + ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * + a_dim1], lda, &c_b13, &work[1], &c__1); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + d__1 = -tau; + dger_(&i__2, &i__3, &d__1, &work[1], &c__1, &a[i__ + (*ku + + i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * + a_dim1], lda); + a[i__ + (*ku + i__) * a_dim1] = -wa; + } + +/* Computing MIN */ + i__2 = *m - 1 - *kl; + if (i__ <= f2cmin(i__2,*n)) { + +/* generate reflection to annihilate A(kl+i+1:m,i) */ + + i__2 = *m - *kl - i__ + 1; + wn = dnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1); + wa = d_sign(&wn, &a[*kl + i__ + i__ * a_dim1]); + if (wn == 0.) { + tau = 0.; + } else { + wb = a[*kl + i__ + i__ * a_dim1] + wa; + i__2 = *m - *kl - i__; + d__1 = 1. / wb; + dscal_(&i__2, &d__1, &a[*kl + i__ + 1 + i__ * a_dim1], & + c__1); + a[*kl + i__ + i__ * a_dim1] = 1.; + tau = wb / wa; + } + +/* apply reflection to A(kl+i:m,i+1:n) from the left */ + + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + dgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__ + + 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], & + c__1, &c_b13, &work[1], &c__1); + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + d__1 = -tau; + dger_(&i__2, &i__3, &d__1, &a[*kl + i__ + i__ * a_dim1], & + c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * + a_dim1], lda); + a[*kl + i__ + i__ * a_dim1] = -wa; + } + } + + if (i__ <= *n) { + i__2 = *m; + for (j = *kl + i__ + 1; j <= i__2; ++j) { + a[j + i__ * a_dim1] = 0.; +/* L50: */ + } + } + + if (i__ <= *m) { + i__2 = *n; + for (j = *ku + i__ + 1; j <= i__2; ++j) { + a[i__ + j * a_dim1] = 0.; +/* L60: */ + } + } +/* L70: */ + } + return 0; + +/* End of DLAGGE */ + +} /* dlagge_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlagsy.c b/lapack-netlib/TESTING/MATGEN/dlagsy.c new file mode 100644 index 000000000..2a1b30afe --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlagsy.c @@ -0,0 +1,706 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAGSY */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, K, LDA, N */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAGSY generates a real symmetric matrix A, by pre- and post- */ +/* > multiplying a real diagonal matrix D with a random orthogonal matrix: */ +/* > A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */ +/* > orthogonal transformations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of nonzero subdiagonals within the band of A. */ +/* > 0 <= K <= N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The generated n by n symmetric matrix A (the full matrix is */ +/* > stored). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlagsy_(integer *n, integer *k, doublereal *d__, + doublereal *a, integer *lda, integer *iseed, doublereal *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *), dnrm2_(integer *, doublereal *, integer *); + extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer i__, j; + doublereal alpha; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemv_(char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), daxpy_(integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *), dsymv_(char *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + doublereal wa, wb, wn; + extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_( + integer *, integer *, integer *, doublereal *); + doublereal tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*k < 0 || *k > *n - 1) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("DLAGSY", &i__1); + return 0; + } + +/* initialize lower triangle of A to diagonal matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + i__ * a_dim1] = d__[i__]; +/* L30: */ + } + +/* Generate lower triangle of symmetric matrix */ + + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + dlarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = dnrm2_(&i__1, &work[1], &c__1); + wa = d_sign(&wn, &work[1]); + if (wn == 0.) { + tau = 0.; + } else { + wb = work[1] + wa; + i__1 = *n - i__; + d__1 = 1. / wb; + dscal_(&i__1, &d__1, &work[2], &c__1); + work[1] = 1.; + tau = wb / wa; + } + +/* apply random reflection to A(i:n,i:n) from the left */ +/* and the right */ + +/* compute y := tau * A * u */ + + i__1 = *n - i__ + 1; + dsymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], & + c__1, &c_b12, &work[*n + 1], &c__1); + +/* compute v := y - 1/2 * tau * ( y, u ) * u */ + + i__1 = *n - i__ + 1; + alpha = tau * -.5 * ddot_(&i__1, &work[*n + 1], &c__1, &work[1], & + c__1); + i__1 = *n - i__ + 1; + daxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1); + +/* apply the transformation as a rank-2 update to A(i:n,i:n) */ + + i__1 = *n - i__ + 1; + dsyr2_("Lower", &i__1, &c_b19, &work[1], &c__1, &work[*n + 1], &c__1, + &a[i__ + i__ * a_dim1], lda); +/* L40: */ + } + +/* Reduce number of subdiagonals to K */ + + i__1 = *n - 1 - *k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* generate reflection to annihilate A(k+i+1:n,i) */ + + i__2 = *n - *k - i__ + 1; + wn = dnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); + wa = d_sign(&wn, &a[*k + i__ + i__ * a_dim1]); + if (wn == 0.) { + tau = 0.; + } else { + wb = a[*k + i__ + i__ * a_dim1] + wa; + i__2 = *n - *k - i__; + d__1 = 1. / wb; + dscal_(&i__2, &d__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1); + a[*k + i__ + i__ * a_dim1] = 1.; + tau = wb / wa; + } + +/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */ + + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + dgemv_("Transpose", &i__2, &i__3, &c_b26, &a[*k + i__ + (i__ + 1) * + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, & + work[1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + d__1 = -tau; + dger_(&i__2, &i__3, &d__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[ + 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda); + +/* apply reflection to A(k+i:n,k+i:n) from the left and the right */ + +/* compute y := tau * A * u */ + + i__2 = *n - *k - i__ + 1; + dsymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, + &a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, &work[1], &c__1); + +/* compute v := y - 1/2 * tau * ( y, u ) * u */ + + i__2 = *n - *k - i__ + 1; + alpha = tau * -.5 * ddot_(&i__2, &work[1], &c__1, &a[*k + i__ + i__ * + a_dim1], &c__1); + i__2 = *n - *k - i__ + 1; + daxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & + c__1); + +/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */ + + i__2 = *n - *k - i__ + 1; + dsyr2_("Lower", &i__2, &c_b19, &a[*k + i__ + i__ * a_dim1], &c__1, & + work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda); + + a[*k + i__ + i__ * a_dim1] = -wa; + i__2 = *n; + for (j = *k + i__ + 1; j <= i__2; ++j) { + a[j + i__ * a_dim1] = 0.; +/* L50: */ + } +/* L60: */ + } + +/* Store full symmetric matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = a[i__ + j * a_dim1]; +/* L70: */ + } +/* L80: */ + } + return 0; + +/* End of DLAGSY */ + +} /* dlagsy_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlahilb.c b/lapack-netlib/TESTING/MATGEN/dlahilb.c new file mode 100644 index 000000000..af8c87bfd --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlahilb.c @@ -0,0 +1,626 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAHILB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) */ + +/* INTEGER N, NRHS, LDA, LDX, LDB, INFO */ +/* DOUBLE PRECISION A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAHILB generates an N by N scaled Hilbert matrix in A along with */ +/* > NRHS right-hand sides in B and solutions in X such that A*X=B. */ +/* > */ +/* > The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */ +/* > entries are integers. The right-hand sides are the first NRHS */ +/* > columns of M * the identity matrix, and the solutions are the */ +/* > first NRHS columns of the inverse Hilbert matrix. */ +/* > */ +/* > The condition number of the Hilbert matrix grows exponentially with */ +/* > its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */ +/* > Hilbert matrices beyond a relatively small dimension cannot be */ +/* > generated exactly without extra precision. Precision is exhausted */ +/* > when the largest entry in the inverse Hilbert matrix is greater than */ +/* > 2 to the power of the number of bits in the fraction of the data type */ +/* > used plus one, which is 24 for single precision. */ +/* > */ +/* > In single, the generated solution is exact for N <= 6 and has */ +/* > small componentwise error for 7 <= N <= 11. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The requested number of right-hand sides. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > The generated scaled Hilbert matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX, NRHS) */ +/* > The generated exact solutions. Currently, the first NRHS */ +/* > columns of the inverse Hilbert matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, NRHS) */ +/* > The generated right-hand sides. Currently, the first NRHS */ +/* > columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > = 1: N is too large; the data is still generated but may not */ +/* > be not exact. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlahilb_(integer *n, integer *nrhs, doublereal *a, + integer *lda, doublereal *x, integer *ldx, doublereal *b, integer * + ldb, doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + integer i__, j, m, r__, ti, tm; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *); + + +/* -- LAPACK test routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ +/* NMAX_EXACT the largest dimension where the generated data is */ +/* exact. */ +/* NMAX_APPROX the largest dimension where the generated data has */ +/* a small componentwise relative error. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + --work; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0 || *n > 11) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*lda < *n) { + *info = -4; + } else if (*ldx < *n) { + *info = -6; + } else if (*ldb < *n) { + *info = -8; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("DLAHILB", &i__1); + return 0; + } + if (*n > 6) { + *info = 1; + } + +/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */ +/* reasonable N is small enough that integers suffice (up to N = 11). */ + m = 1; + i__1 = (*n << 1) - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + tm = m; + ti = i__; + r__ = tm % ti; + while(r__ != 0) { + tm = ti; + ti = r__; + r__ = tm % ti; + } + m = m / ti * i__; + } + +/* Generate the scaled Hilbert matrix in A */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = (doublereal) m / (i__ + j - 1); + } + } + +/* Generate matrix B as simply the first NRHS columns of M * the */ +/* identity. */ + d__1 = (doublereal) m; + dlaset_("Full", n, nrhs, &c_b4, &d__1, &b[b_offset], ldb); +/* Generate the true solutions in X. Because B = the first NRHS */ +/* columns of M*I, the true solutions are just the first NRHS columns */ +/* of the inverse Hilbert matrix. */ + work[1] = (doublereal) (*n); + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j - + 1); + } + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] = work[i__] * work[j] / (i__ + j - 1); + } + } + + return 0; +} /* dlahilb_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlakf2.c b/lapack-netlib/TESTING/MATGEN/dlakf2.c new file mode 100644 index 000000000..b4edc7166 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlakf2.c @@ -0,0 +1,615 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAKF2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) */ + +/* INTEGER LDA, LDZ, M, N */ +/* DOUBLE PRECISION A( LDA, * ), B( LDA, * ), D( LDA, * ), */ +/* $ E( LDA, * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Form the 2*M*N by 2*M*N matrix */ +/* > */ +/* > Z = [ kron(In, A) -kron(B', Im) ] */ +/* > [ kron(In, D) -kron(E', Im) ], */ +/* > */ +/* > where In is the identity matrix of size n and X' is the transpose */ +/* > of X. kron(X, Y) is the Kronecker product between the matrices X */ +/* > and Y. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Size of matrix, must be >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Size of matrix, must be >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION, dimension ( LDA, M ) */ +/* > The matrix A in the output matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A, B, D, and E. ( LDA >= M+N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION, dimension ( LDA, N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION, dimension ( LDA, M ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION, dimension ( LDA, N ) */ +/* > */ +/* > The matrices used in forming the output matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION, dimension ( LDZ, 2*M*N ) */ +/* > The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of Z. ( LDZ >= 2*M*N ) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlakf2_(integer *m, integer *n, doublereal *a, integer * + lda, doublereal *b, doublereal *d__, doublereal *e, doublereal *z__, + integer *ldz) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1, + e_offset, z_dim1, z_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, l, ik, jk, mn; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *); + integer mn2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ==================================================================== */ + + +/* Initialize Z */ + + /* Parameter adjustments */ + e_dim1 = *lda; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + d_dim1 = *lda; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + b_dim1 = *lda; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + + /* Function Body */ + mn = *m * *n; + mn2 = mn << 1; + dlaset_("Full", &mn2, &mn2, &c_b3, &c_b3, &z__[z_offset], ldz); + + ik = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + +/* form kron(In, A) */ + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m; + for (j = 1; j <= i__3; ++j) { + z__[ik + i__ - 1 + (ik + j - 1) * z_dim1] = a[i__ + j * + a_dim1]; +/* L10: */ + } +/* L20: */ + } + +/* form kron(In, D) */ + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m; + for (j = 1; j <= i__3; ++j) { + z__[ik + mn + i__ - 1 + (ik + j - 1) * z_dim1] = d__[i__ + j * + d_dim1]; +/* L30: */ + } +/* L40: */ + } + + ik += *m; +/* L50: */ + } + + ik = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + jk = mn + 1; + + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + +/* form -kron(B', Im) */ + + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + z__[ik + i__ - 1 + (jk + i__ - 1) * z_dim1] = -b[j + l * + b_dim1]; +/* L60: */ + } + +/* form -kron(E', Im) */ + + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + z__[ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1] = -e[j + l * + e_dim1]; +/* L70: */ + } + + jk += *m; +/* L80: */ + } + + ik += *m; +/* L90: */ + } + + return 0; + +/* End of DLAKF2 */ + +} /* dlakf2_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlaran.c b/lapack-netlib/TESTING/MATGEN/dlaran.c new file mode 100644 index 000000000..0b3b6ce8e --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlaran.c @@ -0,0 +1,526 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLARAN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLARAN( ISEED ) */ + +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLARAN returns a random real number from a uniform (0,1) */ +/* > distribution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup list_temp */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine uses a multiplicative congruential method with modulus */ +/* > 2**48 and multiplier 33952834046453 (see G.S.Fishman, */ +/* > 'Multiplicative congruential random number generators with modulus */ +/* > 2**b: an exhaustive analysis for b = 32 and a partial analysis for */ +/* > b = 48', Math. Comp. 189, pp 331-344, 1990). */ +/* > */ +/* > 48-bit integers are stored in 4 integer array elements with 12 bits */ +/* > per element. Hence the routine is portable across machines with */ +/* > integers of 32 bits or more. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +doublereal dlaran_(integer *iseed) +{ + /* System generated locals */ + doublereal ret_val; + + /* Local variables */ + doublereal rndout; + integer it1, it2, it3, it4; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + /* Parameter adjustments */ + --iseed; + + /* Function Body */ +L10: + +/* multiply the seed by the multiplier modulo 2**48 */ + + it4 = iseed[4] * 2549; + it3 = it4 / 4096; + it4 -= it3 << 12; + it3 = it3 + iseed[3] * 2549 + iseed[4] * 2508; + it2 = it3 / 4096; + it3 -= it2 << 12; + it2 = it2 + iseed[2] * 2549 + iseed[3] * 2508 + iseed[4] * 322; + it1 = it2 / 4096; + it2 -= it1 << 12; + it1 = it1 + iseed[1] * 2549 + iseed[2] * 2508 + iseed[3] * 322 + iseed[4] + * 494; + it1 %= 4096; + +/* return updated seed */ + + iseed[1] = it1; + iseed[2] = it2; + iseed[3] = it3; + iseed[4] = it4; + +/* convert 48-bit integer to a real number in the interval (0,1) */ + + rndout = ((doublereal) it1 + ((doublereal) it2 + ((doublereal) it3 + ( + doublereal) it4 * 2.44140625e-4) * 2.44140625e-4) * 2.44140625e-4) + * 2.44140625e-4; + + if (rndout == 1.) { +/* If a real number has n bits of precision, and the first */ +/* n bits of the 48-bit integer above happen to be all 1 (which */ +/* will occur about once every 2**n calls), then DLARAN will */ +/* be rounded to exactly 1.0. */ +/* Since DLARAN is not supposed to return exactly 0.0 or 1.0 */ +/* (and some callers of DLARAN, such as CLARND, depend on that), */ +/* the statistically correct thing to do in this situation is */ +/* simply to iterate again. */ +/* N.B. the case DLARAN = 0.0 should not be possible. */ + + goto L10; + } + + ret_val = rndout; + return ret_val; + +/* End of DLARAN */ + +} /* dlaran_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlarge.c b/lapack-netlib/TESTING/MATGEN/dlarge.c new file mode 100644 index 000000000..5e2f342fc --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlarge.c @@ -0,0 +1,581 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLARGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLARGE( N, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, LDA, N */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLARGE pre- and post-multiplies a real general n by n matrix A */ +/* > with a random orthogonal matrix: A = U*D*U'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the original n by n matrix A. */ +/* > On exit, A is overwritten by U*A*U' for some random */ +/* > orthogonal matrix U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlarge_(integer *n, doublereal *a, integer *lda, integer + *iseed, doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + extern doublereal dnrm2_(integer *, doublereal *, integer *); + integer i__; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemv_(char *, integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *); + doublereal wa, wb, wn; + extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_( + integer *, integer *, integer *, doublereal *); + doublereal tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*lda < f2cmax(1,*n)) { + *info = -3; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("DLARGE", &i__1); + return 0; + } + +/* pre- and post-multiply A by random orthogonal matrix */ + + for (i__ = *n; i__ >= 1; --i__) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + dlarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = dnrm2_(&i__1, &work[1], &c__1); + wa = d_sign(&wn, &work[1]); + if (wn == 0.) { + tau = 0.; + } else { + wb = work[1] + wa; + i__1 = *n - i__; + d__1 = 1. / wb; + dscal_(&i__1, &d__1, &work[2], &c__1); + work[1] = 1.; + tau = wb / wa; + } + +/* multiply A(i:n,1:n) by random reflection from the left */ + + i__1 = *n - i__ + 1; + dgemv_("Transpose", &i__1, n, &c_b8, &a[i__ + a_dim1], lda, &work[1], + &c__1, &c_b10, &work[*n + 1], &c__1); + i__1 = *n - i__ + 1; + d__1 = -tau; + dger_(&i__1, n, &d__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__ + + a_dim1], lda); + +/* multiply A(1:n,i:n) by random reflection from the right */ + + i__1 = *n - i__ + 1; + dgemv_("No transpose", n, &i__1, &c_b8, &a[i__ * a_dim1 + 1], lda, & + work[1], &c__1, &c_b10, &work[*n + 1], &c__1); + i__1 = *n - i__ + 1; + d__1 = -tau; + dger_(n, &i__1, &d__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ * + a_dim1 + 1], lda); +/* L10: */ + } + return 0; + +/* End of DLARGE */ + +} /* dlarge_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlarnd.c b/lapack-netlib/TESTING/MATGEN/dlarnd.c new file mode 100644 index 000000000..9f4ea9dee --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlarnd.c @@ -0,0 +1,508 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLARND */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED ) */ + +/* INTEGER IDIST */ +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLARND returns a random real number from a uniform or normal */ +/* > distribution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > Specifies the distribution of the random numbers: */ +/* > = 1: uniform (0,1) */ +/* > = 2: uniform (-1,1) */ +/* > = 3: normal (0,1) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine calls the auxiliary routine DLARAN to generate a random */ +/* > real number from a uniform (0,1) distribution. The Box-Muller method */ +/* > is used to transform numbers from a uniform to a normal distribution. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +doublereal dlarnd_(integer *idist, integer *iseed) +{ + /* System generated locals */ + doublereal ret_val; + + /* Local variables */ + doublereal t1, t2; + extern doublereal dlaran_(integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Generate a real random number from a uniform (0,1) distribution */ + + /* Parameter adjustments */ + --iseed; + + /* Function Body */ + t1 = dlaran_(&iseed[1]); + + if (*idist == 1) { + +/* uniform (0,1) */ + + ret_val = t1; + } else if (*idist == 2) { + +/* uniform (-1,1) */ + + ret_val = t1 * 2. - 1.; + } else if (*idist == 3) { + +/* normal (0,1) */ + + t2 = dlaran_(&iseed[1]); + ret_val = sqrt(log(t1) * -2.) * cos(t2 * + 6.2831853071795864769252867663); + } + return ret_val; + +/* End of DLARND */ + +} /* dlarnd_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlaror.c b/lapack-netlib/TESTING/MATGEN/dlaror.c new file mode 100644 index 000000000..e68d51f41 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlaror.c @@ -0,0 +1,721 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAROR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) */ + +/* CHARACTER INIT, SIDE */ +/* INTEGER INFO, LDA, M, N */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION A( LDA, * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAROR pre- or post-multiplies an M by N matrix A by a random */ +/* > orthogonal matrix U, overwriting A. A may optionally be initialized */ +/* > to the identity matrix before multiplying by U. U is generated using */ +/* > the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > Specifies whether A is multiplied on the left or right by U. */ +/* > = 'L': Multiply A on the left (premultiply) by U */ +/* > = 'R': Multiply A on the right (postmultiply) by U' */ +/* > = 'C' or 'T': Multiply A on the left by U and the right */ +/* > by U' (Here, U' means U-transpose.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INIT */ +/* > \verbatim */ +/* > INIT is CHARACTER*1 */ +/* > Specifies whether or not A should be initialized to the */ +/* > identity matrix. */ +/* > = 'I': Initialize A to (a section of) the identity matrix */ +/* > before applying U. */ +/* > = 'N': No initialization. Apply U to the input matrix A. */ +/* > */ +/* > INIT = 'I' may be used to generate square or rectangular */ +/* > orthogonal matrices: */ +/* > */ +/* > For M = N and SIDE = 'L' or 'R', the rows will be orthogonal */ +/* > to each other, as will the columns. */ +/* > */ +/* > If M < N, SIDE = 'R' produces a dense matrix whose rows are */ +/* > orthogonal and whose columns are not, while SIDE = 'L' */ +/* > produces a matrix whose rows are orthogonal, and whose first */ +/* > M columns are orthogonal, and whose remaining columns are */ +/* > zero. */ +/* > */ +/* > If M > N, SIDE = 'L' produces a dense matrix whose columns */ +/* > are orthogonal and whose rows are not, while SIDE = 'R' */ +/* > produces a matrix whose columns are orthogonal, and whose */ +/* > first M rows are orthogonal, and whose remaining rows are */ +/* > zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N) */ +/* > On entry, the array A. */ +/* > On exit, overwritten by U A ( if SIDE = 'L' ), */ +/* > or by A U ( if SIDE = 'R' ), */ +/* > or by U A U' ( if SIDE = 'C' or 'T'). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. The array elements should be between 0 and 4095; */ +/* > if not they will be reduced mod 4096. Also, ISEED(4) must */ +/* > be odd. The random number generator uses a linear */ +/* > congruential sequence limited to small integers, and so */ +/* > should produce machine independent random numbers. The */ +/* > values of ISEED are changed on exit, and can be used in the */ +/* > next call to DLAROR to continue the same random number */ +/* > sequence. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (3*MAX( M, N )) */ +/* > Workspace of length */ +/* > 2*M + N if SIDE = 'L', */ +/* > 2*N + M if SIDE = 'R', */ +/* > 3*N if SIDE = 'C' or 'T'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > An error flag. It is set to: */ +/* > = 0: normal return */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > = 1: if the random numbers generated by DLARND are bad. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlaror_(char *side, char *init, integer *m, integer *n, + doublereal *a, integer *lda, integer *iseed, doublereal *x, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + integer kbeg; + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer jcol, irow; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + integer j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + integer ixfrm, itype, nxfrm; + doublereal xnorm; + extern doublereal dlarnd_(integer *, integer *); + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *); + doublereal factor, xnorms; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --x; + + /* Function Body */ + *info = 0; + if (*n == 0 || *m == 0) { + return 0; + } + + itype = 0; + if (lsame_(side, "L")) { + itype = 1; + } else if (lsame_(side, "R")) { + itype = 2; + } else if (lsame_(side, "C") || lsame_(side, "T")) { + itype = 3; + } + +/* Check for argument errors. */ + + if (itype == 0) { + *info = -1; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0 || itype == 3 && *n != *m) { + *info = -4; + } else if (*lda < *m) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAROR", &i__1); + return 0; + } + + if (itype == 1) { + nxfrm = *m; + } else { + nxfrm = *n; + } + +/* Initialize A to the identity matrix if desired */ + + if (lsame_(init, "I")) { + dlaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda); + } + +/* If no rotation possible, multiply by random +/-1 */ + +/* Compute rotation by computing Householder transformations */ +/* H(2), H(3), ..., H(nhouse) */ + + i__1 = nxfrm; + for (j = 1; j <= i__1; ++j) { + x[j] = 0.; +/* L10: */ + } + + i__1 = nxfrm; + for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) { + kbeg = nxfrm - ixfrm + 1; + +/* Generate independent normal( 0, 1 ) random numbers */ + + i__2 = nxfrm; + for (j = kbeg; j <= i__2; ++j) { + x[j] = dlarnd_(&c__3, &iseed[1]); +/* L20: */ + } + +/* Generate a Householder transformation from the random vector X */ + + xnorm = dnrm2_(&ixfrm, &x[kbeg], &c__1); + xnorms = d_sign(&xnorm, &x[kbeg]); + d__1 = -x[kbeg]; + x[kbeg + nxfrm] = d_sign(&c_b10, &d__1); + factor = xnorms * (xnorms + x[kbeg]); + if (abs(factor) < 1e-20) { + *info = 1; + xerbla_("DLAROR", info); + return 0; + } else { + factor = 1. / factor; + } + x[kbeg] += xnorms; + +/* Apply Householder transformation to A */ + + if (itype == 1 || itype == 3) { + +/* Apply H(k) from the left. */ + + dgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], & + c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1); + d__1 = -factor; + dger_(&ixfrm, n, &d__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], & + c__1, &a[kbeg + a_dim1], lda); + + } + + if (itype == 2 || itype == 3) { + +/* Apply H(k) from the right. */ + + dgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[ + kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1); + d__1 = -factor; + dger_(m, &ixfrm, &d__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], & + c__1, &a[kbeg * a_dim1 + 1], lda); + + } +/* L30: */ + } + + d__1 = dlarnd_(&c__3, &iseed[1]); + x[nxfrm * 2] = d_sign(&c_b10, &d__1); + +/* Scale the matrix A by D. */ + + if (itype == 1 || itype == 3) { + i__1 = *m; + for (irow = 1; irow <= i__1; ++irow) { + dscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda); +/* L40: */ + } + } + + if (itype == 2 || itype == 3) { + i__1 = *n; + for (jcol = 1; jcol <= i__1; ++jcol) { + dscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1); +/* L50: */ + } + } + return 0; + +/* End of DLAROR */ + +} /* dlaror_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlarot.c b/lapack-netlib/TESTING/MATGEN/dlarot.c new file mode 100644 index 000000000..f8435c43a --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlarot.c @@ -0,0 +1,709 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLAROT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, */ +/* XRIGHT ) */ + +/* LOGICAL LLEFT, LRIGHT, LROWS */ +/* INTEGER LDA, NL */ +/* DOUBLE PRECISION C, S, XLEFT, XRIGHT */ +/* DOUBLE PRECISION A( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAROT applies a (Givens) rotation to two adjacent rows or */ +/* > columns, where one element of the first and/or last column/row */ +/* > for use on matrices stored in some format other than GE, so */ +/* > that elements of the matrix may be used or modified for which */ +/* > no array element is provided. */ +/* > */ +/* > One example is a symmetric matrix in SB format (bandwidth=4), for */ +/* > which UPLO='L': Two adjacent rows will have the format: */ +/* > */ +/* > row j: C> C> C> C> C> . . . . */ +/* > row j+1: C> C> C> C> C> . . . . */ +/* > */ +/* > '*' indicates elements for which storage is provided, */ +/* > '.' indicates elements for which no storage is provided, but */ +/* > are not necessarily zero; their values are determined by */ +/* > symmetry. ' ' indicates elements which are necessarily zero, */ +/* > and have no storage provided. */ +/* > */ +/* > Those columns which have two '*'s can be handled by DROT. */ +/* > Those columns which have no '*'s can be ignored, since as long */ +/* > as the Givens rotations are carefully applied to preserve */ +/* > symmetry, their values are determined. */ +/* > Those columns which have one '*' have to be handled separately, */ +/* > by using separate variables "p" and "q": */ +/* > */ +/* > row j: C> C> C> C> C> p . . . */ +/* > row j+1: q C> C> C> C> C> . . . . */ +/* > */ +/* > The element p would have to be set correctly, then that column */ +/* > is rotated, setting p to its new value. The next call to */ +/* > DLAROT would rotate columns j and j+1, using p, and restore */ +/* > symmetry. The element q would start out being zero, and be */ +/* > made non-zero by the rotation. Later, rotations would presumably */ +/* > be chosen to zero q out. */ +/* > */ +/* > Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */ +/* > ------- ------- --------- */ +/* > */ +/* > General dense matrix: */ +/* > */ +/* > CALL DLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */ +/* > A(i,1),LDA, DUMMY, DUMMY) */ +/* > */ +/* > General banded matrix in GB format: */ +/* > */ +/* > j = MAX(1, i-KL ) */ +/* > NL = MIN( N, i+KU+1 ) + 1-j */ +/* > CALL DLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */ +/* > A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > [ note that i+1-j is just MIN(i,KL+1) ] */ +/* > */ +/* > Symmetric banded matrix in SY format, bandwidth K, */ +/* > lower triangle only: */ +/* > */ +/* > j = MAX(1, i-K ) */ +/* > NL = MIN( K+1, i ) + 1 */ +/* > CALL DLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */ +/* > A(i,j), LDA, XLEFT, XRIGHT ) */ +/* > */ +/* > Same, but upper triangle only: */ +/* > */ +/* > NL = MIN( K+1, N-i ) + 1 */ +/* > CALL DLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */ +/* > A(i,i), LDA, XLEFT, XRIGHT ) */ +/* > */ +/* > Symmetric banded matrix in SB format, bandwidth K, */ +/* > lower triangle only: */ +/* > */ +/* > [ same as for SY, except:] */ +/* > . . . . */ +/* > A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > [ note that i+1-j is just MIN(i,K+1) ] */ +/* > */ +/* > Same, but upper triangle only: */ +/* > . . . */ +/* > A(K+1,i), LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > Rotating columns is just the transpose of rotating rows, except */ +/* > for GB and SB: (rotating columns i and i+1) */ +/* > */ +/* > GB: */ +/* > j = MAX(1, i-KU ) */ +/* > NL = MIN( N, i+KL+1 ) + 1-j */ +/* > CALL DLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */ +/* > A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ +/* > */ +/* > [note that KU+j+1-i is just MAX(1,KU+2-i)] */ +/* > */ +/* > SB: (upper triangle) */ +/* > */ +/* > . . . . . . */ +/* > A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ +/* > */ +/* > SB: (lower triangle) */ +/* > */ +/* > . . . . . . */ +/* > A(1,i),LDA-1, XTOP, XBOTTM ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > LROWS - LOGICAL */ +/* > If .TRUE., then DLAROT will rotate two rows. If .FALSE., */ +/* > then it will rotate two columns. */ +/* > Not modified. */ +/* > */ +/* > LLEFT - LOGICAL */ +/* > If .TRUE., then XLEFT will be used instead of the */ +/* > corresponding element of A for the first element in the */ +/* > second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */ +/* > If .FALSE., then the corresponding element of A will be */ +/* > used. */ +/* > Not modified. */ +/* > */ +/* > LRIGHT - LOGICAL */ +/* > If .TRUE., then XRIGHT will be used instead of the */ +/* > corresponding element of A for the last element in the */ +/* > first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */ +/* > .FALSE., then the corresponding element of A will be used. */ +/* > Not modified. */ +/* > */ +/* > NL - INTEGER */ +/* > The length of the rows (if LROWS=.TRUE.) or columns (if */ +/* > LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are */ +/* > used, the columns/rows they are in should be included in */ +/* > NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */ +/* > least 2. The number of rows/columns to be rotated */ +/* > exclusive of those involving XLEFT and/or XRIGHT may */ +/* > not be negative, i.e., NL minus how many of LLEFT and */ +/* > LRIGHT are .TRUE. must be at least zero; if not, XERBLA */ +/* > will be called. */ +/* > Not modified. */ +/* > */ +/* > C, S - DOUBLE PRECISION */ +/* > Specify the Givens rotation to be applied. If LROWS is */ +/* > true, then the matrix ( c s ) */ +/* > (-s c ) is applied from the left; */ +/* > if false, then the transpose thereof is applied from the */ +/* > right. For a Givens rotation, C**2 + S**2 should be 1, */ +/* > but this is not checked. */ +/* > Not modified. */ +/* > */ +/* > A - DOUBLE PRECISION array. */ +/* > The array containing the rows/columns to be rotated. The */ +/* > first element of A should be the upper left element to */ +/* > be rotated. */ +/* > Read and modified. */ +/* > */ +/* > LDA - INTEGER */ +/* > The "effective" leading dimension of A. If A contains */ +/* > a matrix stored in GE or SY format, then this is just */ +/* > the leading dimension of A as dimensioned in the calling */ +/* > routine. If A contains a matrix stored in band (GB or SB) */ +/* > format, then this should be *one less* than the leading */ +/* > dimension used in the calling routine. Thus, if */ +/* > A were dimensioned A(LDA,*) in DLAROT, then A(1,j) would */ +/* > be the j-th element in the first of the two rows */ +/* > to be rotated, and A(2,j) would be the j-th in the second, */ +/* > regardless of how the array may be stored in the calling */ +/* > routine. [A cannot, however, actually be dimensioned thus, */ +/* > since for band format, the row number may exceed LDA, which */ +/* > is not legal FORTRAN.] */ +/* > If LROWS=.TRUE., then LDA must be at least 1, otherwise */ +/* > it must be at least NL minus the number of .TRUE. values */ +/* > in XLEFT and XRIGHT. */ +/* > Not modified. */ +/* > */ +/* > XLEFT - DOUBLE PRECISION */ +/* > If LLEFT is .TRUE., then XLEFT will be used and modified */ +/* > instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */ +/* > (if LROWS=.FALSE.). */ +/* > Read and modified. */ +/* > */ +/* > XRIGHT - DOUBLE PRECISION */ +/* > If LRIGHT is .TRUE., then XRIGHT will be used and modified */ +/* > instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */ +/* > (if LROWS=.FALSE.). */ +/* > Read and modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlarot_(logical *lrows, logical *lleft, logical *lright, + integer *nl, doublereal *c__, doublereal *s, doublereal *a, integer * + lda, doublereal *xleft, doublereal *xright) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer iinc; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer inext, ix, iy, nt; + doublereal xt[2], yt[2]; + extern /* Subroutine */ int xerbla_(char *, integer *); + integer iyt; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Set up indices, arrays for ends */ + + /* Parameter adjustments */ + --a; + + /* Function Body */ + if (*lrows) { + iinc = *lda; + inext = 1; + } else { + iinc = 1; + inext = *lda; + } + + if (*lleft) { + nt = 1; + ix = iinc + 1; + iy = *lda + 2; + xt[0] = a[1]; + yt[0] = *xleft; + } else { + nt = 0; + ix = 1; + iy = inext + 1; + } + + if (*lright) { + iyt = inext + 1 + (*nl - 1) * iinc; + ++nt; + xt[nt - 1] = *xright; + yt[nt - 1] = a[iyt]; + } + +/* Check for errors */ + + if (*nl < nt) { + xerbla_("DLAROT", &c__4); + return 0; + } + if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) { + xerbla_("DLAROT", &c__8); + return 0; + } + +/* Rotate */ + + i__1 = *nl - nt; + drot_(&i__1, &a[ix], &iinc, &a[iy], &iinc, c__, s); + drot_(&nt, xt, &c__1, yt, &c__1, c__, s); + +/* Stuff values back into XLEFT, XRIGHT, etc. */ + + if (*lleft) { + a[1] = xt[0]; + *xleft = yt[0]; + } + + if (*lright) { + *xright = xt[nt - 1]; + a[iyt] = yt[nt - 1]; + } + + return 0; + +/* End of DLAROT */ + +} /* dlarot_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlatm1.c b/lapack-netlib/TESTING/MATGEN/dlatm1.c new file mode 100644 index 000000000..1e9386125 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlatm1.c @@ -0,0 +1,698 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATM1 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) */ + +/* INTEGER IDIST, INFO, IRSIGN, MODE, N */ +/* DOUBLE PRECISION COND */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATM1 computes the entries of D(1..N) as specified by */ +/* > MODE, COND and IRSIGN. IDIST and ISEED determine the generation */ +/* > of random numbers. DLATM1 is called by DLATMR to generate */ +/* > random test matrices for LAPACK programs. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry describes how D is to be computed: */ +/* > MODE = 0 means do not change D. */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is DOUBLE PRECISION */ +/* > On entry, used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IRSIGN */ +/* > \verbatim */ +/* > IRSIGN is INTEGER */ +/* > On entry, if MODE neither -6, 0 nor 6, determines sign of */ +/* > entries of D */ +/* > 0 => leave entries of D unchanged */ +/* > 1 => multiply each entry of D by 1 or -1 with probability .5 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => UNIFORM( 0, 1 ) */ +/* > 2 => UNIFORM( -1, 1 ) */ +/* > 3 => NORMAL( 0, 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. The random number generator uses a */ +/* > linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to DLATM1 */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension ( N ) */ +/* > Array to be computed according to MODE, COND and IRSIGN. */ +/* > May be changed on exit if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of entries of D. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > 0 => normal termination */ +/* > -1 => if MODE not in range -6 to 6 */ +/* > -2 => if MODE neither -6, 0 nor 6, and */ +/* > IRSIGN neither 0 nor 1 */ +/* > -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */ +/* > -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */ +/* > -7 => if N negative */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlatm1_(integer *mode, doublereal *cond, integer *irsign, + integer *idist, integer *iseed, doublereal *d__, integer *n, integer + *info) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal temp; + integer i__; + doublereal alpha; + extern doublereal dlaran_(integer *); + extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_( + integer *, integer *, integer *, doublereal *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and Test the input parameters. Initialize flags & seed. */ + + /* Parameter adjustments */ + --d__; + --iseed; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Set INFO if an error */ + + if (*mode < -6 || *mode > 6) { + *info = -1; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && * + irsign != 1)) { + *info = -2; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) { + *info = -3; + } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) { + *info = -4; + } else if (*n < 0) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLATM1", &i__1); + return 0; + } + +/* Compute D according to COND and MODE */ + + if (*mode != 0) { + switch (abs(*mode)) { + case 1: goto L10; + case 2: goto L30; + case 3: goto L50; + case 4: goto L70; + case 5: goto L90; + case 6: goto L110; + } + +/* One large D value: */ + +L10: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = 1. / *cond; +/* L20: */ + } + d__[1] = 1.; + goto L120; + +/* One small D value: */ + +L30: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = 1.; +/* L40: */ + } + d__[*n] = 1. / *cond; + goto L120; + +/* Exponentially distributed D values: */ + +L50: + d__[1] = 1.; + if (*n > 1) { + d__1 = -1. / (doublereal) (*n - 1); + alpha = pow_dd(cond, &d__1); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ - 1; + d__[i__] = pow_di(&alpha, &i__2); +/* L60: */ + } + } + goto L120; + +/* Arithmetically distributed D values: */ + +L70: + d__[1] = 1.; + if (*n > 1) { + temp = 1. / *cond; + alpha = (1. - temp) / (doublereal) (*n - 1); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + d__[i__] = (doublereal) (*n - i__) * alpha + temp; +/* L80: */ + } + } + goto L120; + +/* Randomly distributed D values on ( 1/COND , 1): */ + +L90: + alpha = log(1. / *cond); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = exp(alpha * dlaran_(&iseed[1])); +/* L100: */ + } + goto L120; + +/* Randomly distributed D values from IDIST */ + +L110: + dlarnv_(idist, &iseed[1], n, &d__[1]); + +L120: + +/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */ +/* random signs to D */ + + if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = dlaran_(&iseed[1]); + if (temp > .5) { + d__[i__] = -d__[i__]; + } +/* L130: */ + } + } + +/* Reverse if MODE < 0 */ + + if (*mode < 0) { + i__1 = *n / 2; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = d__[i__]; + d__[i__] = d__[*n + 1 - i__]; + d__[*n + 1 - i__] = temp; +/* L140: */ + } + } + + } + + return 0; + +/* End of DLATM1 */ + +} /* dlatm1_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlatm2.c b/lapack-netlib/TESTING/MATGEN/dlatm2.c new file mode 100644 index 000000000..fbd9e61f2 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlatm2.c @@ -0,0 +1,698 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATM2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST, */ +/* ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) */ + + +/* INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N */ +/* DOUBLE PRECISION SPARSE */ + + +/* INTEGER ISEED( 4 ), IWORK( * ) */ +/* DOUBLE PRECISION D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATM2 returns the (I,J) entry of a random matrix of dimension */ +/* > (M, N) described by the other parameters. It is called by the */ +/* > DLATMR routine in order to build random test matrices. No error */ +/* > checking on parameters is done, because this routine is called in */ +/* > a tight loop by DLATMR which has already checked the parameters. */ +/* > */ +/* > Use of DLATM2 differs from SLATM3 in the order in which the random */ +/* > number generator is called to fill in random matrix entries. */ +/* > With DLATM2, the generator is called to fill in the pivoted matrix */ +/* > columnwise. With DLATM3, the generator is called to fill in the */ +/* > matrix columnwise, after which it is pivoted. Thus, DLATM3 can */ +/* > be used to construct random matrices which differ only in their */ +/* > order of rows and/or columns. DLATM2 is used to construct band */ +/* > matrices while avoiding calling the random number generator for */ +/* > entries outside the band (and therefore generating random numbers */ +/* > */ +/* > The matrix whose (I,J) entry is returned is constructed as */ +/* > follows (this routine only computes one entry): */ +/* > */ +/* > If I is outside (1..M) or J is outside (1..N), return zero */ +/* > (this is convenient for generating matrices in band format). */ +/* > */ +/* > Generate a matrix A with random entries of distribution IDIST. */ +/* > */ +/* > Set the diagonal to D. */ +/* > */ +/* > Grade the matrix, if desired, from the left (by DL) and/or */ +/* > from the right (by DR or DL) as specified by IGRADE. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > IPVTNG and IWORK. */ +/* > */ +/* > Band the matrix to have lower bandwidth KL and upper */ +/* > bandwidth KU. */ +/* > */ +/* > Set random entries to zero as specified by SPARSE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > Row of entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J */ +/* > \verbatim */ +/* > J is INTEGER */ +/* > Column of entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > Lower bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > Upper bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => UNIFORM( 0, 1 ) */ +/* > 2 => UNIFORM( -1, 1 ) */ +/* > 3 => NORMAL( 0, 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array of dimension ( 4 ) */ +/* > Seed for random number generator. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array of dimension ( MIN( I , J ) ) */ +/* > Diagonal entries of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGRADE */ +/* > \verbatim */ +/* > IGRADE is INTEGER */ +/* > Specifies grading of matrix as follows: */ +/* > 0 => no grading */ +/* > 1 => matrix premultiplied by diag( DL ) */ +/* > 2 => matrix postmultiplied by diag( DR ) */ +/* > 3 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > 4 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > 5 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array ( I or J, as appropriate ) */ +/* > Left scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DR */ +/* > \verbatim */ +/* > DR is DOUBLE PRECISION array ( I or J, as appropriate ) */ +/* > Right scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPVTNG */ +/* > \verbatim */ +/* > IPVTNG is INTEGER */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 0 => none. */ +/* > 1 => row pivoting. */ +/* > 2 => column pivoting. */ +/* > 3 => full pivoting, i.e., on both sides. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array ( I or J, as appropriate ) */ +/* > This array specifies the permutation used. The */ +/* > row (or column) in position K was originally in */ +/* > position IWORK( K ). */ +/* > This differs from IWORK for DLATM3. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is DOUBLE PRECISION between 0. and 1. */ +/* > On entry specifies the sparsity of the matrix */ +/* > if sparse matrix is to be generated. */ +/* > SPARSE should lie between 0 and 1. */ +/* > A uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +doublereal dlatm2_(integer *m, integer *n, integer *i__, integer *j, integer * + kl, integer *ku, integer *idist, integer *iseed, doublereal *d__, + integer *igrade, doublereal *dl, doublereal *dr, integer *ipvtng, + integer *iwork, doublereal *sparse) +{ + /* System generated locals */ + doublereal ret_val; + + /* Local variables */ + integer isub, jsub; + doublereal temp; + extern doublereal dlaran_(integer *), dlarnd_(integer *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + + + + +/* ===================================================================== */ + + + + + + + +/* ----------------------------------------------------------------------- */ + + + +/* Check for I and J in range */ + + /* Parameter adjustments */ + --iwork; + --dr; + --dl; + --d__; + --iseed; + + /* Function Body */ + if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) { + ret_val = 0.; + return ret_val; + } + +/* Check for banding */ + + if (*j > *i__ + *ku || *j < *i__ - *kl) { + ret_val = 0.; + return ret_val; + } + +/* Check for sparsity */ + + if (*sparse > 0.) { + if (dlaran_(&iseed[1]) < *sparse) { + ret_val = 0.; + return ret_val; + } + } + +/* Compute subscripts depending on IPVTNG */ + + if (*ipvtng == 0) { + isub = *i__; + jsub = *j; + } else if (*ipvtng == 1) { + isub = iwork[*i__]; + jsub = *j; + } else if (*ipvtng == 2) { + isub = *i__; + jsub = iwork[*j]; + } else if (*ipvtng == 3) { + isub = iwork[*i__]; + jsub = iwork[*j]; + } + +/* Compute entry and grade it according to IGRADE */ + + if (isub == jsub) { + temp = d__[isub]; + } else { + temp = dlarnd_(idist, &iseed[1]); + } + if (*igrade == 1) { + temp *= dl[isub]; + } else if (*igrade == 2) { + temp *= dr[jsub]; + } else if (*igrade == 3) { + temp = temp * dl[isub] * dr[jsub]; + } else if (*igrade == 4 && isub != jsub) { + temp = temp * dl[isub] / dl[jsub]; + } else if (*igrade == 5) { + temp = temp * dl[isub] * dl[jsub]; + } + ret_val = temp; + return ret_val; + +/* End of DLATM2 */ + +} /* dlatm2_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlatm3.c b/lapack-netlib/TESTING/MATGEN/dlatm3.c new file mode 100644 index 000000000..d440bcbfd --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlatm3.c @@ -0,0 +1,716 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATM3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, */ +/* IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, */ +/* SPARSE ) */ + + +/* INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, */ +/* $ KU, M, N */ +/* DOUBLE PRECISION SPARSE */ + + +/* INTEGER ISEED( 4 ), IWORK( * ) */ +/* DOUBLE PRECISION D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATM3 returns the (ISUB,JSUB) entry of a random matrix of */ +/* > dimension (M, N) described by the other parameters. (ISUB,JSUB) */ +/* > is the final position of the (I,J) entry after pivoting */ +/* > according to IPVTNG and IWORK. DLATM3 is called by the */ +/* > DLATMR routine in order to build random test matrices. No error */ +/* > checking on parameters is done, because this routine is called in */ +/* > a tight loop by DLATMR which has already checked the parameters. */ +/* > */ +/* > Use of DLATM3 differs from SLATM2 in the order in which the random */ +/* > number generator is called to fill in random matrix entries. */ +/* > With DLATM2, the generator is called to fill in the pivoted matrix */ +/* > columnwise. With DLATM3, the generator is called to fill in the */ +/* > matrix columnwise, after which it is pivoted. Thus, DLATM3 can */ +/* > be used to construct random matrices which differ only in their */ +/* > order of rows and/or columns. DLATM2 is used to construct band */ +/* > matrices while avoiding calling the random number generator for */ +/* > entries outside the band (and therefore generating random numbers */ +/* > in different orders for different pivot orders). */ +/* > */ +/* > The matrix whose (ISUB,JSUB) entry is returned is constructed as */ +/* > follows (this routine only computes one entry): */ +/* > */ +/* > If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */ +/* > (this is convenient for generating matrices in band format). */ +/* > */ +/* > Generate a matrix A with random entries of distribution IDIST. */ +/* > */ +/* > Set the diagonal to D. */ +/* > */ +/* > Grade the matrix, if desired, from the left (by DL) and/or */ +/* > from the right (by DR or DL) as specified by IGRADE. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > IPVTNG and IWORK. */ +/* > */ +/* > Band the matrix to have lower bandwidth KL and upper */ +/* > bandwidth KU. */ +/* > */ +/* > Set random entries to zero as specified by SPARSE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > Row of unpivoted entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J */ +/* > \verbatim */ +/* > J is INTEGER */ +/* > Column of unpivoted entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISUB */ +/* > \verbatim */ +/* > ISUB is INTEGER */ +/* > Row of pivoted entry to be returned. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JSUB */ +/* > \verbatim */ +/* > JSUB is INTEGER */ +/* > Column of pivoted entry to be returned. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > Lower bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > Upper bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => UNIFORM( 0, 1 ) */ +/* > 2 => UNIFORM( -1, 1 ) */ +/* > 3 => NORMAL( 0, 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array of dimension ( 4 ) */ +/* > Seed for random number generator. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array of dimension ( MIN( I , J ) ) */ +/* > Diagonal entries of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGRADE */ +/* > \verbatim */ +/* > IGRADE is INTEGER */ +/* > Specifies grading of matrix as follows: */ +/* > 0 => no grading */ +/* > 1 => matrix premultiplied by diag( DL ) */ +/* > 2 => matrix postmultiplied by diag( DR ) */ +/* > 3 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > 4 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > 5 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array ( I or J, as appropriate ) */ +/* > Left scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DR */ +/* > \verbatim */ +/* > DR is DOUBLE PRECISION array ( I or J, as appropriate ) */ +/* > Right scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPVTNG */ +/* > \verbatim */ +/* > IPVTNG is INTEGER */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 0 => none. */ +/* > 1 => row pivoting. */ +/* > 2 => column pivoting. */ +/* > 3 => full pivoting, i.e., on both sides. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array ( I or J, as appropriate ) */ +/* > This array specifies the permutation used. The */ +/* > row (or column) originally in position K is in */ +/* > position IWORK( K ) after pivoting. */ +/* > This differs from IWORK for DLATM2. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is DOUBLE PRECISION between 0. and 1. */ +/* > On entry specifies the sparsity of the matrix */ +/* > if sparse matrix is to be generated. */ +/* > SPARSE should lie between 0 and 1. */ +/* > A uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +doublereal dlatm3_(integer *m, integer *n, integer *i__, integer *j, integer * + isub, integer *jsub, integer *kl, integer *ku, integer *idist, + integer *iseed, doublereal *d__, integer *igrade, doublereal *dl, + doublereal *dr, integer *ipvtng, integer *iwork, doublereal *sparse) +{ + /* System generated locals */ + doublereal ret_val; + + /* Local variables */ + doublereal temp; + extern doublereal dlaran_(integer *), dlarnd_(integer *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + + + + +/* ===================================================================== */ + + + + + + + +/* ----------------------------------------------------------------------- */ + + + +/* Check for I and J in range */ + + /* Parameter adjustments */ + --iwork; + --dr; + --dl; + --d__; + --iseed; + + /* Function Body */ + if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) { + *isub = *i__; + *jsub = *j; + ret_val = 0.; + return ret_val; + } + +/* Compute subscripts depending on IPVTNG */ + + if (*ipvtng == 0) { + *isub = *i__; + *jsub = *j; + } else if (*ipvtng == 1) { + *isub = iwork[*i__]; + *jsub = *j; + } else if (*ipvtng == 2) { + *isub = *i__; + *jsub = iwork[*j]; + } else if (*ipvtng == 3) { + *isub = iwork[*i__]; + *jsub = iwork[*j]; + } + +/* Check for banding */ + + if (*jsub > *isub + *ku || *jsub < *isub - *kl) { + ret_val = 0.; + return ret_val; + } + +/* Check for sparsity */ + + if (*sparse > 0.) { + if (dlaran_(&iseed[1]) < *sparse) { + ret_val = 0.; + return ret_val; + } + } + +/* Compute entry and grade it according to IGRADE */ + + if (*i__ == *j) { + temp = d__[*i__]; + } else { + temp = dlarnd_(idist, &iseed[1]); + } + if (*igrade == 1) { + temp *= dl[*i__]; + } else if (*igrade == 2) { + temp *= dr[*j]; + } else if (*igrade == 3) { + temp = temp * dl[*i__] * dr[*j]; + } else if (*igrade == 4 && *i__ != *j) { + temp = temp * dl[*i__] / dl[*j]; + } else if (*igrade == 5) { + temp = temp * dl[*i__] * dl[*j]; + } + ret_val = temp; + return ret_val; + +/* End of DLATM3 */ + +} /* dlatm3_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlatm5.c b/lapack-netlib/TESTING/MATGEN/dlatm5.c new file mode 100644 index 000000000..c09bab40d --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlatm5.c @@ -0,0 +1,981 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATM5 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, */ +/* E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, */ +/* QBLCKB ) */ + +/* INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, */ +/* $ PRTYPE, QBLCKA, QBLCKB */ +/* DOUBLE PRECISION ALPHA */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), */ +/* $ D( LDD, * ), E( LDE, * ), F( LDF, * ), */ +/* $ L( LDL, * ), R( LDR, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATM5 generates matrices involved in the Generalized Sylvester */ +/* > equation: */ +/* > */ +/* > A * R - L * B = C */ +/* > D * R - L * E = F */ +/* > */ +/* > They also satisfy (the diagonalization condition) */ +/* > */ +/* > [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] ) */ +/* > [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] ) */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PRTYPE */ +/* > \verbatim */ +/* > PRTYPE is INTEGER */ +/* > "Points" to a certain type of the matrices to generate */ +/* > (see further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Specifies the order of A and D and the number of rows in */ +/* > C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Specifies the order of B and E and the number of columns in */ +/* > C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, M). */ +/* > On exit A M-by-M is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N). */ +/* > On exit B N-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (LDC, N). */ +/* > On exit C M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of C. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (LDD, M). */ +/* > On exit D M-by-M is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDD */ +/* > \verbatim */ +/* > LDD is INTEGER */ +/* > The leading dimension of D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (LDE, N). */ +/* > On exit E N-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDE */ +/* > \verbatim */ +/* > LDE is INTEGER */ +/* > The leading dimension of E. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] F */ +/* > \verbatim */ +/* > F is DOUBLE PRECISION array, dimension (LDF, N). */ +/* > On exit F M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of F. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is DOUBLE PRECISION array, dimension (LDR, N). */ +/* > On exit R M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDR */ +/* > \verbatim */ +/* > LDR is INTEGER */ +/* > The leading dimension of R. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is DOUBLE PRECISION array, dimension (LDL, N). */ +/* > On exit L M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDL */ +/* > \verbatim */ +/* > LDL is INTEGER */ +/* > The leading dimension of L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION */ +/* > Parameter used in generating PRTYPE = 1 and 5 matrices. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QBLCKA */ +/* > \verbatim */ +/* > QBLCKA is INTEGER */ +/* > When PRTYPE = 3, specifies the distance between 2-by-2 */ +/* > blocks on the diagonal in A. Otherwise, QBLCKA is not */ +/* > referenced. QBLCKA > 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QBLCKB */ +/* > \verbatim */ +/* > QBLCKB is INTEGER */ +/* > When PRTYPE = 3, specifies the distance between 2-by-2 */ +/* > blocks on the diagonal in B. Otherwise, QBLCKB is not */ +/* > referenced. QBLCKB > 1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup double_matgen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */ +/* > */ +/* > A : if (i == j) then A(i, j) = 1.0 */ +/* > if (j == i + 1) then A(i, j) = -1.0 */ +/* > else A(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > B : if (i == j) then B(i, j) = 1.0 - ALPHA */ +/* > if (j == i + 1) then B(i, j) = 1.0 */ +/* > else B(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > D : if (i == j) then D(i, j) = 1.0 */ +/* > else D(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > E : if (i == j) then E(i, j) = 1.0 */ +/* > else E(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > L = R are chosen from [-10...10], */ +/* > which specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */ +/* > */ +/* > A : if (i <= j) then A(i, j) = [-1...1] */ +/* > else A(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > if (PRTYPE = 3) then */ +/* > A(k + 1, k + 1) = A(k, k) */ +/* > A(k + 1, k) = [-1...1] */ +/* > sign(A(k, k + 1) = -(sin(A(k + 1, k)) */ +/* > k = 1, M - 1, QBLCKA */ +/* > */ +/* > B : if (i <= j) then B(i, j) = [-1...1] */ +/* > else B(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > if (PRTYPE = 3) then */ +/* > B(k + 1, k + 1) = B(k, k) */ +/* > B(k + 1, k) = [-1...1] */ +/* > sign(B(k, k + 1) = -(sign(B(k + 1, k)) */ +/* > k = 1, N - 1, QBLCKB */ +/* > */ +/* > D : if (i <= j) then D(i, j) = [-1...1]. */ +/* > else D(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > */ +/* > E : if (i <= j) then D(i, j) = [-1...1] */ +/* > else E(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > L, R are chosen from [-10...10], */ +/* > which specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 4 Full */ +/* > A(i, j) = [-10...10] */ +/* > D(i, j) = [-1...1] i,j = 1...M */ +/* > B(i, j) = [-10...10] */ +/* > E(i, j) = [-1...1] i,j = 1...N */ +/* > R(i, j) = [-10...10] */ +/* > L(i, j) = [-1...1] i = 1..M ,j = 1...N */ +/* > */ +/* > L, R specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 5 special case common and/or close eigs. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dlatm5_(integer *prtype, integer *m, integer *n, + doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * + c__, integer *ldc, doublereal *d__, integer *ldd, doublereal *e, + integer *lde, doublereal *f, integer *ldf, doublereal *r__, integer * + ldr, doublereal *l, integer *ldl, doublereal *alpha, integer *qblcka, + integer *qblckb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset, + r_dim1, r_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + doublereal imeps, reeps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + r_dim1 = *ldr; + r_offset = 1 + r_dim1 * 1; + r__ -= r_offset; + l_dim1 = *ldl; + l_offset = 1 + l_dim1 * 1; + l -= l_offset; + + /* Function Body */ + if (*prtype == 1) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + if (i__ == j) { + a[i__ + j * a_dim1] = 1.; + d__[i__ + j * d_dim1] = 1.; + } else if (i__ == j - 1) { + a[i__ + j * a_dim1] = -1.; + d__[i__ + j * d_dim1] = 0.; + } else { + a[i__ + j * a_dim1] = 0.; + d__[i__ + j * d_dim1] = 0.; + } +/* L10: */ + } +/* L20: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (i__ == j) { + b[i__ + j * b_dim1] = 1. - *alpha; + e[i__ + j * e_dim1] = 1.; + } else if (i__ == j - 1) { + b[i__ + j * b_dim1] = 1.; + e[i__ + j * e_dim1] = 0.; + } else { + b[i__ + j * b_dim1] = 0.; + e[i__ + j * e_dim1] = 0.; + } +/* L30: */ + } +/* L40: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (i__ / j))) * + 20.; + l[i__ + j * l_dim1] = r__[i__ + j * r_dim1]; +/* L50: */ + } +/* L60: */ + } + + } else if (*prtype == 2 || *prtype == 3) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + if (i__ <= j) { + a[i__ + j * a_dim1] = (.5 - sin((doublereal) i__)) * 2.; + d__[i__ + j * d_dim1] = (.5 - sin((doublereal) (i__ * j))) + * 2.; + } else { + a[i__ + j * a_dim1] = 0.; + d__[i__ + j * d_dim1] = 0.; + } +/* L70: */ + } +/* L80: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (i__ <= j) { + b[i__ + j * b_dim1] = (.5 - sin((doublereal) (i__ + j))) * + 2.; + e[i__ + j * e_dim1] = (.5 - sin((doublereal) j)) * 2.; + } else { + b[i__ + j * b_dim1] = 0.; + e[i__ + j * e_dim1] = 0.; + } +/* L90: */ + } +/* L100: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (i__ * j))) * + 20.; + l[i__ + j * l_dim1] = (.5 - sin((doublereal) (i__ + j))) * + 20.; +/* L110: */ + } +/* L120: */ + } + + if (*prtype == 3) { + if (*qblcka <= 1) { + *qblcka = 2; + } + i__1 = *m - 1; + i__2 = *qblcka; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { + a[k + 1 + (k + 1) * a_dim1] = a[k + k * a_dim1]; + a[k + 1 + k * a_dim1] = -sin(a[k + (k + 1) * a_dim1]); +/* L130: */ + } + + if (*qblckb <= 1) { + *qblckb = 2; + } + i__2 = *n - 1; + i__1 = *qblckb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { + b[k + 1 + (k + 1) * b_dim1] = b[k + k * b_dim1]; + b[k + 1 + k * b_dim1] = -sin(b[k + (k + 1) * b_dim1]); +/* L140: */ + } + } + + } else if (*prtype == 4) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + a[i__ + j * a_dim1] = (.5 - sin((doublereal) (i__ * j))) * + 20.; + d__[i__ + j * d_dim1] = (.5 - sin((doublereal) (i__ + j))) * + 2.; +/* L150: */ + } +/* L160: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + b[i__ + j * b_dim1] = (.5 - sin((doublereal) (i__ + j))) * + 20.; + e[i__ + j * e_dim1] = (.5 - sin((doublereal) (i__ * j))) * 2.; +/* L170: */ + } +/* L180: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (j / i__))) * + 20.; + l[i__ + j * l_dim1] = (.5 - sin((doublereal) (i__ * j))) * 2.; +/* L190: */ + } +/* L200: */ + } + + } else if (*prtype >= 5) { + reeps = 20. / *alpha; + imeps = -1.5 / *alpha; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (i__ * j))) * * + alpha / 20.; + l[i__ + j * l_dim1] = (.5 - sin((doublereal) (i__ + j))) * * + alpha / 20.; +/* L210: */ + } +/* L220: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__ + i__ * d_dim1] = 1.; +/* L230: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ <= 4) { + a[i__ + i__ * a_dim1] = 1.; + if (i__ > 2) { + a[i__ + i__ * a_dim1] = reeps + 1.; + } + if (i__ % 2 != 0 && i__ < *m) { + a[i__ + (i__ + 1) * a_dim1] = imeps; + } else if (i__ > 1) { + a[i__ + (i__ - 1) * a_dim1] = -imeps; + } + } else if (i__ <= 8) { + if (i__ <= 6) { + a[i__ + i__ * a_dim1] = reeps; + } else { + a[i__ + i__ * a_dim1] = -reeps; + } + if (i__ % 2 != 0 && i__ < *m) { + a[i__ + (i__ + 1) * a_dim1] = 1.; + } else if (i__ > 1) { + a[i__ + (i__ - 1) * a_dim1] = -1.; + } + } else { + a[i__ + i__ * a_dim1] = 1.; + if (i__ % 2 != 0 && i__ < *m) { + a[i__ + (i__ + 1) * a_dim1] = imeps * 2; + } else if (i__ > 1) { + a[i__ + (i__ - 1) * a_dim1] = -imeps * 2; + } + } +/* L240: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__ + i__ * e_dim1] = 1.; + if (i__ <= 4) { + b[i__ + i__ * b_dim1] = -1.; + if (i__ > 2) { + b[i__ + i__ * b_dim1] = 1. - reeps; + } + if (i__ % 2 != 0 && i__ < *n) { + b[i__ + (i__ + 1) * b_dim1] = imeps; + } else if (i__ > 1) { + b[i__ + (i__ - 1) * b_dim1] = -imeps; + } + } else if (i__ <= 8) { + if (i__ <= 6) { + b[i__ + i__ * b_dim1] = reeps; + } else { + b[i__ + i__ * b_dim1] = -reeps; + } + if (i__ % 2 != 0 && i__ < *n) { + b[i__ + (i__ + 1) * b_dim1] = imeps + 1.; + } else if (i__ > 1) { + b[i__ + (i__ - 1) * b_dim1] = -1. - imeps; + } + } else { + b[i__ + i__ * b_dim1] = 1. - reeps; + if (i__ % 2 != 0 && i__ < *n) { + b[i__ + (i__ + 1) * b_dim1] = imeps * 2; + } else if (i__ > 1) { + b[i__ + (i__ - 1) * b_dim1] = -imeps * 2; + } + } +/* L250: */ + } + } + +/* Compute rhs (C, F) */ + + dgemm_("N", "N", m, n, m, &c_b29, &a[a_offset], lda, &r__[r_offset], ldr, + &c_b30, &c__[c_offset], ldc); + dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &b[b_offset], ldb, & + c_b29, &c__[c_offset], ldc); + dgemm_("N", "N", m, n, m, &c_b29, &d__[d_offset], ldd, &r__[r_offset], + ldr, &c_b30, &f[f_offset], ldf); + dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &e[e_offset], lde, & + c_b29, &f[f_offset], ldf); + +/* End of DLATM5 */ + + return 0; +} /* dlatm5_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlatm6.c b/lapack-netlib/TESTING/MATGEN/dlatm6.c new file mode 100644 index 000000000..534498594 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlatm6.c @@ -0,0 +1,750 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATM6 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, */ +/* BETA, WX, WY, S, DIF ) */ + +/* INTEGER LDA, LDX, LDY, N, TYPE */ +/* DOUBLE PRECISION ALPHA, BETA, WX, WY */ +/* DOUBLE PRECISION A( LDA, * ), B( LDA, * ), DIF( * ), S( * ), */ +/* $ X( LDX, * ), Y( LDY, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATM6 generates test matrices for the generalized eigenvalue */ +/* > problem, their corresponding right and left eigenvector matrices, */ +/* > and also reciprocal condition numbers for all eigenvalues and */ +/* > the reciprocal condition numbers of eigenvectors corresponding to */ +/* > the 1th and 5th eigenvalues. */ +/* > */ +/* > Test Matrices */ +/* > ============= */ +/* > */ +/* > Two kinds of test matrix pairs */ +/* > */ +/* > (A, B) = inverse(YH) * (Da, Db) * inverse(X) */ +/* > */ +/* > are used in the tests: */ +/* > */ +/* > Type 1: */ +/* > Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */ +/* > 0 2+a 0 0 0 0 1 0 0 0 */ +/* > 0 0 3+a 0 0 0 0 1 0 0 */ +/* > 0 0 0 4+a 0 0 0 0 1 0 */ +/* > 0 0 0 0 5+a , 0 0 0 0 1 , and */ +/* > */ +/* > Type 2: */ +/* > Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */ +/* > 1 1 0 0 0 0 1 0 0 0 */ +/* > 0 0 1 0 0 0 0 1 0 0 */ +/* > 0 0 0 1+a 1+b 0 0 0 1 0 */ +/* > 0 0 0 -1-b 1+a , 0 0 0 0 1 . */ +/* > */ +/* > In both cases the same inverse(YH) and inverse(X) are used to compute */ +/* > (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */ +/* > */ +/* > YH: = 1 0 -y y -y X = 1 0 -x -x x */ +/* > 0 1 -y y -y 0 1 x -x -x */ +/* > 0 0 1 0 0 0 0 1 0 0 */ +/* > 0 0 0 1 0 0 0 0 1 0 */ +/* > 0 0 0 0 1, 0 0 0 0 1 , */ +/* > */ +/* > where a, b, x and y will have all values independently of each other. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TYPE */ +/* > \verbatim */ +/* > TYPE is INTEGER */ +/* > Specifies the problem type (see further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Size of the matrices A and B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, N). */ +/* > On exit A N-by-N is initialized according to TYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A and of B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDA, N). */ +/* > On exit B N-by-N is initialized according to TYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX, N). */ +/* > On exit X is the N-by-N matrix of right eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of X. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension (LDY, N). */ +/* > On exit Y is the N-by-N matrix of left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION */ +/* > */ +/* > Weighting constants for matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WX */ +/* > \verbatim */ +/* > WX is DOUBLE PRECISION */ +/* > Constant for right eigenvector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WY */ +/* > \verbatim */ +/* > WY is DOUBLE PRECISION */ +/* > Constant for left eigenvector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > S(i) is the reciprocal condition number for eigenvalue i. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is DOUBLE PRECISION array, dimension (N) */ +/* > DIF(i) is the reciprocal condition number for eigenvector i. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlatm6_(integer *type__, integer *n, doublereal *a, + integer *lda, doublereal *b, doublereal *x, integer *ldx, doublereal * + y, integer *ldy, doublereal *alpha, doublereal *beta, doublereal *wx, + doublereal *wy, doublereal *s, doublereal *dif) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1, + y_offset, i__1, i__2; + + /* Local variables */ + integer info; + doublereal work[100]; + integer i__, j; + doublereal z__[144] /* was [12][12] */; + extern /* Subroutine */ int dlakf2_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *), dgesvd_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal + *, integer *, doublereal *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Generate test problem ... */ +/* (Da, Db) ... */ + + /* Parameter adjustments */ + b_dim1 = *lda; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --s; + --dif; + + /* Function Body */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + + if (i__ == j) { + a[i__ + i__ * a_dim1] = (doublereal) i__ + *alpha; + b[i__ + i__ * b_dim1] = 1.; + } else { + a[i__ + j * a_dim1] = 0.; + b[i__ + j * b_dim1] = 0.; + } + +/* L10: */ + } +/* L20: */ + } + +/* Form X and Y */ + + dlacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy); + y[y_dim1 + 3] = -(*wy); + y[y_dim1 + 4] = *wy; + y[y_dim1 + 5] = -(*wy); + y[(y_dim1 << 1) + 3] = -(*wy); + y[(y_dim1 << 1) + 4] = *wy; + y[(y_dim1 << 1) + 5] = -(*wy); + + dlacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx); + x[x_dim1 * 3 + 1] = -(*wx); + x[(x_dim1 << 2) + 1] = -(*wx); + x[x_dim1 * 5 + 1] = *wx; + x[x_dim1 * 3 + 2] = *wx; + x[(x_dim1 << 2) + 2] = -(*wx); + x[x_dim1 * 5 + 2] = -(*wx); + +/* Form (A, B) */ + + b[b_dim1 * 3 + 1] = *wx + *wy; + b[b_dim1 * 3 + 2] = -(*wx) + *wy; + b[(b_dim1 << 2) + 1] = *wx - *wy; + b[(b_dim1 << 2) + 2] = *wx - *wy; + b[b_dim1 * 5 + 1] = -(*wx) + *wy; + b[b_dim1 * 5 + 2] = *wx + *wy; + if (*type__ == 1) { + a[a_dim1 * 3 + 1] = *wx * a[a_dim1 + 1] + *wy * a[a_dim1 * 3 + 3]; + a[a_dim1 * 3 + 2] = -(*wx) * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * + 3 + 3]; + a[(a_dim1 << 2) + 1] = *wx * a[a_dim1 + 1] - *wy * a[(a_dim1 << 2) + + 4]; + a[(a_dim1 << 2) + 2] = *wx * a[(a_dim1 << 1) + 2] - *wy * a[(a_dim1 << + 2) + 4]; + a[a_dim1 * 5 + 1] = -(*wx) * a[a_dim1 + 1] + *wy * a[a_dim1 * 5 + 5]; + a[a_dim1 * 5 + 2] = *wx * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * 5 + + 5]; + } else if (*type__ == 2) { + a[a_dim1 * 3 + 1] = *wx * 2. + *wy; + a[a_dim1 * 3 + 2] = *wy; + a[(a_dim1 << 2) + 1] = -(*wy) * (*alpha + 2. + *beta); + a[(a_dim1 << 2) + 2] = *wx * 2. - *wy * (*alpha + 2. + *beta); + a[a_dim1 * 5 + 1] = *wx * -2. + *wy * (*alpha - *beta); + a[a_dim1 * 5 + 2] = *wy * (*alpha - *beta); + a[a_dim1 + 1] = 1.; + a[(a_dim1 << 1) + 1] = -1.; + a[a_dim1 + 2] = 1.; + a[(a_dim1 << 1) + 2] = a[a_dim1 + 1]; + a[a_dim1 * 3 + 3] = 1.; + a[(a_dim1 << 2) + 4] = *alpha + 1.; + a[a_dim1 * 5 + 4] = *beta + 1.; + a[(a_dim1 << 2) + 5] = -a[a_dim1 * 5 + 4]; + a[a_dim1 * 5 + 5] = a[(a_dim1 << 2) + 4]; + } + +/* Compute condition numbers */ + + if (*type__ == 1) { + + s[1] = 1. / sqrt((*wy * 3. * *wy + 1.) / (a[a_dim1 + 1] * a[a_dim1 + + 1] + 1.)); + s[2] = 1. / sqrt((*wy * 3. * *wy + 1.) / (a[(a_dim1 << 1) + 2] * a[( + a_dim1 << 1) + 2] + 1.)); + s[3] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[a_dim1 * 3 + 3] * a[ + a_dim1 * 3 + 3] + 1.)); + s[4] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[(a_dim1 << 2) + 4] * a[( + a_dim1 << 2) + 4] + 1.)); + s[5] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[a_dim1 * 5 + 5] * a[ + a_dim1 * 5 + 5] + 1.)); + + dlakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[ + b_offset], &b[(b_dim1 << 1) + 2], z__, &c__12); + dgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, & + work[9], &c__1, &work[10], &c__40, &info); + dif[1] = work[7]; + + dlakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[ + b_offset], &b[b_dim1 * 5 + 5], z__, &c__12); + dgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, & + work[9], &c__1, &work[10], &c__40, &info); + dif[5] = work[7]; + + } else if (*type__ == 2) { + + s[1] = 1. / sqrt(*wy * *wy + .33333333333333331); + s[2] = s[1]; + s[3] = 1. / sqrt(*wx * *wx + .5); + s[4] = 1. / sqrt((*wx * 2. * *wx + 1.) / ((*alpha + 1.) * (*alpha + + 1.) + 1. + (*beta + 1.) * (*beta + 1.))); + s[5] = s[4]; + + dlakf2_(&c__2, &c__3, &a[a_offset], lda, &a[a_dim1 * 3 + 3], &b[ + b_offset], &b[b_dim1 * 3 + 3], z__, &c__12); + dgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1, + &work[13], &c__1, &work[14], &c__60, &info); + dif[1] = work[11]; + + dlakf2_(&c__3, &c__2, &a[a_offset], lda, &a[(a_dim1 << 2) + 4], &b[ + b_offset], &b[(b_dim1 << 2) + 4], z__, &c__12); + dgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1, + &work[13], &c__1, &work[14], &c__60, &info); + dif[5] = work[11]; + + } + + return 0; + +/* End of DLATM6 */ + +} /* dlatm6_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlatm7.c b/lapack-netlib/TESTING/MATGEN/dlatm7.c new file mode 100644 index 000000000..e03729c8a --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlatm7.c @@ -0,0 +1,699 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATM7 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N, */ +/* RANK, INFO ) */ + +/* DOUBLE PRECISION COND */ +/* INTEGER IDIST, INFO, IRSIGN, MODE, N, RANK */ +/* DOUBLE PRECISION D( * ) */ +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATM7 computes the entries of D as specified by MODE */ +/* > COND and IRSIGN. IDIST and ISEED determine the generation */ +/* > of random numbers. DLATM7 is called by DLATMT to generate */ +/* > random test matrices. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > MODE - INTEGER */ +/* > On entry describes how D is to be computed: */ +/* > MODE = 0 means do not change D. */ +/* > */ +/* > MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */ +/* > MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK */ +/* > */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > Not modified. */ +/* > */ +/* > COND - DOUBLE PRECISION */ +/* > On entry, used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > */ +/* > IRSIGN - INTEGER */ +/* > On entry, if MODE neither -6, 0 nor 6, determines sign of */ +/* > entries of D */ +/* > 0 => leave entries of D unchanged */ +/* > 1 => multiply each entry of D by 1 or -1 with probability .5 */ +/* > */ +/* > IDIST - CHARACTER*1 */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => UNIFORM( 0, 1 ) */ +/* > 2 => UNIFORM( -1, 1 ) */ +/* > 3 => NORMAL( 0, 1 ) */ +/* > Not modified. */ +/* > */ +/* > ISEED - INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. The random number generator uses a */ +/* > linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to DLATM7 */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > */ +/* > D - DOUBLE PRECISION array, dimension ( MIN( M , N ) ) */ +/* > Array to be computed according to MODE, COND and IRSIGN. */ +/* > May be changed on exit if MODE is nonzero. */ +/* > */ +/* > N - INTEGER */ +/* > Number of entries of D. Not modified. */ +/* > */ +/* > RANK - INTEGER */ +/* > The rank of matrix to be generated for modes 1,2,3 only. */ +/* > D( RANK+1:N ) = 0. */ +/* > Not modified. */ +/* > */ +/* > INFO - INTEGER */ +/* > 0 => normal termination */ +/* > -1 => if MODE not in range -6 to 6 */ +/* > -2 => if MODE neither -6, 0 nor 6, and */ +/* > IRSIGN neither 0 nor 1 */ +/* > -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */ +/* > -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */ +/* > -7 => if N negative */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlatm7_(integer *mode, doublereal *cond, integer *irsign, + integer *idist, integer *iseed, doublereal *d__, integer *n, integer + *rank, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal temp; + integer i__; + doublereal alpha; + extern doublereal dlaran_(integer *); + extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_( + integer *, integer *, integer *, doublereal *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and Test the input parameters. Initialize flags & seed. */ + + /* Parameter adjustments */ + --d__; + --iseed; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Set INFO if an error */ + + if (*mode < -6 || *mode > 6) { + *info = -1; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && * + irsign != 1)) { + *info = -2; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) { + *info = -3; + } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) { + *info = -4; + } else if (*n < 0) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLATM7", &i__1); + return 0; + } + +/* Compute D according to COND and MODE */ + + if (*mode != 0) { + switch (abs(*mode)) { + case 1: goto L100; + case 2: goto L130; + case 3: goto L160; + case 4: goto L190; + case 5: goto L210; + case 6: goto L230; + } + +/* One large D value: */ + +L100: + i__1 = *rank; + for (i__ = 2; i__ <= i__1; ++i__) { + d__[i__] = 1. / *cond; +/* L110: */ + } + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + d__[i__] = 0.; +/* L120: */ + } + d__[1] = 1.; + goto L240; + +/* One small D value: */ + +L130: + i__1 = *rank - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = 1.; +/* L140: */ + } + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + d__[i__] = 0.; +/* L150: */ + } + d__[*rank] = 1. / *cond; + goto L240; + +/* Exponentially distributed D values: */ + +L160: + d__[1] = 1.; + if (*n > 1 && *rank > 1) { + d__1 = -1. / (doublereal) (*rank - 1); + alpha = pow_dd(cond, &d__1); + i__1 = *rank; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ - 1; + d__[i__] = pow_di(&alpha, &i__2); +/* L170: */ + } + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + d__[i__] = 0.; +/* L180: */ + } + } + goto L240; + +/* Arithmetically distributed D values: */ + +L190: + d__[1] = 1.; + if (*n > 1) { + temp = 1. / *cond; + alpha = (1. - temp) / (doublereal) (*n - 1); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + d__[i__] = (doublereal) (*n - i__) * alpha + temp; +/* L200: */ + } + } + goto L240; + +/* Randomly distributed D values on ( 1/COND , 1): */ + +L210: + alpha = log(1. / *cond); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = exp(alpha * dlaran_(&iseed[1])); +/* L220: */ + } + goto L240; + +/* Randomly distributed D values from IDIST */ + +L230: + dlarnv_(idist, &iseed[1], n, &d__[1]); + +L240: + +/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */ +/* random signs to D */ + + if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = dlaran_(&iseed[1]); + if (temp > .5) { + d__[i__] = -d__[i__]; + } +/* L250: */ + } + } + +/* Reverse if MODE < 0 */ + + if (*mode < 0) { + i__1 = *n / 2; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = d__[i__]; + d__[i__] = d__[*n + 1 - i__]; + d__[*n + 1 - i__] = temp; +/* L260: */ + } + } + + } + + return 0; + +/* End of DLATM7 */ + +} /* dlatm7_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlatme.c b/lapack-netlib/TESTING/MATGEN/dlatme.c new file mode 100644 index 000000000..973e51a2e --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlatme.c @@ -0,0 +1,1158 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATME */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, */ +/* RSIGN, */ +/* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, */ +/* A, */ +/* LDA, WORK, INFO ) */ + +/* CHARACTER DIST, RSIGN, SIM, UPPER */ +/* INTEGER INFO, KL, KU, LDA, MODE, MODES, N */ +/* DOUBLE PRECISION ANORM, COND, CONDS, DMAX */ +/* CHARACTER EI( * ) */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION A( LDA, * ), D( * ), DS( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATME generates random non-symmetric square matrices with */ +/* > specified eigenvalues for testing LAPACK programs. */ +/* > */ +/* > DLATME operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > 1. Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and RSIGN */ +/* > as described below. */ +/* > */ +/* > 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', */ +/* > or MODE=5), certain pairs of adjacent elements of D are */ +/* > interpreted as the real and complex parts of a complex */ +/* > conjugate pair; A thus becomes block diagonal, with 1x1 */ +/* > and 2x2 blocks. */ +/* > */ +/* > 3. If UPPER='T', the upper triangle of A is set to random values */ +/* > out of distribution DIST. */ +/* > */ +/* > 4. If SIM='T', A is multiplied on the left by a random matrix */ +/* > X, whose singular values are specified by DS, MODES, and */ +/* > CONDS, and on the right by X inverse. */ +/* > */ +/* > 5. If KL < N-1, the lower bandwidth is reduced to KL using */ +/* > Householder transformations. If KU < N-1, the upper */ +/* > bandwidth is reduced to KU. */ +/* > */ +/* > 6. If ANORM is not negative, the matrix is scaled to have */ +/* > maximum-element-norm ANORM. */ +/* > */ +/* > (Note: since the matrix cannot be reduced beyond Hessenberg form, */ +/* > no packing options are available.) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns (or rows) of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values, and for the */ +/* > upper triangle (see UPPER). */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to DLATME */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension ( N ) */ +/* > This array is used to specify the eigenvalues of A. If */ +/* > MODE=0, then D is assumed to contain the eigenvalues (but */ +/* > see the description of EI), otherwise they will be */ +/* > computed according to MODE, COND, DMAX, and RSIGN and */ +/* > placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D (with EI) as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. Each odd-even pair */ +/* > of elements will be either used as two real */ +/* > eigenvalues or as the real and imaginary part */ +/* > of a complex conjugate pair of eigenvalues; */ +/* > the choice of which is done is random, with */ +/* > 50-50 probability, for each pair. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is between 1 and 4, D has entries ranging */ +/* > from 1 to 1/COND, if between -1 and -4, D has entries */ +/* > ranging from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is DOUBLE PRECISION */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is DOUBLE PRECISION */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))). Note that DMAX need not be */ +/* > positive: if DMAX is negative (or zero), D will be */ +/* > scaled by a negative number (or zero). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EI */ +/* > \verbatim */ +/* > EI is CHARACTER*1 array, dimension ( N ) */ +/* > If MODE is 0, and EI(1) is not ' ' (space character), */ +/* > this array specifies which elements of D (on input) are */ +/* > real eigenvalues and which are the real and imaginary parts */ +/* > of a complex conjugate pair of eigenvalues. The elements */ +/* > of EI may then only have the values 'R' and 'I'. If */ +/* > EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is */ +/* > CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex */ +/* > conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th */ +/* > eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', */ +/* > nor may two adjacent elements of EI both have the value 'I'. */ +/* > If MODE is not 0, then EI is ignored. If MODE is 0 and */ +/* > EI(1)=' ', then the eigenvalues will all be real. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RSIGN */ +/* > \verbatim */ +/* > RSIGN is CHARACTER*1 */ +/* > If MODE is not 0, 6, or -6, and RSIGN='T', then the */ +/* > elements of D, as computed according to MODE and COND, will */ +/* > be multiplied by a random sign (+1 or -1). If RSIGN='F', */ +/* > they will not be. RSIGN may only have the values 'T' or */ +/* > 'F'. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPPER */ +/* > \verbatim */ +/* > UPPER is CHARACTER*1 */ +/* > If UPPER='T', then the elements of A above the diagonal */ +/* > (and above the 2x2 diagonal blocks, if A has complex */ +/* > eigenvalues) will be set to random numbers out of DIST. */ +/* > If UPPER='F', they will not. UPPER may only have the */ +/* > values 'T' or 'F'. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIM */ +/* > \verbatim */ +/* > SIM is CHARACTER*1 */ +/* > If SIM='T', then A will be operated on by a "similarity */ +/* > transform", i.e., multiplied on the left by a matrix X and */ +/* > on the right by X inverse. X = U S V, where U and V are */ +/* > random unitary matrices and S is a (diagonal) matrix of */ +/* > singular values specified by DS, MODES, and CONDS. If */ +/* > SIM='F', then A will not be transformed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DS */ +/* > \verbatim */ +/* > DS is DOUBLE PRECISION array, dimension ( N ) */ +/* > This array is used to specify the singular values of X, */ +/* > in the same way that D specifies the eigenvalues of A. */ +/* > If MODE=0, the DS contains the singular values, which */ +/* > may not be zero. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODES */ +/* > \verbatim */ +/* > MODES is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDS */ +/* > \verbatim */ +/* > CONDS is DOUBLE PRECISION */ +/* > Same as MODE and COND, but for specifying the diagonal */ +/* > of S. MODES=-6 and +6 are not allowed (since they would */ +/* > result in randomly ill-conditioned eigenvalues.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. KL=1 */ +/* > specifies upper Hessenberg form. If KL is at least N-1, */ +/* > then A will have full lower bandwidth. KL must be at */ +/* > least 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. KU=1 */ +/* > specifies lower Hessenberg form. If KU is at least N-1, */ +/* > then A will have full upper bandwidth; if KU and KL */ +/* > are both at least N-1, then A will be dense. Only one of */ +/* > KU and KL may be less than N-1. KU must be at least 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is DOUBLE PRECISION */ +/* > If ANORM is not negative, then A will be scaled by a non- */ +/* > negative real number to make the maximum-element-norm of A */ +/* > to be ANORM. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. LDA must be at least N. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension ( 3*N ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => N negative */ +/* > -2 => DIST illegal string */ +/* > -5 => MODE not in range -6 to 6 */ +/* > -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or */ +/* > two adjacent elements of EI are 'I'. */ +/* > -9 => RSIGN is not 'T' or 'F' */ +/* > -10 => UPPER is not 'T' or 'F' */ +/* > -11 => SIM is not 'T' or 'F' */ +/* > -12 => MODES=0 and DS has a zero singular value. */ +/* > -13 => MODES is not in the range -5 to 5. */ +/* > -14 => MODES is nonzero and CONDS is less than 1. */ +/* > -15 => KL is less than 1. */ +/* > -16 => KU is less than 1, or KL and KU are both less than */ +/* > N-1. */ +/* > -19 => LDA is less than N. */ +/* > 1 => Error return from DLATM1 (computing D) */ +/* > 2 => Cannot scale to DMAX (f2cmax. eigenvalue is 0) */ +/* > 3 => Error return from DLATM1 (computing DS) */ +/* > 4 => Error return from DLARGE */ +/* > 5 => Zero singular value from DLATM1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlatme_(integer *n, char *dist, integer *iseed, + doublereal *d__, integer *mode, doublereal *cond, doublereal *dmax__, + char *ei, char *rsign, char *upper, char *sim, doublereal *ds, + integer *modes, doublereal *conds, integer *kl, integer *ku, + doublereal *anorm, doublereal *a, integer *lda, doublereal *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1, d__2, d__3; + + /* Local variables */ + logical bads; + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer isim; + doublereal temp; + logical badei; + integer i__, j; + doublereal alpha; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + integer iinfo; + doublereal tempa[1]; + integer icols; + logical useei; + integer idist; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer irows; + extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *, + integer *, integer *, doublereal *, integer *, integer *); + integer ic, jc; + extern doublereal dlange_(char *, integer *, integer *, doublereal *, + integer *, doublereal *); + integer ir, jr; + extern /* Subroutine */ int dlarge_(integer *, doublereal *, integer *, + integer *, doublereal *, integer *), dlarfg_(integer *, + doublereal *, doublereal *, integer *, doublereal *); + extern doublereal dlaran_(integer *); + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *), dlarnv_(integer *, integer *, + integer *, doublereal *); + integer irsign, iupper; + doublereal xnorms; + integer jcr; + doublereal tau; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + --ei; + --ds; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Check EI */ + + useei = TRUE_; + badei = FALSE_; + if (lsame_(ei + 1, " ") || *mode != 0) { + useei = FALSE_; + } else { + if (lsame_(ei + 1, "R")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + if (lsame_(ei + j, "I")) { + if (lsame_(ei + (j - 1), "I")) { + badei = TRUE_; + } + } else { + if (! lsame_(ei + j, "R")) { + badei = TRUE_; + } + } +/* L10: */ + } + } else { + badei = TRUE_; + } + } + +/* Decode RSIGN */ + + if (lsame_(rsign, "T")) { + irsign = 1; + } else if (lsame_(rsign, "F")) { + irsign = 0; + } else { + irsign = -1; + } + +/* Decode UPPER */ + + if (lsame_(upper, "T")) { + iupper = 1; + } else if (lsame_(upper, "F")) { + iupper = 0; + } else { + iupper = -1; + } + +/* Decode SIM */ + + if (lsame_(sim, "T")) { + isim = 1; + } else if (lsame_(sim, "F")) { + isim = 0; + } else { + isim = -1; + } + +/* Check DS, if MODES=0 and ISIM=1 */ + + bads = FALSE_; + if (*modes == 0 && isim == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (ds[j] == 0.) { + bads = TRUE_; + } +/* L20: */ + } + } + +/* Set INFO if an error */ + + if (*n < 0) { + *info = -1; + } else if (idist == -1) { + *info = -2; + } else if (abs(*mode) > 6) { + *info = -5; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) { + *info = -6; + } else if (badei) { + *info = -8; + } else if (irsign == -1) { + *info = -9; + } else if (iupper == -1) { + *info = -10; + } else if (isim == -1) { + *info = -11; + } else if (bads) { + *info = -12; + } else if (isim == 1 && abs(*modes) > 5) { + *info = -13; + } else if (isim == 1 && *modes != 0 && *conds < 1.) { + *info = -14; + } else if (*kl < 1) { + *info = -15; + } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) { + *info = -16; + } else if (*lda < f2cmax(1,*n)) { + *info = -19; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLATME", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L30: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up diagonal of A */ + +/* Compute D according to COND and MODE */ + + dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L40: */ + } + + if (temp > 0.) { + alpha = *dmax__ / temp; + } else if (*dmax__ != 0.) { + *info = 2; + return 0; + } else { + alpha = 0.; + } + + dscal_(n, &alpha, &d__[1], &c__1); + + } + + dlaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda); + i__1 = *lda + 1; + dcopy_(n, &d__[1], &c__1, &a[a_offset], &i__1); + +/* Set up complex conjugate pairs */ + + if (*mode == 0) { + if (useei) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + if (lsame_(ei + j, "I")) { + a[j - 1 + j * a_dim1] = a[j + j * a_dim1]; + a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1]; + a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1]; + } +/* L50: */ + } + } + + } else if (abs(*mode) == 5) { + + i__1 = *n; + for (j = 2; j <= i__1; j += 2) { + if (dlaran_(&iseed[1]) > .5) { + a[j - 1 + j * a_dim1] = a[j + j * a_dim1]; + a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1]; + a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1]; + } +/* L60: */ + } + } + +/* 3) If UPPER='T', set upper triangle of A to random numbers. */ +/* (but don't modify the corners of 2x2 blocks.) */ + + if (iupper != 0) { + i__1 = *n; + for (jc = 2; jc <= i__1; ++jc) { + if (a[jc - 1 + jc * a_dim1] != 0.) { + jr = jc - 2; + } else { + jr = jc - 1; + } + dlarnv_(&idist, &iseed[1], &jr, &a[jc * a_dim1 + 1]); +/* L70: */ + } + } + +/* 4) If SIM='T', apply similarity transformation. */ + +/* -1 */ +/* Transform is X A X , where X = U S V, thus */ + +/* it is U S V A V' (1/S) U' */ + + if (isim != 0) { + +/* Compute S (singular values of the eigenvector matrix) */ +/* according to CONDS and MODES */ + + dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo); + if (iinfo != 0) { + *info = 3; + return 0; + } + +/* Multiply by V and V' */ + + dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo); + if (iinfo != 0) { + *info = 4; + return 0; + } + +/* Multiply by S and (1/S) */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(n, &ds[j], &a[j + a_dim1], lda); + if (ds[j] != 0.) { + d__1 = 1. / ds[j]; + dscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1); + } else { + *info = 5; + return 0; + } +/* L80: */ + } + +/* Multiply by U and U' */ + + dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo); + if (iinfo != 0) { + *info = 4; + return 0; + } + } + +/* 5) Reduce the bandwidth. */ + + if (*kl < *n - 1) { + +/* Reduce bandwidth -- kill column */ + + i__1 = *n - 1; + for (jcr = *kl + 1; jcr <= i__1; ++jcr) { + ic = jcr - *kl; + irows = *n + 1 - jcr; + icols = *n + *kl - jcr; + + dcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1); + xnorms = work[1]; + dlarfg_(&irows, &xnorms, &work[2], &c__1, &tau); + work[1] = 1.; + + dgemv_("T", &irows, &icols, &c_b39, &a[jcr + (ic + 1) * a_dim1], + lda, &work[1], &c__1, &c_b23, &work[irows + 1], &c__1); + d__1 = -tau; + dger_(&irows, &icols, &d__1, &work[1], &c__1, &work[irows + 1], & + c__1, &a[jcr + (ic + 1) * a_dim1], lda); + + dgemv_("N", n, &irows, &c_b39, &a[jcr * a_dim1 + 1], lda, &work[1] + , &c__1, &c_b23, &work[irows + 1], &c__1); + d__1 = -tau; + dger_(n, &irows, &d__1, &work[irows + 1], &c__1, &work[1], &c__1, + &a[jcr * a_dim1 + 1], lda); + + a[jcr + ic * a_dim1] = xnorms; + i__2 = irows - 1; + dlaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a[jcr + 1 + ic * + a_dim1], lda); +/* L90: */ + } + } else if (*ku < *n - 1) { + +/* Reduce upper bandwidth -- kill a row at a time. */ + + i__1 = *n - 1; + for (jcr = *ku + 1; jcr <= i__1; ++jcr) { + ir = jcr - *ku; + irows = *n + *ku - jcr; + icols = *n + 1 - jcr; + + dcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1); + xnorms = work[1]; + dlarfg_(&icols, &xnorms, &work[2], &c__1, &tau); + work[1] = 1.; + + dgemv_("N", &irows, &icols, &c_b39, &a[ir + 1 + jcr * a_dim1], + lda, &work[1], &c__1, &c_b23, &work[icols + 1], &c__1); + d__1 = -tau; + dger_(&irows, &icols, &d__1, &work[icols + 1], &c__1, &work[1], & + c__1, &a[ir + 1 + jcr * a_dim1], lda); + + dgemv_("C", &icols, n, &c_b39, &a[jcr + a_dim1], lda, &work[1], & + c__1, &c_b23, &work[icols + 1], &c__1); + d__1 = -tau; + dger_(&icols, n, &d__1, &work[1], &c__1, &work[icols + 1], &c__1, + &a[jcr + a_dim1], lda); + + a[ir + jcr * a_dim1] = xnorms; + i__2 = icols - 1; + dlaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a[ir + (jcr + 1) * + a_dim1], lda); +/* L100: */ + } + } + +/* Scale the matrix to have norm ANORM */ + + if (*anorm >= 0.) { + temp = dlange_("M", n, n, &a[a_offset], lda, tempa); + if (temp > 0.) { + alpha = *anorm / temp; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(n, &alpha, &a[j * a_dim1 + 1], &c__1); +/* L110: */ + } + } + } + + return 0; + +/* End of DLATME */ + +} /* dlatme_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlatmr.c b/lapack-netlib/TESTING/MATGEN/dlatmr.c new file mode 100644 index 000000000..962cf026f --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlatmr.c @@ -0,0 +1,1768 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATMR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, */ +/* CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, */ +/* PACK, A, LDA, IWORK, INFO ) */ + +/* CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N */ +/* DOUBLE PRECISION ANORM, COND, CONDL, CONDR, DMAX, SPARSE */ +/* INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATMR generates random matrices of various types for testing */ +/* > LAPACK programs. */ +/* > */ +/* > DLATMR operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Generate a matrix A with random entries of distribution DIST */ +/* > which is symmetric if SYM='S', and nonsymmetric */ +/* > if SYM='N'. */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX and RSIGN */ +/* > as described below. */ +/* > */ +/* > Grade the matrix, if desired, from the left and/or right */ +/* > as specified by GRADE. The inputs DL, MODEL, CONDL, DR, */ +/* > MODER and CONDR also determine the grading as described */ +/* > below. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > PIVTNG and IPIVOT. */ +/* > */ +/* > Set random entries to zero, if desired, to get a random sparse */ +/* > matrix as specified by SPARSE. */ +/* > */ +/* > Make A a band matrix, if desired, by zeroing out the matrix */ +/* > outside a band of lower bandwidth KL and upper bandwidth KU. */ +/* > */ +/* > Scale A, if desired, to have maximum entry ANORM. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if symmetric) */ +/* > zero out lower half (if symmetric) */ +/* > store the upper half columnwise (if symmetric or */ +/* > square upper triangular) */ +/* > store the lower half columnwise (if symmetric or */ +/* > square lower triangular) */ +/* > same as upper half rowwise if symmetric */ +/* > store the lower triangle in banded format (if symmetric) */ +/* > store the upper triangle in banded format (if symmetric) */ +/* > store the entire matrix in banded format */ +/* > */ +/* > Note: If two calls to DLATMR differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > */ +/* > If two calls to DLATMR both have full bandwidth (KL = M-1 */ +/* > and KU = N-1), and differ only in the PIVTNG and PACK */ +/* > parameters, then the matrices generated will differ only */ +/* > in the order of the rows and/or columns, and otherwise */ +/* > contain the same data. This consistency cannot be and */ +/* > is not maintained with less than full bandwidth. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate a random matrix . */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to DLATMR */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='S' or 'H', generated matrix is symmetric. */ +/* > If SYM='N', generated matrix is nonsymmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */ +/* > On entry this array specifies the diagonal entries */ +/* > of the diagonal of A. D may either be specified */ +/* > on entry, or set according to MODE and COND as described */ +/* > below. May be changed on exit if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry describes how D is to be used: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is DOUBLE PRECISION */ +/* > On entry, used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is DOUBLE PRECISION */ +/* > If MODE neither -6, 0 nor 6, the diagonal is scaled by */ +/* > DMAX / f2cmax(abs(D(i))), so that maximum absolute entry */ +/* > of diagonal is abs(DMAX). If DMAX is negative (or zero), */ +/* > diagonal will be scaled by a negative number (or zero). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RSIGN */ +/* > \verbatim */ +/* > RSIGN is CHARACTER*1 */ +/* > If MODE neither -6, 0 nor 6, specifies sign of diagonal */ +/* > as follows: */ +/* > 'T' => diagonal entries are multiplied by 1 or -1 */ +/* > with probability .5 */ +/* > 'F' => diagonal unchanged */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GRADE */ +/* > \verbatim */ +/* > GRADE is CHARACTER*1 */ +/* > Specifies grading of matrix as follows: */ +/* > 'N' => no grading */ +/* > 'L' => matrix premultiplied by diag( DL ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'R' => matrix postmultiplied by diag( DR ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'B' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'S' or 'H' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > ('S' for symmetric, or 'H' for Hermitian) */ +/* > 'E' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > ( 'E' for eigenvalue invariance) */ +/* > (only if matrix nonsymmetric) */ +/* > Note: if GRADE='E', then M must equal N. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DL */ +/* > \verbatim */ +/* > DL is DOUBLE PRECISION array, dimension (M) */ +/* > If MODEL=0, then on entry this array specifies the diagonal */ +/* > entries of a diagonal matrix used as described under GRADE */ +/* > above. If MODEL is not zero, then DL will be set according */ +/* > to MODEL and CONDL, analogous to the way D is set according */ +/* > to MODE and COND (except there is no DMAX parameter for DL). */ +/* > If GRADE='E', then DL cannot have zero entries. */ +/* > Not referenced if GRADE = 'N' or 'R'. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODEL */ +/* > \verbatim */ +/* > MODEL is INTEGER */ +/* > This specifies how the diagonal array DL is to be computed, */ +/* > just as MODE specifies how D is to be computed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDL */ +/* > \verbatim */ +/* > CONDL is DOUBLE PRECISION */ +/* > When MODEL is not zero, this specifies the condition number */ +/* > of the computed DL. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DR */ +/* > \verbatim */ +/* > DR is DOUBLE PRECISION array, dimension (N) */ +/* > If MODER=0, then on entry this array specifies the diagonal */ +/* > entries of a diagonal matrix used as described under GRADE */ +/* > above. If MODER is not zero, then DR will be set according */ +/* > to MODER and CONDR, analogous to the way D is set according */ +/* > to MODE and COND (except there is no DMAX parameter for DR). */ +/* > Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODER */ +/* > \verbatim */ +/* > MODER is INTEGER */ +/* > This specifies how the diagonal array DR is to be computed, */ +/* > just as MODE specifies how D is to be computed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDR */ +/* > \verbatim */ +/* > CONDR is DOUBLE PRECISION */ +/* > When MODER is not zero, this specifies the condition number */ +/* > of the computed DR. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVTNG */ +/* > \verbatim */ +/* > PIVTNG is CHARACTER*1 */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 'N' or ' ' => none. */ +/* > 'L' => left or row pivoting (matrix must be nonsymmetric). */ +/* > 'R' => right or column pivoting (matrix must be */ +/* > nonsymmetric). */ +/* > 'B' or 'F' => both or full pivoting, i.e., on both sides. */ +/* > In this case, M must equal N */ +/* > */ +/* > If two calls to DLATMR both have full bandwidth (KL = M-1 */ +/* > and KU = N-1), and differ only in the PIVTNG and PACK */ +/* > parameters, then the matrices generated will differ only */ +/* > in the order of the rows and/or columns, and otherwise */ +/* > contain the same data. This consistency cannot be */ +/* > maintained with less than full bandwidth. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIVOT */ +/* > \verbatim */ +/* > IPIVOT is INTEGER array, dimension (N or M) */ +/* > This array specifies the permutation used. After the */ +/* > basic matrix is generated, the rows, columns, or both */ +/* > are permuted. If, say, row pivoting is selected, DLATMR */ +/* > starts with the *last* row and interchanges the M-th and */ +/* > IPIVOT(M)-th rows, then moves to the next-to-last row, */ +/* > interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, */ +/* > and so on. In terms of "2-cycles", the permutation is */ +/* > (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) */ +/* > where the rightmost cycle is applied first. This is the */ +/* > *inverse* of the effect of pivoting in LINPACK. The idea */ +/* > is that factoring (with pivoting) an identity matrix */ +/* > which has been inverse-pivoted in this way should */ +/* > result in a pivot vector identical to IPIVOT. */ +/* > Not referenced if PIVTNG = 'N'. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > On entry specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL at least M-1 implies the matrix is not */ +/* > banded. Must equal KU if matrix is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > On entry specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU at least N-1 implies the matrix is not */ +/* > banded. Must equal KL if matrix is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is DOUBLE PRECISION */ +/* > On entry specifies the sparsity of the matrix if a sparse */ +/* > matrix is to be generated. SPARSE should lie between */ +/* > 0 and 1. To generate a sparse matrix, for each matrix entry */ +/* > a uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is DOUBLE PRECISION */ +/* > On entry specifies maximum entry of output matrix */ +/* > (output matrix will by multiplied by a constant so that */ +/* > its largest absolute entry equal ANORM) */ +/* > if ANORM is nonnegative. If ANORM is negative no scaling */ +/* > is done. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > On entry specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries (if symmetric) */ +/* > 'L' => zero out all superdiagonal entries (if symmetric) */ +/* > 'C' => store the upper triangle columnwise */ +/* > (only if matrix symmetric or square upper triangular) */ +/* > 'R' => store the lower triangle columnwise */ +/* > (only if matrix symmetric or square lower triangular) */ +/* > (same as upper half rowwise if symmetric) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if matrix symmetric) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if matrix symmetric) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, SB or TB - use 'B' or 'Q' */ +/* > PP, SP or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to DLATMR differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On exit A is the desired test matrix. Only those */ +/* > entries of A which are significant on output */ +/* > will be referenced (even if A is in packed or band */ +/* > storage format). The 'unoccupied corners' of A in */ +/* > band format will be zeroed out. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > on entry LDA specifies the first dimension of A as */ +/* > declared in the calling program. */ +/* > If PACK='N', 'U' or 'L', LDA must be at least f2cmax ( 1, M ). */ +/* > If PACK='C' or 'R', LDA must be at least 1. */ +/* > If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) */ +/* > If PACK='Z', LDA must be at least KUU+KLL+1, where */ +/* > KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, M-1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension ( N or M) */ +/* > Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error parameter on exit: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S' or 'H' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string */ +/* > -11 => GRADE illegal string, or GRADE='E' and */ +/* > M not equal to N, or GRADE='L', 'R', 'B' or 'E' and */ +/* > SYM = 'S' or 'H' */ +/* > -12 => GRADE = 'E' and DL contains zero */ +/* > -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', */ +/* > 'S' or 'E' */ +/* > -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', */ +/* > and MODEL neither -6, 0 nor 6 */ +/* > -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' */ +/* > -17 => CONDR less than 1.0, GRADE='R' or 'B', and */ +/* > MODER neither -6, 0 nor 6 */ +/* > -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and */ +/* > M not equal to N, or PIVTNG='L' or 'R' and SYM='S' */ +/* > or 'H' */ +/* > -19 => IPIVOT contains out of range number and */ +/* > PIVTNG not equal to 'N' */ +/* > -20 => KL negative */ +/* > -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL */ +/* > -22 => SPARSE not in range 0. to 1. */ +/* > -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' */ +/* > and SYM='N', or PACK='C' and SYM='N' and either KL */ +/* > not equal to 0 or N not equal to M, or PACK='R' and */ +/* > SYM='N', and either KU not equal to 0 or N not equal */ +/* > to M */ +/* > -26 => LDA too small */ +/* > 1 => Error return from DLATM1 (computing D) */ +/* > 2 => Cannot scale diagonal to DMAX (f2cmax. entry is 0) */ +/* > 3 => Error return from DLATM1 (computing DL) */ +/* > 4 => Error return from DLATM1 (computing DR) */ +/* > 5 => ANORM is positive, but matrix constructed prior to */ +/* > attempting to scale it to have norm ANORM, is zero */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlatmr_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond, + doublereal *dmax__, char *rsign, char *grade, doublereal *dl, integer + *model, doublereal *condl, doublereal *dr, integer *moder, doublereal + *condr, char *pivtng, integer *ipivot, integer *kl, integer *ku, + doublereal *sparse, doublereal *anorm, char *pack, doublereal *a, + integer *lda, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer isub, jsub; + doublereal temp; + integer isym, i__, j, k; + doublereal alpha; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + integer ipack; + extern logical lsame_(char *, char *); + doublereal tempa[1]; + integer iisub, idist, jjsub, mnmin; + logical dzero; + integer mnsub; + doublereal onorm; + integer mxsub, npvts; + extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *, + integer *, integer *, doublereal *, integer *, integer *); + extern doublereal dlatm2_(integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, doublereal *, integer + *, doublereal *, doublereal *, integer *, integer *, doublereal *) + , dlatm3_(integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, doublereal + *, integer *, doublereal *, doublereal *, integer *, integer *, + doublereal *), dlangb_(char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *), dlange_(char *, + integer *, integer *, doublereal *, integer *, doublereal *); + integer igrade; + extern doublereal dlansb_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); + logical fulbnd; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical badpvt; + extern doublereal dlansp_(char *, char *, integer *, doublereal *, + doublereal *), dlansy_(char *, char *, integer *, + doublereal *, integer *, doublereal *); + integer irsign, ipvtng, kll, kuu; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + --dl; + --dr; + --ipivot; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iwork; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "S")) { + isym = 0; + } else if (lsame_(sym, "N")) { + isym = 1; + } else if (lsame_(sym, "H")) { + isym = 0; + } else { + isym = -1; + } + +/* Decode RSIGN */ + + if (lsame_(rsign, "F")) { + irsign = 0; + } else if (lsame_(rsign, "T")) { + irsign = 1; + } else { + irsign = -1; + } + +/* Decode PIVTNG */ + + if (lsame_(pivtng, "N")) { + ipvtng = 0; + } else if (lsame_(pivtng, " ")) { + ipvtng = 0; + } else if (lsame_(pivtng, "L")) { + ipvtng = 1; + npvts = *m; + } else if (lsame_(pivtng, "R")) { + ipvtng = 2; + npvts = *n; + } else if (lsame_(pivtng, "B")) { + ipvtng = 3; + npvts = f2cmin(*n,*m); + } else if (lsame_(pivtng, "F")) { + ipvtng = 3; + npvts = f2cmin(*n,*m); + } else { + ipvtng = -1; + } + +/* Decode GRADE */ + + if (lsame_(grade, "N")) { + igrade = 0; + } else if (lsame_(grade, "L")) { + igrade = 1; + } else if (lsame_(grade, "R")) { + igrade = 2; + } else if (lsame_(grade, "B")) { + igrade = 3; + } else if (lsame_(grade, "E")) { + igrade = 4; + } else if (lsame_(grade, "H") || lsame_(grade, + "S")) { + igrade = 5; + } else { + igrade = -1; + } + +/* Decode PACK */ + + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + } else if (lsame_(pack, "C")) { + ipack = 3; + } else if (lsame_(pack, "R")) { + ipack = 4; + } else if (lsame_(pack, "B")) { + ipack = 5; + } else if (lsame_(pack, "Q")) { + ipack = 6; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + kll = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + kuu = f2cmin(i__1,i__2); + +/* If inv(DL) is used, check to see if DL has a zero entry. */ + + dzero = FALSE_; + if (igrade == 4 && *model == 0) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (dl[i__] == 0.) { + dzero = TRUE_; + } +/* L10: */ + } + } + +/* Check values in IPIVOT */ + + badpvt = FALSE_; + if (ipvtng > 0) { + i__1 = npvts; + for (j = 1; j <= i__1; ++j) { + if (ipivot[j] <= 0 || ipivot[j] > npvts) { + badpvt = TRUE_; + } +/* L20: */ + } + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && isym == 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (*mode < -6 || *mode > 6) { + *info = -7; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) { + *info = -8; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) { + *info = -10; + } else if (igrade == -1 || igrade == 4 && *m != *n || igrade >= 1 && + igrade <= 4 && isym == 0) { + *info = -11; + } else if (igrade == 4 && dzero) { + *info = -12; + } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && ( + *model < -6 || *model > 6)) { + *info = -13; + } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && ( + *model != -6 && *model != 0 && *model != 6) && *condl < 1.) { + *info = -14; + } else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) { + *info = -16; + } else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 && + *moder != 6) && *condr < 1.) { + *info = -17; + } else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 || + ipvtng == 2) && isym == 0) { + *info = -18; + } else if (ipvtng != 0 && badpvt) { + *info = -19; + } else if (*kl < 0) { + *info = -20; + } else if (*ku < 0 || isym == 0 && *kl != *ku) { + *info = -21; + } else if (*sparse < 0. || *sparse > 1.) { + *info = -22; + } else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 || + ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0 + || *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n)) + { + *info = -24; + } else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < f2cmax(1,*m) || + (ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack == + 6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) { + *info = -26; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLATMR", &i__1); + return 0; + } + +/* Decide if we can pivot consistently */ + + fulbnd = FALSE_; + if (kuu == *n - 1 && kll == *m - 1) { + fulbnd = TRUE_; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L30: */ + } + + iseed[4] = (iseed[4] / 2 << 1) + 1; + +/* 2) Set up D, DL, and DR, if indicated. */ + +/* Compute D according to COND and MODE */ + + dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info); + if (*info != 0) { + *info = 1; + return 0; + } + if (*mode != 0 && *mode != -6 && *mode != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = mnmin; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L40: */ + } + if (temp == 0. && *dmax__ != 0.) { + *info = 2; + return 0; + } + if (temp != 0.) { + alpha = *dmax__ / temp; + } else { + alpha = 1.; + } + i__1 = mnmin; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = alpha * d__[i__]; +/* L50: */ + } + + } + +/* Compute DL if grading set */ + + if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) { + dlatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info); + if (*info != 0) { + *info = 3; + return 0; + } + } + +/* Compute DR if grading set */ + + if (igrade == 2 || igrade == 3) { + dlatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info); + if (*info != 0) { + *info = 4; + return 0; + } + } + +/* 3) Generate IWORK if pivoting */ + + if (ipvtng > 0) { + i__1 = npvts; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = i__; +/* L60: */ + } + if (fulbnd) { + i__1 = npvts; + for (i__ = 1; i__ <= i__1; ++i__) { + k = ipivot[i__]; + j = iwork[i__]; + iwork[i__] = iwork[k]; + iwork[k] = j; +/* L70: */ + } + } else { + for (i__ = npvts; i__ >= 1; --i__) { + k = ipivot[i__]; + j = iwork[i__]; + iwork[i__] = iwork[k]; + iwork[k] = j; +/* L80: */ + } + } + } + +/* 4) Generate matrices for each kind of PACKing */ +/* Always sweep matrix columnwise (if symmetric, upper */ +/* half only) so that matrix generated does not depend */ +/* on PACK */ + + if (fulbnd) { + +/* Use DLATM3 so matrices generated with differing PIVOTing only */ +/* differ only in the order of their rows and/or columns. */ + + if (ipack == 0) { + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + a[isub + jsub * a_dim1] = temp; + a[jsub + isub * a_dim1] = temp; +/* L90: */ + } +/* L100: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + a[isub + jsub * a_dim1] = temp; +/* L110: */ + } +/* L120: */ + } + } + + } else if (ipack == 1) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + a[mnsub + mxsub * a_dim1] = temp; + if (mnsub != mxsub) { + a[mxsub + mnsub * a_dim1] = 0.; + } +/* L130: */ + } +/* L140: */ + } + + } else if (ipack == 2) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + a[mxsub + mnsub * a_dim1] = temp; + if (mnsub != mxsub) { + a[mnsub + mxsub * a_dim1] = 0.; + } +/* L150: */ + } +/* L160: */ + } + + } else if (ipack == 3) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + +/* Compute K = location of (ISUB,JSUB) entry in packed */ +/* array */ + + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + k = mxsub * (mxsub - 1) / 2 + mnsub; + +/* Convert K to (IISUB,JJSUB) location */ + + jjsub = (k - 1) / *lda + 1; + iisub = k - *lda * (jjsub - 1); + + a[iisub + jjsub * a_dim1] = temp; +/* L170: */ + } +/* L180: */ + } + + } else if (ipack == 4) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + +/* Compute K = location of (I,J) entry in packed array */ + + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mnsub == 1) { + k = mxsub; + } else { + k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n - + mnsub + 2) / 2 + mxsub - mnsub + 1; + } + +/* Convert K to (IISUB,JJSUB) location */ + + jjsub = (k - 1) / *lda + 1; + iisub = k - *lda * (jjsub - 1); + + a[iisub + jjsub * a_dim1] = temp; +/* L190: */ + } +/* L200: */ + } + + } else if (ipack == 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + if (i__ < 1) { + a[j - i__ + 1 + (i__ + *n) * a_dim1] = 0.; + } else { + temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + a[mxsub - mnsub + 1 + mnsub * a_dim1] = temp; + } +/* L210: */ + } +/* L220: */ + } + + } else if (ipack == 6) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + a[mnsub - mxsub + kuu + 1 + mxsub * a_dim1] = temp; +/* L230: */ + } +/* L240: */ + } + + } else if (ipack == 7) { + + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + a[mnsub - mxsub + kuu + 1 + mxsub * a_dim1] = temp; + if (i__ < 1) { + a[j - i__ + 1 + kuu + (i__ + *n) * a_dim1] = 0.; + } + if (i__ >= 1 && mnsub != mxsub) { + a[mxsub - mnsub + 1 + kuu + mnsub * a_dim1] = + temp; + } +/* L250: */ + } +/* L260: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + kll; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + temp = dlatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + a[isub - jsub + kuu + 1 + jsub * a_dim1] = temp; +/* L270: */ + } +/* L280: */ + } + } + + } + + } else { + +/* Use DLATM2 */ + + if (ipack == 0) { + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = dlatm2_(m, n, &i__, &j, kl, ku, + &idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + a[j + i__ * a_dim1] = a[i__ + j * a_dim1]; +/* L290: */ + } +/* L300: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = dlatm2_(m, n, &i__, &j, kl, ku, + &idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); +/* L310: */ + } +/* L320: */ + } + } + + } else if (ipack == 1) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = dlatm2_(m, n, &i__, &j, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + if (i__ != j) { + a[j + i__ * a_dim1] = 0.; + } +/* L330: */ + } +/* L340: */ + } + + } else if (ipack == 2) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = dlatm2_(m, n, &i__, &j, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + if (i__ != j) { + a[i__ + j * a_dim1] = 0.; + } +/* L350: */ + } +/* L360: */ + } + + } else if (ipack == 3) { + + isub = 0; + jsub = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++isub; + if (isub > *lda) { + isub = 1; + ++jsub; + } + a[isub + jsub * a_dim1] = dlatm2_(m, n, &i__, &j, kl, ku, + &idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[ + 1], &ipvtng, &iwork[1], sparse); +/* L370: */ + } +/* L380: */ + } + + } else if (ipack == 4) { + + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + +/* Compute K = location of (I,J) entry in packed array */ + + if (i__ == 1) { + k = j; + } else { + k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n - + i__ + 2) / 2 + j - i__ + 1; + } + +/* Convert K to (ISUB,JSUB) location */ + + jsub = (k - 1) / *lda + 1; + isub = k - *lda * (jsub - 1); + + a[isub + jsub * a_dim1] = dlatm2_(m, n, &i__, &j, kl, + ku, &idist, &iseed[1], &d__[1], &igrade, &dl[ + 1], &dr[1], &ipvtng, &iwork[1], sparse); +/* L390: */ + } +/* L400: */ + } + } else { + isub = 0; + jsub = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++isub; + if (isub > *lda) { + isub = 1; + ++jsub; + } + a[isub + jsub * a_dim1] = dlatm2_(m, n, &i__, &j, kl, + ku, &idist, &iseed[1], &d__[1], &igrade, &dl[ + 1], &dr[1], &ipvtng, &iwork[1], sparse); +/* L410: */ + } +/* L420: */ + } + } + + } else if (ipack == 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + if (i__ < 1) { + a[j - i__ + 1 + (i__ + *n) * a_dim1] = 0.; + } else { + a[j - i__ + 1 + i__ * a_dim1] = dlatm2_(m, n, &i__, & + j, kl, ku, &idist, &iseed[1], &d__[1], & + igrade, &dl[1], &dr[1], &ipvtng, &iwork[1], + sparse); + } +/* L430: */ + } +/* L440: */ + } + + } else if (ipack == 6) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + a[i__ - j + kuu + 1 + j * a_dim1] = dlatm2_(m, n, &i__, & + j, kl, ku, &idist, &iseed[1], &d__[1], &igrade, & + dl[1], &dr[1], &ipvtng, &iwork[1], sparse); +/* L450: */ + } +/* L460: */ + } + + } else if (ipack == 7) { + + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + a[i__ - j + kuu + 1 + j * a_dim1] = dlatm2_(m, n, & + i__, &j, kl, ku, &idist, &iseed[1], &d__[1], & + igrade, &dl[1], &dr[1], &ipvtng, &iwork[1], + sparse); + if (i__ < 1) { + a[j - i__ + 1 + kuu + (i__ + *n) * a_dim1] = 0.; + } + if (i__ >= 1 && i__ != j) { + a[j - i__ + 1 + kuu + i__ * a_dim1] = a[i__ - j + + kuu + 1 + j * a_dim1]; + } +/* L470: */ + } +/* L480: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + kll; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + a[i__ - j + kuu + 1 + j * a_dim1] = dlatm2_(m, n, & + i__, &j, kl, ku, &idist, &iseed[1], &d__[1], & + igrade, &dl[1], &dr[1], &ipvtng, &iwork[1], + sparse); +/* L490: */ + } +/* L500: */ + } + } + + } + + } + +/* 5) Scaling the norm */ + + if (ipack == 0) { + onorm = dlange_("M", m, n, &a[a_offset], lda, tempa); + } else if (ipack == 1) { + onorm = dlansy_("M", "U", n, &a[a_offset], lda, tempa); + } else if (ipack == 2) { + onorm = dlansy_("M", "L", n, &a[a_offset], lda, tempa); + } else if (ipack == 3) { + onorm = dlansp_("M", "U", n, &a[a_offset], tempa); + } else if (ipack == 4) { + onorm = dlansp_("M", "L", n, &a[a_offset], tempa); + } else if (ipack == 5) { + onorm = dlansb_("M", "L", n, &kll, &a[a_offset], lda, tempa); + } else if (ipack == 6) { + onorm = dlansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa); + } else if (ipack == 7) { + onorm = dlangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa); + } + + if (*anorm >= 0.) { + + if (*anorm > 0. && onorm == 0.) { + +/* Desired scaling impossible */ + + *info = 5; + return 0; + + } else if (*anorm > 1. && onorm < 1. || *anorm < 1. && onorm > 1.) { + +/* Scale carefully to avoid over / underflow */ + + if (ipack <= 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + d__1 = 1. / onorm; + dscal_(m, &d__1, &a[j * a_dim1 + 1], &c__1); + dscal_(m, anorm, &a[j * a_dim1 + 1], &c__1); +/* L510: */ + } + + } else if (ipack == 3 || ipack == 4) { + + i__1 = *n * (*n + 1) / 2; + d__1 = 1. / onorm; + dscal_(&i__1, &d__1, &a[a_offset], &c__1); + i__1 = *n * (*n + 1) / 2; + dscal_(&i__1, anorm, &a[a_offset], &c__1); + + } else if (ipack >= 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = kll + kuu + 1; + d__1 = 1. / onorm; + dscal_(&i__2, &d__1, &a[j * a_dim1 + 1], &c__1); + i__2 = kll + kuu + 1; + dscal_(&i__2, anorm, &a[j * a_dim1 + 1], &c__1); +/* L520: */ + } + + } + + } else { + +/* Scale straightforwardly */ + + if (ipack <= 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + d__1 = *anorm / onorm; + dscal_(m, &d__1, &a[j * a_dim1 + 1], &c__1); +/* L530: */ + } + + } else if (ipack == 3 || ipack == 4) { + + i__1 = *n * (*n + 1) / 2; + d__1 = *anorm / onorm; + dscal_(&i__1, &d__1, &a[a_offset], &c__1); + + } else if (ipack >= 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = kll + kuu + 1; + d__1 = *anorm / onorm; + dscal_(&i__2, &d__1, &a[j * a_dim1 + 1], &c__1); +/* L540: */ + } + } + + } + + } + +/* End of DLATMR */ + + return 0; +} /* dlatmr_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlatms.c b/lapack-netlib/TESTING/MATGEN/dlatms.c new file mode 100644 index 000000000..609e1d450 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlatms.c @@ -0,0 +1,1769 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATMS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* KL, KU, PACK, A, LDA, WORK, INFO ) */ + +/* CHARACTER DIST, PACK, SYM */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, N */ +/* DOUBLE PRECISION COND, DMAX */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATMS generates random matrices with specified singular values */ +/* > (or symmetric/hermitian with specified eigenvalues) */ +/* > for testing LAPACK programs. */ +/* > */ +/* > DLATMS operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and SYM */ +/* > as described below. */ +/* > */ +/* > Generate a matrix with the appropriate band structure, by one */ +/* > of two methods: */ +/* > */ +/* > Method A: */ +/* > Generate a dense M x N matrix by multiplying D on the left */ +/* > and the right by random unitary matrices, then: */ +/* > */ +/* > Reduce the bandwidth according to KL and KU, using */ +/* > Householder transformations. */ +/* > */ +/* > Method B: */ +/* > Convert the bandwidth-0 (i.e., diagonal) matrix to a */ +/* > bandwidth-1 matrix using Givens rotations, "chasing" */ +/* > out-of-band elements back, much as in QR; then */ +/* > convert the bandwidth-1 to a bandwidth-2 matrix, etc. */ +/* > Note that for reasonably small bandwidths (relative to */ +/* > M and N) this requires less storage, as a dense matrix */ +/* > is not generated. Also, for symmetric matrices, only */ +/* > one triangle is generated. */ +/* > */ +/* > Method A is chosen if the bandwidth is a large fraction of the */ +/* > order of the matrix, and LDA is at least M (so a dense */ +/* > matrix can be stored.) Method B is chosen if the bandwidth */ +/* > is small (< 1/2 N for symmetric, < .3 N+M for */ +/* > non-symmetric), or LDA is less than M and not less than the */ +/* > bandwidth. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if symmetric) */ +/* > zero out lower half (if symmetric) */ +/* > store the upper half columnwise (if symmetric or upper */ +/* > triangular) */ +/* > store the lower half columnwise (if symmetric or lower */ +/* > triangular) */ +/* > store the lower triangle in banded format (if symmetric */ +/* > or lower triangular) */ +/* > store the upper triangle in banded format (if symmetric */ +/* > or upper triangular) */ +/* > store the entire matrix in banded format */ +/* > If Method B is chosen, and band format is specified, then the */ +/* > matrix will be generated in the band format, so no repacking */ +/* > will be necessary. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values. */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to DLATMS */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='S' or 'H', the generated matrix is symmetric, with */ +/* > eigenvalues specified by D, COND, MODE, and DMAX; they */ +/* > may be positive, negative, or zero. */ +/* > If SYM='P', the generated matrix is symmetric, with */ +/* > eigenvalues (= singular values) specified by D, COND, */ +/* > MODE, and DMAX; they will not be negative. */ +/* > If SYM='N', the generated matrix is nonsymmetric, with */ +/* > singular values specified by D, COND, MODE, and DMAX; */ +/* > they will not be negative. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension ( MIN( M , N ) ) */ +/* > This array is used to specify the singular values or */ +/* > eigenvalues of A (see SYM, above.) If MODE=0, then D is */ +/* > assumed to contain the singular/eigenvalues, otherwise */ +/* > they will be computed according to MODE, COND, and DMAX, */ +/* > and placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the singular/eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then */ +/* > the elements of D will also be multiplied by a random */ +/* > sign (i.e., +1 or -1.) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is DOUBLE PRECISION */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is DOUBLE PRECISION */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))); thus, the maximum absolute eigen- or */ +/* > singular value (which is to say the norm) will be abs(DMAX). */ +/* > Note that DMAX need not be positive: if DMAX is negative */ +/* > (or zero), D will be scaled by a negative number (or zero). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL being at least M-1 means that the matrix */ +/* > has full lower bandwidth. KL must equal KU if the matrix */ +/* > is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU being at least N-1 means that the matrix */ +/* > has full upper bandwidth. KL must equal KU if the matrix */ +/* > is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > This specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries (if symmetric) */ +/* > 'L' => zero out all superdiagonal entries (if symmetric) */ +/* > 'C' => store the upper triangle columnwise */ +/* > (only if the matrix is symmetric or upper triangular) */ +/* > 'R' => store the lower triangle columnwise */ +/* > (only if the matrix is symmetric or lower triangular) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if matrix symmetric or lower triangular) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if matrix symmetric or upper triangular) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, SB or TB - use 'B' or 'Q' */ +/* > PP, SP or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to DLATMS differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. A is first generated */ +/* > in full (unpacked) form, and then packed, if so specified */ +/* > by PACK. Thus, the first M elements of the first N */ +/* > columns will always be modified. If PACK specifies a */ +/* > packed or banded storage scheme, all LDA elements of the */ +/* > first N columns will be modified; the elements of the */ +/* > array which do not correspond to elements of the generated */ +/* > matrix are set to zero. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */ +/* > LDA must be at least M. If PACK='B' or 'Q', then LDA must */ +/* > be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */ +/* > If PACK='Z', LDA must be large enough to hold the packed */ +/* > array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension ( 3*MAX( N , M ) ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => KL negative */ +/* > -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL */ +/* > -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */ +/* > or PACK='C' or 'Q' and SYM='N' and KL is not zero; */ +/* > or PACK='R' or 'B' and SYM='N' and KU is not zero; */ +/* > or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */ +/* > N. */ +/* > -14 => LDA is less than M, or PACK='Z' and LDA is less than */ +/* > MIN(KU,N-1) + MIN(KL,M-1) + 1. */ +/* > 1 => Error return from DLATM1 */ +/* > 2 => Cannot scale to DMAX (f2cmax. sing. value is 0) */ +/* > 3 => Error return from DLAGGE or SLAGSY */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlatms_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond, + doublereal *dmax__, integer *kl, integer *ku, char *pack, doublereal * + a, integer *lda, doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1, d__2, d__3; + logical L__1; + + /* Local variables */ + integer ilda, icol; + doublereal temp; + integer irow, isym; + doublereal c__; + integer i__, j, k; + doublereal s, alpha, angle; + integer ipack; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + integer ioffg; + extern logical lsame_(char *, char *); + integer iinfo, idist, mnmin; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer iskew; + doublereal extra, dummy; + extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *, + integer *, integer *, doublereal *, integer *, integer *); + integer ic, jc, nc; + extern /* Subroutine */ int dlagge_(integer *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, integer *, + doublereal *, integer *); + integer il, iendch, ir, jr, ipackg, mr, minlda; + extern doublereal dlarnd_(integer *, integer *); + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), xerbla_(char *, integer *), dlagsy_( + integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *), dlarot_(logical *, logical *, + logical *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, doublereal *); + logical iltemp, givens; + integer ioffst, irsign; + logical ilextr, topdwn; + integer ir1, ir2, isympk, jch, llb, jkl, jku, uub; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "N")) { + isym = 1; + irsign = 0; + } else if (lsame_(sym, "P")) { + isym = 2; + irsign = 0; + } else if (lsame_(sym, "S")) { + isym = 2; + irsign = 1; + } else if (lsame_(sym, "H")) { + isym = 2; + irsign = 1; + } else { + isym = -1; + } + +/* Decode PACK */ + + isympk = 0; + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + isympk = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + isympk = 1; + } else if (lsame_(pack, "C")) { + ipack = 3; + isympk = 2; + } else if (lsame_(pack, "R")) { + ipack = 4; + isympk = 3; + } else if (lsame_(pack, "B")) { + ipack = 5; + isympk = 3; + } else if (lsame_(pack, "Q")) { + ipack = 6; + isympk = 2; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + llb = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + uub = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *m, i__2 = *n + llb; + mr = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *n, i__2 = *m + uub; + nc = f2cmin(i__1,i__2); + + if (ipack == 5 || ipack == 6) { + minlda = uub + 1; + } else if (ipack == 7) { + minlda = llb + uub + 1; + } else { + minlda = *m; + } + +/* Use Givens rotation method if bandwidth small enough, */ +/* or if LDA is too small to store the matrix unpacked. */ + + givens = FALSE_; + if (isym == 1) { +/* Computing MAX */ + i__1 = 1, i__2 = mr + nc; + if ((doublereal) (llb + uub) < (doublereal) f2cmax(i__1,i__2) * .3) { + givens = TRUE_; + } + } else { + if (llb << 1 < *m) { + givens = TRUE_; + } + } + if (*lda < *m && *lda >= minlda) { + givens = TRUE_; + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && isym != 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (abs(*mode) > 6) { + *info = -7; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) { + *info = -8; + } else if (*kl < 0) { + *info = -10; + } else if (*ku < 0 || isym != 1 && *kl != *ku) { + *info = -11; + } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym + == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk + != 0 && *m != *n) { + *info = -12; + } else if (*lda < f2cmax(1,minlda)) { + *info = -14; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLATMS", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L10: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up D if indicated. */ + +/* Compute D according to COND and MODE */ + + dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, &iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + +/* Choose Top-Down if D is (apparently) increasing, */ +/* Bottom-Up if D is (apparently) decreasing. */ + + if (abs(d__[1]) <= (d__1 = d__[mnmin], abs(d__1))) { + topdwn = TRUE_; + } else { + topdwn = FALSE_; + } + + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = mnmin; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L20: */ + } + + if (temp > 0.) { + alpha = *dmax__ / temp; + } else { + *info = 2; + return 0; + } + + dscal_(&mnmin, &alpha, &d__[1], &c__1); + + } + +/* 3) Generate Banded Matrix using Givens rotations. */ +/* Also the special case of UUB=LLB=0 */ + +/* Compute Addressing constants to cover all */ +/* storage formats. Whether GE, SY, GB, or SB, */ +/* upper or lower triangle or both, */ +/* the (i,j)-th element is in */ +/* A( i - ISKEW*j + IOFFST, j ) */ + + if (ipack > 4) { + ilda = *lda - 1; + iskew = 1; + if (ipack > 5) { + ioffst = uub + 1; + } else { + ioffst = 1; + } + } else { + ilda = *lda; + iskew = 0; + ioffst = 0; + } + +/* IPACKG is the format that the matrix is generated in. If this is */ +/* different from IPACK, then the matrix must be repacked at the */ +/* end. It also signals how to compute the norm, for scaling. */ + + ipackg = 0; + dlaset_("Full", lda, n, &c_b22, &c_b22, &a[a_offset], lda); + +/* Diagonal Matrix -- We are done, unless it */ +/* is to be stored SP/PP/TP (PACK='R' or 'C') */ + + if (llb == 0 && uub == 0) { + i__1 = ilda + 1; + dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &i__1) + ; + if (ipack <= 2 || ipack >= 5) { + ipackg = ipack; + } + + } else if (givens) { + +/* Check whether to use Givens rotations, */ +/* Householder transformations, or nothing. */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + if (ipack > 4) { + ipackg = ipack; + } else { + ipackg = 0; + } + + i__1 = ilda + 1; + dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], & + i__1); + + if (topdwn) { + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* Last row actually rotated is M */ +/* Last column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__3 = *m + jku; + i__2 = f2cmin(i__3,*n) + jkl - 1; + for (jr = 1; jr <= i__2; ++jr) { + extra = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__4 = jr - jkl; + icol = f2cmax(i__3,i__4); + if (jr < *m) { +/* Computing MIN */ + i__3 = *n, i__4 = jr + jku; + il = f2cmin(i__3,i__4) + 1 - icol; + L__1 = jr > jkl; + dlarot_(&c_true, &L__1, &c_false, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ir = jr; + ic = icol; + i__3 = -jkl - jku; + for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ir < *m) { + dlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &c__, & + s, &dummy); + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + temp = 0.; + iltemp = jch > jku; + d__1 = -s; + dlarot_(&c_false, &iltemp, &c_true, &il, &c__, & + d__1, &a[irow - iskew * ic + ioffst + ic * + a_dim1], &ilda, &temp, &extra); + if (iltemp) { + dlartg_(&a[irow + 1 - iskew * (ic + 1) + + ioffst + (ic + 1) * a_dim1], &temp, & + c__, &s, &dummy); +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + extra = 0.; + L__1 = jch > jku + jkl; + d__1 = -s; + dlarot_(&c_true, &L__1, &c_true, &il, &c__, & + d__1, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, & + temp); + ic = icol; + ir = irow; + } +/* L30: */ + } +/* L40: */ + } +/* L50: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* Computing MIN */ + i__3 = *n + jkl; + i__2 = f2cmin(i__3,*m) + jku - 1; + for (jc = 1; jc <= i__2; ++jc) { + extra = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__4 = jc - jku; + irow = f2cmax(i__3,i__4); + if (jc < *n) { +/* Computing MIN */ + i__3 = *m, i__4 = jc + jkl; + il = f2cmin(i__3,i__4) + 1 - irow; + L__1 = jc > jku; + dlarot_(&c_false, &L__1, &c_false, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ic = jc; + ir = irow; + i__3 = -jkl - jku; + for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ic < *n) { + dlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &c__, & + s, &dummy); + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + temp = 0.; + iltemp = jch > jkl; + d__1 = -s; + dlarot_(&c_true, &iltemp, &c_true, &il, &c__, & + d__1, &a[ir - iskew * icol + ioffst + + icol * a_dim1], &ilda, &temp, &extra); + if (iltemp) { + dlartg_(&a[ir + 1 - iskew * (icol + 1) + + ioffst + (icol + 1) * a_dim1], &temp, + &c__, &s, &dummy); +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + extra = 0.; + L__1 = jch > jkl + jku; + d__1 = -s; + dlarot_(&c_false, &L__1, &c_true, &il, &c__, & + d__1, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, & + temp); + ic = icol; + ir = irow; + } +/* L60: */ + } +/* L70: */ + } +/* L80: */ + } + + } else { + +/* Bottom-Up -- Start at the bottom right. */ + + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* First row actually rotated is M */ +/* First column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n + jkl; + iendch = f2cmin(i__2,i__3) - 1; +/* Computing MIN */ + i__2 = *m + jku; + i__3 = 1 - jkl; + for (jc = f2cmin(i__2,*n) - 1; jc >= i__3; --jc) { + extra = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__2 = 1, i__4 = jc - jku + 1; + irow = f2cmax(i__2,i__4); + if (jc > 0) { +/* Computing MIN */ + i__2 = *m, i__4 = jc + jkl + 1; + il = f2cmin(i__2,i__4) + 1 - irow; + L__1 = jc + jkl < *m; + dlarot_(&c_false, &c_false, &L__1, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ic = jc; + i__2 = iendch; + i__4 = jkl + jku; + for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <= + i__2; jch += i__4) { + ilextr = ic > 0; + if (ilextr) { + dlartg_(&a[jch - iskew * ic + ioffst + ic * + a_dim1], &extra, &c__, &s, &dummy); + } + ic = f2cmax(1,ic); +/* Computing MIN */ + i__5 = *n - 1, i__6 = jch + jku; + icol = f2cmin(i__5,i__6); + iltemp = jch + jku < *n; + temp = 0.; + i__5 = icol + 2 - ic; + dlarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, & + s, &a[jch - iskew * ic + ioffst + ic * + a_dim1], &ilda, &extra, &temp); + if (iltemp) { + dlartg_(&a[jch - iskew * icol + ioffst + icol + * a_dim1], &temp, &c__, &s, &dummy); +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra = 0.; + L__1 = jch + jkl + jku <= iendch; + dlarot_(&c_false, &c_true, &L__1, &il, &c__, & + s, &a[jch - iskew * icol + ioffst + + icol * a_dim1], &ilda, &temp, &extra); + ic = icol; + } +/* L90: */ + } +/* L100: */ + } +/* L110: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* First row actually rotated is MIN( N+JKL, M ) */ +/* First column actually rotated is N */ + +/* Computing MIN */ + i__3 = *n, i__4 = *m + jku; + iendch = f2cmin(i__3,i__4) - 1; +/* Computing MIN */ + i__3 = *n + jkl; + i__4 = 1 - jku; + for (jr = f2cmin(i__3,*m) - 1; jr >= i__4; --jr) { + extra = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__2 = jr - jkl + 1; + icol = f2cmax(i__3,i__2); + if (jr > 0) { +/* Computing MIN */ + i__3 = *n, i__2 = jr + jku + 1; + il = f2cmin(i__3,i__2) + 1 - icol; + L__1 = jr + jku < *n; + dlarot_(&c_true, &c_false, &L__1, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ir = jr; + i__3 = iendch; + i__2 = jkl + jku; + for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <= + i__3; jch += i__2) { + ilextr = ir > 0; + if (ilextr) { + dlartg_(&a[ir - iskew * jch + ioffst + jch * + a_dim1], &extra, &c__, &s, &dummy); + } + ir = f2cmax(1,ir); +/* Computing MIN */ + i__5 = *m - 1, i__6 = jch + jkl; + irow = f2cmin(i__5,i__6); + iltemp = jch + jkl < *m; + temp = 0.; + i__5 = irow + 2 - ir; + dlarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, & + s, &a[ir - iskew * jch + ioffst + jch * + a_dim1], &ilda, &extra, &temp); + if (iltemp) { + dlartg_(&a[irow - iskew * jch + ioffst + jch * + a_dim1], &temp, &c__, &s, &dummy); +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra = 0.; + L__1 = jch + jkl + jku <= iendch; + dlarot_(&c_true, &c_true, &L__1, &il, &c__, & + s, &a[irow - iskew * jch + ioffst + + jch * a_dim1], &ilda, &temp, &extra); + ir = irow; + } +/* L120: */ + } +/* L130: */ + } +/* L140: */ + } + } + + } else { + +/* Symmetric -- A = U D U' */ + + ipackg = ipack; + ioffg = ioffst; + + if (topdwn) { + +/* Top-Down -- Generate Upper triangle only */ + + if (ipack >= 5) { + ipackg = 6; + ioffg = uub + 1; + } else { + ipackg = 1; + } + i__1 = ilda + 1; + dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1], + &i__1); + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + i__4 = *n - 1; + for (jc = 1; jc <= i__4; ++jc) { +/* Computing MAX */ + i__2 = 1, i__3 = jc - k; + irow = f2cmax(i__2,i__3); +/* Computing MIN */ + i__2 = jc + 1, i__3 = k + 2; + il = f2cmin(i__2,i__3); + extra = 0.; + temp = a[jc - iskew * (jc + 1) + ioffg + (jc + 1) * + a_dim1]; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = sin(angle); + L__1 = jc > k; + dlarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[ + irow - iskew * jc + ioffg + jc * a_dim1], & + ilda, &extra, &temp); +/* Computing MIN */ + i__3 = k, i__5 = *n - jc; + i__2 = f2cmin(i__3,i__5) + 1; + dlarot_(&c_true, &c_true, &c_false, &i__2, &c__, &s, & + a[(1 - iskew) * jc + ioffg + jc * a_dim1], & + ilda, &temp, &dummy); + +/* Chase EXTRA back up the matrix */ + + icol = jc; + i__2 = -k; + for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1; + jch += i__2) { + dlartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg + + (icol + 1) * a_dim1], &extra, &c__, &s, & + dummy); + temp = a[jch - iskew * (jch + 1) + ioffg + (jch + + 1) * a_dim1]; + i__3 = k + 2; + d__1 = -s; + dlarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + d__1, &a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &temp, &extra); +/* Computing MAX */ + i__3 = 1, i__5 = jch - k; + irow = f2cmax(i__3,i__5); +/* Computing MIN */ + i__3 = jch + 1, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra = 0.; + L__1 = jch > k; + d__1 = -s; + dlarot_(&c_false, &L__1, &c_true, &il, &c__, & + d__1, &a[irow - iskew * jch + ioffg + jch + * a_dim1], &ilda, &extra, &temp); + icol = jch; +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + +/* If we need lower triangle, copy from upper. Note that */ +/* the order of copying is chosen to work for 'q' -> 'b' */ + + if (ipack != ipackg && ipack != 3) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst - iskew * jc; +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + a[jr + irow + jc * a_dim1] = a[jc - iskew * jr + + ioffg + jr * a_dim1]; +/* L180: */ + } +/* L190: */ + } + if (ipack == 5) { + i__1 = *n; + for (jc = *n - uub + 1; jc <= i__1; ++jc) { + i__4 = uub + 1; + for (jr = *n + 2 - jc; jr <= i__4; ++jr) { + a[jr + jc * a_dim1] = 0.; +/* L200: */ + } +/* L210: */ + } + } + if (ipackg == 6) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } else { + +/* Bottom-Up -- Generate Lower triangle only */ + + if (ipack >= 5) { + ipackg = 5; + if (ipack == 6) { + ioffg = 1; + } + } else { + ipackg = 2; + } + i__1 = ilda + 1; + dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1], + &i__1); + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + for (jc = *n - 1; jc >= 1; --jc) { +/* Computing MIN */ + i__4 = *n + 1 - jc, i__2 = k + 2; + il = f2cmin(i__4,i__2); + extra = 0.; + temp = a[(1 - iskew) * jc + 1 + ioffg + jc * a_dim1]; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = -sin(angle); + L__1 = *n - jc > k; + dlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[( + 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda, + &temp, &extra); +/* Computing MAX */ + i__4 = 1, i__2 = jc - k + 1; + icol = f2cmax(i__4,i__2); + i__4 = jc + 2 - icol; + dlarot_(&c_true, &c_false, &c_true, &i__4, &c__, &s, & + a[jc - iskew * icol + ioffg + icol * a_dim1], + &ilda, &dummy, &temp); + +/* Chase EXTRA back down the matrix */ + + icol = jc; + i__4 = *n - 1; + i__2 = k; + for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <= + i__4; jch += i__2) { + dlartg_(&a[jch - iskew * icol + ioffg + icol * + a_dim1], &extra, &c__, &s, &dummy); + temp = a[(1 - iskew) * jch + 1 + ioffg + jch * + a_dim1]; + i__3 = k + 2; + dlarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[jch - iskew * icol + ioffg + icol * + a_dim1], &ilda, &extra, &temp); +/* Computing MIN */ + i__3 = *n + 1 - jch, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra = 0.; + L__1 = *n - jch > k; + dlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, & + a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &temp, &extra); + icol = jch; +/* L220: */ + } +/* L230: */ + } +/* L240: */ + } + +/* If we need upper triangle, copy from lower. Note that */ +/* the order of copying is chosen to work for 'b' -> 'q' */ + + if (ipack != ipackg && ipack != 4) { + for (jc = *n; jc >= 1; --jc) { + irow = ioffst - iskew * jc; +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + a[jr + irow + jc * a_dim1] = a[jc - iskew * jr + + ioffg + jr * a_dim1]; +/* L250: */ + } +/* L260: */ + } + if (ipack == 6) { + i__1 = uub; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.; +/* L270: */ + } +/* L280: */ + } + } + if (ipackg == 5) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } + } + + } else { + +/* 4) Generate Banded Matrix by first */ +/* Rotating by random Unitary matrices, */ +/* then reducing the bandwidth using Householder */ +/* transformations. */ + +/* Note: we should get here only if LDA .ge. N */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + dlagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[ + 1], &work[1], &iinfo); + } else { + +/* Symmetric -- A = U D U' */ + + dlagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[1], + &iinfo); + + } + if (iinfo != 0) { + *info = 3; + return 0; + } + } + +/* 5) Pack the matrix */ + + if (ipack != ipackg) { + if (ipack == 1) { + +/* 'U' -- Upper triangular, not packed */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L290: */ + } +/* L300: */ + } + + } else if (ipack == 2) { + +/* 'L' -- Lower triangular, not packed */ + + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L310: */ + } +/* L320: */ + } + + } else if (ipack == 3) { + +/* 'C' -- Upper triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + a[irow + icol * a_dim1] = a[i__ + j * a_dim1]; +/* L330: */ + } +/* L340: */ + } + + } else if (ipack == 4) { + +/* 'R' -- Lower triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + a[irow + icol * a_dim1] = a[i__ + j * a_dim1]; +/* L350: */ + } +/* L360: */ + } + + } else if (ipack >= 5) { + +/* 'B' -- The lower triangle is packed as a band matrix. */ +/* 'Q' -- The upper triangle is packed as a band matrix. */ +/* 'Z' -- The whole matrix is packed as a band matrix. */ + + if (ipack == 5) { + uub = 0; + } + if (ipack == 6) { + llb = 0; + } + + i__1 = uub; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = j + llb; + for (i__ = f2cmin(i__2,*m); i__ >= 1; --i__) { + a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1]; +/* L370: */ + } +/* L380: */ + } + + i__1 = *n; + for (j = uub + 2; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = j + llb; + i__2 = f2cmin(i__4,*m); + for (i__ = j - uub; i__ <= i__2; ++i__) { + a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1]; +/* L390: */ + } +/* L400: */ + } + } + +/* If packed, zero out extraneous elements. */ + +/* Symmetric/Triangular Packed -- */ +/* zero out everything after A(IROW,ICOL) */ + + if (ipack == 3 || ipack == 4) { + i__1 = *m; + for (jc = icol; jc <= i__1; ++jc) { + i__2 = *lda; + for (jr = irow + 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.; +/* L410: */ + } + irow = 0; +/* L420: */ + } + + } else if (ipack >= 5) { + +/* Packed Band -- */ +/* 1st row is now in A( UUB+2-j, j), zero above it */ +/* m-th row is now in A( M+UUB-j,j), zero below it */ +/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */ +/* zero below it, too. */ + + ir1 = uub + llb + 2; + ir2 = uub + *m + 2; + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.; +/* L430: */ + } +/* Computing MAX */ +/* Computing MIN */ + i__3 = ir1, i__5 = ir2 - jc; + i__2 = 1, i__4 = f2cmin(i__3,i__5); + i__6 = *lda; + for (jr = f2cmax(i__2,i__4); jr <= i__6; ++jr) { + a[jr + jc * a_dim1] = 0.; +/* L440: */ + } +/* L450: */ + } + } + } + + return 0; + +/* End of DLATMS */ + +} /* dlatms_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/dlatmt.c b/lapack-netlib/TESTING/MATGEN/dlatmt.c new file mode 100644 index 000000000..383409761 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/dlatmt.c @@ -0,0 +1,1780 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DLATMT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* RANK, KL, KU, PACK, A, LDA, WORK, INFO ) */ + +/* DOUBLE PRECISION COND, DMAX */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK */ +/* CHARACTER DIST, PACK, SYM */ +/* DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) */ +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATMT generates random matrices with specified singular values */ +/* > (or symmetric/hermitian with specified eigenvalues) */ +/* > for testing LAPACK programs. */ +/* > */ +/* > DLATMT operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and SYM */ +/* > as described below. */ +/* > */ +/* > Generate a matrix with the appropriate band structure, by one */ +/* > of two methods: */ +/* > */ +/* > Method A: */ +/* > Generate a dense M x N matrix by multiplying D on the left */ +/* > and the right by random unitary matrices, then: */ +/* > */ +/* > Reduce the bandwidth according to KL and KU, using */ +/* > Householder transformations. */ +/* > */ +/* > Method B: */ +/* > Convert the bandwidth-0 (i.e., diagonal) matrix to a */ +/* > bandwidth-1 matrix using Givens rotations, "chasing" */ +/* > out-of-band elements back, much as in QR; then */ +/* > convert the bandwidth-1 to a bandwidth-2 matrix, etc. */ +/* > Note that for reasonably small bandwidths (relative to */ +/* > M and N) this requires less storage, as a dense matrix */ +/* > is not generated. Also, for symmetric matrices, only */ +/* > one triangle is generated. */ +/* > */ +/* > Method A is chosen if the bandwidth is a large fraction of the */ +/* > order of the matrix, and LDA is at least M (so a dense */ +/* > matrix can be stored.) Method B is chosen if the bandwidth */ +/* > is small (< 1/2 N for symmetric, < .3 N+M for */ +/* > non-symmetric), or LDA is less than M and not less than the */ +/* > bandwidth. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if symmetric) */ +/* > zero out lower half (if symmetric) */ +/* > store the upper half columnwise (if symmetric or upper */ +/* > triangular) */ +/* > store the lower half columnwise (if symmetric or lower */ +/* > triangular) */ +/* > store the lower triangle in banded format (if symmetric */ +/* > or lower triangular) */ +/* > store the upper triangle in banded format (if symmetric */ +/* > or upper triangular) */ +/* > store the entire matrix in banded format */ +/* > If Method B is chosen, and band format is specified, then the */ +/* > matrix will be generated in the band format, so no repacking */ +/* > will be necessary. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values. */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to DLATMT */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='S' or 'H', the generated matrix is symmetric, with */ +/* > eigenvalues specified by D, COND, MODE, and DMAX; they */ +/* > may be positive, negative, or zero. */ +/* > If SYM='P', the generated matrix is symmetric, with */ +/* > eigenvalues (= singular values) specified by D, COND, */ +/* > MODE, and DMAX; they will not be negative. */ +/* > If SYM='N', the generated matrix is nonsymmetric, with */ +/* > singular values specified by D, COND, MODE, and DMAX; */ +/* > they will not be negative. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension ( MIN( M , N ) ) */ +/* > This array is used to specify the singular values or */ +/* > eigenvalues of A (see SYM, above.) If MODE=0, then D is */ +/* > assumed to contain the singular/eigenvalues, otherwise */ +/* > they will be computed according to MODE, COND, and DMAX, */ +/* > and placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the singular/eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D as input */ +/* > */ +/* > MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */ +/* > MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) */ +/* > */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then */ +/* > the elements of D will also be multiplied by a random */ +/* > sign (i.e., +1 or -1.) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is DOUBLE PRECISION */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is DOUBLE PRECISION */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))); thus, the maximum absolute eigen- or */ +/* > singular value (which is to say the norm) will be abs(DMAX). */ +/* > Note that DMAX need not be positive: if DMAX is negative */ +/* > (or zero), D will be scaled by a negative number (or zero). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The rank of matrix to be generated for modes 1,2,3 only. */ +/* > D( RANK+1:N ) = 0. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL being at least M-1 means that the matrix */ +/* > has full lower bandwidth. KL must equal KU if the matrix */ +/* > is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU being at least N-1 means that the matrix */ +/* > has full upper bandwidth. KL must equal KU if the matrix */ +/* > is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > This specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries (if symmetric) */ +/* > 'L' => zero out all superdiagonal entries (if symmetric) */ +/* > 'C' => store the upper triangle columnwise */ +/* > (only if the matrix is symmetric or upper triangular) */ +/* > 'R' => store the lower triangle columnwise */ +/* > (only if the matrix is symmetric or lower triangular) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if matrix symmetric or lower triangular) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if matrix symmetric or upper triangular) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, SB or TB - use 'B' or 'Q' */ +/* > PP, SP or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to DLATMT differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. A is first generated */ +/* > in full (unpacked) form, and then packed, if so specified */ +/* > by PACK. Thus, the first M elements of the first N */ +/* > columns will always be modified. If PACK specifies a */ +/* > packed or banded storage scheme, all LDA elements of the */ +/* > first N columns will be modified; the elements of the */ +/* > array which do not correspond to elements of the generated */ +/* > matrix are set to zero. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */ +/* > LDA must be at least M. If PACK='B' or 'Q', then LDA must */ +/* > be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */ +/* > If PACK='Z', LDA must be large enough to hold the packed */ +/* > array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension ( 3*MAX( N , M ) ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => KL negative */ +/* > -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL */ +/* > -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */ +/* > or PACK='C' or 'Q' and SYM='N' and KL is not zero; */ +/* > or PACK='R' or 'B' and SYM='N' and KU is not zero; */ +/* > or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */ +/* > N. */ +/* > -14 => LDA is less than M, or PACK='Z' and LDA is less than */ +/* > MIN(KU,N-1) + MIN(KL,M-1) + 1. */ +/* > 1 => Error return from DLATM7 */ +/* > 2 => Cannot scale to DMAX (f2cmax. sing. value is 0) */ +/* > 3 => Error return from DLAGGE or DLAGSY */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup double_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int dlatmt_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond, + doublereal *dmax__, integer *rank, integer *kl, integer *ku, char * + pack, doublereal *a, integer *lda, doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1, d__2, d__3; + logical L__1; + + /* Local variables */ + integer ilda, icol; + doublereal temp; + integer irow, isym; + doublereal c__; + integer i__, j, k; + doublereal s, alpha, angle; + integer ipack; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + integer ioffg; + extern logical lsame_(char *, char *); + integer iinfo, idist, mnmin; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer iskew; + doublereal extra, dummy; + extern /* Subroutine */ int dlatm7_(integer *, doublereal *, integer *, + integer *, integer *, doublereal *, integer *, integer *, integer + *); + integer ic, jc, nc; + extern /* Subroutine */ int dlagge_(integer *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, integer *, + doublereal *, integer *); + integer il, iendch, ir, jr, ipackg, mr, minlda; + extern doublereal dlarnd_(integer *, integer *); + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), xerbla_(char *, integer *), dlagsy_( + integer *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, integer *), dlarot_(logical *, logical *, + logical *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, doublereal *); + integer ioffst, irsign; + logical givens, iltemp, ilextr, topdwn; + integer ir1, ir2, isympk, jch, llb, jkl, jku, uub; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "N")) { + isym = 1; + irsign = 0; + } else if (lsame_(sym, "P")) { + isym = 2; + irsign = 0; + } else if (lsame_(sym, "S")) { + isym = 2; + irsign = 1; + } else if (lsame_(sym, "H")) { + isym = 2; + irsign = 1; + } else { + isym = -1; + } + +/* Decode PACK */ + + isympk = 0; + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + isympk = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + isympk = 1; + } else if (lsame_(pack, "C")) { + ipack = 3; + isympk = 2; + } else if (lsame_(pack, "R")) { + ipack = 4; + isympk = 3; + } else if (lsame_(pack, "B")) { + ipack = 5; + isympk = 3; + } else if (lsame_(pack, "Q")) { + ipack = 6; + isympk = 2; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + llb = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + uub = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *m, i__2 = *n + llb; + mr = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *n, i__2 = *m + uub; + nc = f2cmin(i__1,i__2); + + if (ipack == 5 || ipack == 6) { + minlda = uub + 1; + } else if (ipack == 7) { + minlda = llb + uub + 1; + } else { + minlda = *m; + } + +/* Use Givens rotation method if bandwidth small enough, */ +/* or if LDA is too small to store the matrix unpacked. */ + + givens = FALSE_; + if (isym == 1) { +/* Computing MAX */ + i__1 = 1, i__2 = mr + nc; + if ((doublereal) (llb + uub) < (doublereal) f2cmax(i__1,i__2) * .3) { + givens = TRUE_; + } + } else { + if (llb << 1 < *m) { + givens = TRUE_; + } + } + if (*lda < *m && *lda >= minlda) { + givens = TRUE_; + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && isym != 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (abs(*mode) > 6) { + *info = -7; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) { + *info = -8; + } else if (*kl < 0) { + *info = -10; + } else if (*ku < 0 || isym != 1 && *kl != *ku) { + *info = -11; + } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym + == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk + != 0 && *m != *n) { + *info = -12; + } else if (*lda < f2cmax(1,minlda)) { + *info = -14; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLATMT", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L100: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up D if indicated. */ + +/* Compute D according to COND and MODE */ + + dlatm7_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, rank, & + iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + +/* Choose Top-Down if D is (apparently) increasing, */ +/* Bottom-Up if D is (apparently) decreasing. */ + + if (abs(d__[1]) <= (d__1 = d__[*rank], abs(d__1))) { + topdwn = TRUE_; + } else { + topdwn = FALSE_; + } + + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = *rank; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L110: */ + } + + if (temp > 0.) { + alpha = *dmax__ / temp; + } else { + *info = 2; + return 0; + } + + dscal_(rank, &alpha, &d__[1], &c__1); + + } + +/* 3) Generate Banded Matrix using Givens rotations. */ +/* Also the special case of UUB=LLB=0 */ + +/* Compute Addressing constants to cover all */ +/* storage formats. Whether GE, SY, GB, or SB, */ +/* upper or lower triangle or both, */ +/* the (i,j)-th element is in */ +/* A( i - ISKEW*j + IOFFST, j ) */ + + if (ipack > 4) { + ilda = *lda - 1; + iskew = 1; + if (ipack > 5) { + ioffst = uub + 1; + } else { + ioffst = 1; + } + } else { + ilda = *lda; + iskew = 0; + ioffst = 0; + } + +/* IPACKG is the format that the matrix is generated in. If this is */ +/* different from IPACK, then the matrix must be repacked at the */ +/* end. It also signals how to compute the norm, for scaling. */ + + ipackg = 0; + dlaset_("Full", lda, n, &c_b22, &c_b22, &a[a_offset], lda); + +/* Diagonal Matrix -- We are done, unless it */ +/* is to be stored SP/PP/TP (PACK='R' or 'C') */ + + if (llb == 0 && uub == 0) { + i__1 = ilda + 1; + dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &i__1) + ; + if (ipack <= 2 || ipack >= 5) { + ipackg = ipack; + } + + } else if (givens) { + +/* Check whether to use Givens rotations, */ +/* Householder transformations, or nothing. */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + if (ipack > 4) { + ipackg = ipack; + } else { + ipackg = 0; + } + + i__1 = ilda + 1; + dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], & + i__1); + + if (topdwn) { + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* Last row actually rotated is M */ +/* Last column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__3 = *m + jku; + i__2 = f2cmin(i__3,*n) + jkl - 1; + for (jr = 1; jr <= i__2; ++jr) { + extra = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__4 = jr - jkl; + icol = f2cmax(i__3,i__4); + if (jr < *m) { +/* Computing MIN */ + i__3 = *n, i__4 = jr + jku; + il = f2cmin(i__3,i__4) + 1 - icol; + L__1 = jr > jkl; + dlarot_(&c_true, &L__1, &c_false, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ir = jr; + ic = icol; + i__3 = -jkl - jku; + for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ir < *m) { + dlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &c__, & + s, &dummy); + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + temp = 0.; + iltemp = jch > jku; + d__1 = -s; + dlarot_(&c_false, &iltemp, &c_true, &il, &c__, & + d__1, &a[irow - iskew * ic + ioffst + ic * + a_dim1], &ilda, &temp, &extra); + if (iltemp) { + dlartg_(&a[irow + 1 - iskew * (ic + 1) + + ioffst + (ic + 1) * a_dim1], &temp, & + c__, &s, &dummy); +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + extra = 0.; + L__1 = jch > jku + jkl; + d__1 = -s; + dlarot_(&c_true, &L__1, &c_true, &il, &c__, & + d__1, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, & + temp); + ic = icol; + ir = irow; + } +/* L120: */ + } +/* L130: */ + } +/* L140: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* Computing MIN */ + i__3 = *n + jkl; + i__2 = f2cmin(i__3,*m) + jku - 1; + for (jc = 1; jc <= i__2; ++jc) { + extra = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__4 = jc - jku; + irow = f2cmax(i__3,i__4); + if (jc < *n) { +/* Computing MIN */ + i__3 = *m, i__4 = jc + jkl; + il = f2cmin(i__3,i__4) + 1 - irow; + L__1 = jc > jku; + dlarot_(&c_false, &L__1, &c_false, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ic = jc; + ir = irow; + i__3 = -jkl - jku; + for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ic < *n) { + dlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &c__, & + s, &dummy); + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + temp = 0.; + iltemp = jch > jkl; + d__1 = -s; + dlarot_(&c_true, &iltemp, &c_true, &il, &c__, & + d__1, &a[ir - iskew * icol + ioffst + + icol * a_dim1], &ilda, &temp, &extra); + if (iltemp) { + dlartg_(&a[ir + 1 - iskew * (icol + 1) + + ioffst + (icol + 1) * a_dim1], &temp, + &c__, &s, &dummy); +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + extra = 0.; + L__1 = jch > jkl + jku; + d__1 = -s; + dlarot_(&c_false, &L__1, &c_true, &il, &c__, & + d__1, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, & + temp); + ic = icol; + ir = irow; + } +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + + } else { + +/* Bottom-Up -- Start at the bottom right. */ + + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* First row actually rotated is M */ +/* First column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n + jkl; + iendch = f2cmin(i__2,i__3) - 1; +/* Computing MIN */ + i__2 = *m + jku; + i__3 = 1 - jkl; + for (jc = f2cmin(i__2,*n) - 1; jc >= i__3; --jc) { + extra = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__2 = 1, i__4 = jc - jku + 1; + irow = f2cmax(i__2,i__4); + if (jc > 0) { +/* Computing MIN */ + i__2 = *m, i__4 = jc + jkl + 1; + il = f2cmin(i__2,i__4) + 1 - irow; + L__1 = jc + jkl < *m; + dlarot_(&c_false, &c_false, &L__1, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ic = jc; + i__2 = iendch; + i__4 = jkl + jku; + for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <= + i__2; jch += i__4) { + ilextr = ic > 0; + if (ilextr) { + dlartg_(&a[jch - iskew * ic + ioffst + ic * + a_dim1], &extra, &c__, &s, &dummy); + } + ic = f2cmax(1,ic); +/* Computing MIN */ + i__5 = *n - 1, i__6 = jch + jku; + icol = f2cmin(i__5,i__6); + iltemp = jch + jku < *n; + temp = 0.; + i__5 = icol + 2 - ic; + dlarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, & + s, &a[jch - iskew * ic + ioffst + ic * + a_dim1], &ilda, &extra, &temp); + if (iltemp) { + dlartg_(&a[jch - iskew * icol + ioffst + icol + * a_dim1], &temp, &c__, &s, &dummy); +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra = 0.; + L__1 = jch + jkl + jku <= iendch; + dlarot_(&c_false, &c_true, &L__1, &il, &c__, & + s, &a[jch - iskew * icol + ioffst + + icol * a_dim1], &ilda, &temp, &extra); + ic = icol; + } +/* L180: */ + } +/* L190: */ + } +/* L200: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* First row actually rotated is MIN( N+JKL, M ) */ +/* First column actually rotated is N */ + +/* Computing MIN */ + i__3 = *n, i__4 = *m + jku; + iendch = f2cmin(i__3,i__4) - 1; +/* Computing MIN */ + i__3 = *n + jkl; + i__4 = 1 - jku; + for (jr = f2cmin(i__3,*m) - 1; jr >= i__4; --jr) { + extra = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__2 = jr - jkl + 1; + icol = f2cmax(i__3,i__2); + if (jr > 0) { +/* Computing MIN */ + i__3 = *n, i__2 = jr + jku + 1; + il = f2cmin(i__3,i__2) + 1 - icol; + L__1 = jr + jku < *n; + dlarot_(&c_true, &c_false, &L__1, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ir = jr; + i__3 = iendch; + i__2 = jkl + jku; + for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <= + i__3; jch += i__2) { + ilextr = ir > 0; + if (ilextr) { + dlartg_(&a[ir - iskew * jch + ioffst + jch * + a_dim1], &extra, &c__, &s, &dummy); + } + ir = f2cmax(1,ir); +/* Computing MIN */ + i__5 = *m - 1, i__6 = jch + jkl; + irow = f2cmin(i__5,i__6); + iltemp = jch + jkl < *m; + temp = 0.; + i__5 = irow + 2 - ir; + dlarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, & + s, &a[ir - iskew * jch + ioffst + jch * + a_dim1], &ilda, &extra, &temp); + if (iltemp) { + dlartg_(&a[irow - iskew * jch + ioffst + jch * + a_dim1], &temp, &c__, &s, &dummy); +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra = 0.; + L__1 = jch + jkl + jku <= iendch; + dlarot_(&c_true, &c_true, &L__1, &il, &c__, & + s, &a[irow - iskew * jch + ioffst + + jch * a_dim1], &ilda, &temp, &extra); + ir = irow; + } +/* L210: */ + } +/* L220: */ + } +/* L230: */ + } + } + + } else { + +/* Symmetric -- A = U D U' */ + + ipackg = ipack; + ioffg = ioffst; + + if (topdwn) { + +/* Top-Down -- Generate Upper triangle only */ + + if (ipack >= 5) { + ipackg = 6; + ioffg = uub + 1; + } else { + ipackg = 1; + } + i__1 = ilda + 1; + dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1], + &i__1); + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + i__4 = *n - 1; + for (jc = 1; jc <= i__4; ++jc) { +/* Computing MAX */ + i__2 = 1, i__3 = jc - k; + irow = f2cmax(i__2,i__3); +/* Computing MIN */ + i__2 = jc + 1, i__3 = k + 2; + il = f2cmin(i__2,i__3); + extra = 0.; + temp = a[jc - iskew * (jc + 1) + ioffg + (jc + 1) * + a_dim1]; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = sin(angle); + L__1 = jc > k; + dlarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[ + irow - iskew * jc + ioffg + jc * a_dim1], & + ilda, &extra, &temp); +/* Computing MIN */ + i__3 = k, i__5 = *n - jc; + i__2 = f2cmin(i__3,i__5) + 1; + dlarot_(&c_true, &c_true, &c_false, &i__2, &c__, &s, & + a[(1 - iskew) * jc + ioffg + jc * a_dim1], & + ilda, &temp, &dummy); + +/* Chase EXTRA back up the matrix */ + + icol = jc; + i__2 = -k; + for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1; + jch += i__2) { + dlartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg + + (icol + 1) * a_dim1], &extra, &c__, &s, & + dummy); + temp = a[jch - iskew * (jch + 1) + ioffg + (jch + + 1) * a_dim1]; + i__3 = k + 2; + d__1 = -s; + dlarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + d__1, &a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &temp, &extra); +/* Computing MAX */ + i__3 = 1, i__5 = jch - k; + irow = f2cmax(i__3,i__5); +/* Computing MIN */ + i__3 = jch + 1, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra = 0.; + L__1 = jch > k; + d__1 = -s; + dlarot_(&c_false, &L__1, &c_true, &il, &c__, & + d__1, &a[irow - iskew * jch + ioffg + jch + * a_dim1], &ilda, &extra, &temp); + icol = jch; +/* L240: */ + } +/* L250: */ + } +/* L260: */ + } + +/* If we need lower triangle, copy from upper. Note that */ +/* the order of copying is chosen to work for 'q' -> 'b' */ + + if (ipack != ipackg && ipack != 3) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst - iskew * jc; +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + a[jr + irow + jc * a_dim1] = a[jc - iskew * jr + + ioffg + jr * a_dim1]; +/* L270: */ + } +/* L280: */ + } + if (ipack == 5) { + i__1 = *n; + for (jc = *n - uub + 1; jc <= i__1; ++jc) { + i__4 = uub + 1; + for (jr = *n + 2 - jc; jr <= i__4; ++jr) { + a[jr + jc * a_dim1] = 0.; +/* L290: */ + } +/* L300: */ + } + } + if (ipackg == 6) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } else { + +/* Bottom-Up -- Generate Lower triangle only */ + + if (ipack >= 5) { + ipackg = 5; + if (ipack == 6) { + ioffg = 1; + } + } else { + ipackg = 2; + } + i__1 = ilda + 1; + dcopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1], + &i__1); + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + for (jc = *n - 1; jc >= 1; --jc) { +/* Computing MIN */ + i__4 = *n + 1 - jc, i__2 = k + 2; + il = f2cmin(i__4,i__2); + extra = 0.; + temp = a[(1 - iskew) * jc + 1 + ioffg + jc * a_dim1]; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + c__ = cos(angle); + s = -sin(angle); + L__1 = *n - jc > k; + dlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[( + 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda, + &temp, &extra); +/* Computing MAX */ + i__4 = 1, i__2 = jc - k + 1; + icol = f2cmax(i__4,i__2); + i__4 = jc + 2 - icol; + dlarot_(&c_true, &c_false, &c_true, &i__4, &c__, &s, & + a[jc - iskew * icol + ioffg + icol * a_dim1], + &ilda, &dummy, &temp); + +/* Chase EXTRA back down the matrix */ + + icol = jc; + i__4 = *n - 1; + i__2 = k; + for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <= + i__4; jch += i__2) { + dlartg_(&a[jch - iskew * icol + ioffg + icol * + a_dim1], &extra, &c__, &s, &dummy); + temp = a[(1 - iskew) * jch + 1 + ioffg + jch * + a_dim1]; + i__3 = k + 2; + dlarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[jch - iskew * icol + ioffg + icol * + a_dim1], &ilda, &extra, &temp); +/* Computing MIN */ + i__3 = *n + 1 - jch, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra = 0.; + L__1 = *n - jch > k; + dlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, & + a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &temp, &extra); + icol = jch; +/* L310: */ + } +/* L320: */ + } +/* L330: */ + } + +/* If we need upper triangle, copy from lower. Note that */ +/* the order of copying is chosen to work for 'b' -> 'q' */ + + if (ipack != ipackg && ipack != 4) { + for (jc = *n; jc >= 1; --jc) { + irow = ioffst - iskew * jc; +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + a[jr + irow + jc * a_dim1] = a[jc - iskew * jr + + ioffg + jr * a_dim1]; +/* L340: */ + } +/* L350: */ + } + if (ipack == 6) { + i__1 = uub; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.; +/* L360: */ + } +/* L370: */ + } + } + if (ipackg == 5) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } + } + + } else { + +/* 4) Generate Banded Matrix by first */ +/* Rotating by random Unitary matrices, */ +/* then reducing the bandwidth using Householder */ +/* transformations. */ + +/* Note: we should get here only if LDA .ge. N */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + dlagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[ + 1], &work[1], &iinfo); + } else { + +/* Symmetric -- A = U D U' */ + + dlagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[1], + &iinfo); + + } + if (iinfo != 0) { + *info = 3; + return 0; + } + } + +/* 5) Pack the matrix */ + + if (ipack != ipackg) { + if (ipack == 1) { + +/* 'U' -- Upper triangular, not packed */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L380: */ + } +/* L390: */ + } + + } else if (ipack == 2) { + +/* 'L' -- Lower triangular, not packed */ + + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.; +/* L400: */ + } +/* L410: */ + } + + } else if (ipack == 3) { + +/* 'C' -- Upper triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + a[irow + icol * a_dim1] = a[i__ + j * a_dim1]; +/* L420: */ + } +/* L430: */ + } + + } else if (ipack == 4) { + +/* 'R' -- Lower triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + a[irow + icol * a_dim1] = a[i__ + j * a_dim1]; +/* L440: */ + } +/* L450: */ + } + + } else if (ipack >= 5) { + +/* 'B' -- The lower triangle is packed as a band matrix. */ +/* 'Q' -- The upper triangle is packed as a band matrix. */ +/* 'Z' -- The whole matrix is packed as a band matrix. */ + + if (ipack == 5) { + uub = 0; + } + if (ipack == 6) { + llb = 0; + } + + i__1 = uub; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = j + llb; + for (i__ = f2cmin(i__2,*m); i__ >= 1; --i__) { + a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1]; +/* L460: */ + } +/* L470: */ + } + + i__1 = *n; + for (j = uub + 2; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = j + llb; + i__2 = f2cmin(i__4,*m); + for (i__ = j - uub; i__ <= i__2; ++i__) { + a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1]; +/* L480: */ + } +/* L490: */ + } + } + +/* If packed, zero out extraneous elements. */ + +/* Symmetric/Triangular Packed -- */ +/* zero out everything after A(IROW,ICOL) */ + + if (ipack == 3 || ipack == 4) { + i__1 = *m; + for (jc = icol; jc <= i__1; ++jc) { + i__2 = *lda; + for (jr = irow + 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.; +/* L500: */ + } + irow = 0; +/* L510: */ + } + + } else if (ipack >= 5) { + +/* Packed Band -- */ +/* 1st row is now in A( UUB+2-j, j), zero above it */ +/* m-th row is now in A( M+UUB-j,j), zero below it */ +/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */ +/* zero below it, too. */ + + ir1 = uub + llb + 2; + ir2 = uub + *m + 2; + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.; +/* L520: */ + } +/* Computing MAX */ +/* Computing MIN */ + i__3 = ir1, i__5 = ir2 - jc; + i__2 = 1, i__4 = f2cmin(i__3,i__5); + i__6 = *lda; + for (jr = f2cmax(i__2,i__4); jr <= i__6; ++jr) { + a[jr + jc * a_dim1] = 0.; +/* L530: */ + } +/* L540: */ + } + } + } + + return 0; + +/* End of DLATMT */ + +} /* dlatmt_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slagge.c b/lapack-netlib/TESTING/MATGEN/slagge.c new file mode 100644 index 000000000..6ff27dbbf --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slagge.c @@ -0,0 +1,845 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAGGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, KL, KU, LDA, M, N */ +/* INTEGER ISEED( 4 ) */ +/* REAL A( LDA, * ), D( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAGGE generates a real general m by n matrix A, by pre- and post- */ +/* > multiplying a real diagonal matrix D with random orthogonal matrices: */ +/* > A = U*D*V. The lower and upper bandwidths may then be reduced to */ +/* > kl and ku by additional orthogonal transformations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of nonzero subdiagonals within the band of A. */ +/* > 0 <= KL <= M-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of nonzero superdiagonals within the band of A. */ +/* > 0 <= KU <= N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (f2cmin(M,N)) */ +/* > The diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The generated m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (M+N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slagge_(integer *m, integer *n, integer *kl, integer *ku, + real *d__, real *a, integer *lda, integer *iseed, real *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + extern real snrm2_(integer *, real *, integer *); + integer i__, j; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *); + real wa, wb, wn; + extern /* Subroutine */ int xerbla_(char *, integer *), slarnv_( + integer *, integer *, integer *, real *); + real tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0 || *kl > *m - 1) { + *info = -3; + } else if (*ku < 0 || *ku > *n - 1) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -7; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("SLAGGE", &i__1); + return 0; + } + +/* initialize A to diagonal matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.f; +/* L10: */ + } +/* L20: */ + } + i__1 = f2cmin(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + i__ * a_dim1] = d__[i__]; +/* L30: */ + } + +/* Quick exit if the user wants a diagonal matrix */ + + if (*kl == 0 && *ku == 0) { + return 0; + } + +/* pre- and post-multiply A by random orthogonal matrices */ + + for (i__ = f2cmin(*m,*n); i__ >= 1; --i__) { + if (i__ < *m) { + +/* generate random reflection */ + + i__1 = *m - i__ + 1; + slarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *m - i__ + 1; + wn = snrm2_(&i__1, &work[1], &c__1); + wa = r_sign(&wn, &work[1]); + if (wn == 0.f) { + tau = 0.f; + } else { + wb = work[1] + wa; + i__1 = *m - i__; + r__1 = 1.f / wb; + sscal_(&i__1, &r__1, &work[2], &c__1); + work[1] = 1.f; + tau = wb / wa; + } + +/* multiply A(i:m,i:n) by random reflection from the left */ + + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + sgemv_("Transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * a_dim1], + lda, &work[1], &c__1, &c_b13, &work[*m + 1], &c__1); + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + r__1 = -tau; + sger_(&i__1, &i__2, &r__1, &work[1], &c__1, &work[*m + 1], &c__1, + &a[i__ + i__ * a_dim1], lda); + } + if (i__ < *n) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + slarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = snrm2_(&i__1, &work[1], &c__1); + wa = r_sign(&wn, &work[1]); + if (wn == 0.f) { + tau = 0.f; + } else { + wb = work[1] + wa; + i__1 = *n - i__; + r__1 = 1.f / wb; + sscal_(&i__1, &r__1, &work[2], &c__1); + work[1] = 1.f; + tau = wb / wa; + } + +/* multiply A(i:m,i:n) by random reflection from the right */ + + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + sgemv_("No transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * + a_dim1], lda, &work[1], &c__1, &c_b13, &work[*n + 1], & + c__1); + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + r__1 = -tau; + sger_(&i__1, &i__2, &r__1, &work[*n + 1], &c__1, &work[1], &c__1, + &a[i__ + i__ * a_dim1], lda); + } +/* L40: */ + } + +/* Reduce number of subdiagonals to KL and number of superdiagonals */ +/* to KU */ + +/* Computing MAX */ + i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku; + i__1 = f2cmax(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + if (*kl <= *ku) { + +/* annihilate subdiagonal elements first (necessary if KL = 0) */ + +/* Computing MIN */ + i__2 = *m - 1 - *kl; + if (i__ <= f2cmin(i__2,*n)) { + +/* generate reflection to annihilate A(kl+i+1:m,i) */ + + i__2 = *m - *kl - i__ + 1; + wn = snrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1); + wa = r_sign(&wn, &a[*kl + i__ + i__ * a_dim1]); + if (wn == 0.f) { + tau = 0.f; + } else { + wb = a[*kl + i__ + i__ * a_dim1] + wa; + i__2 = *m - *kl - i__; + r__1 = 1.f / wb; + sscal_(&i__2, &r__1, &a[*kl + i__ + 1 + i__ * a_dim1], & + c__1); + a[*kl + i__ + i__ * a_dim1] = 1.f; + tau = wb / wa; + } + +/* apply reflection to A(kl+i:m,i+1:n) from the left */ + + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + sgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__ + + 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], & + c__1, &c_b13, &work[1], &c__1); + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + r__1 = -tau; + sger_(&i__2, &i__3, &r__1, &a[*kl + i__ + i__ * a_dim1], & + c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * + a_dim1], lda); + a[*kl + i__ + i__ * a_dim1] = -wa; + } + +/* Computing MIN */ + i__2 = *n - 1 - *ku; + if (i__ <= f2cmin(i__2,*m)) { + +/* generate reflection to annihilate A(i,ku+i+1:n) */ + + i__2 = *n - *ku - i__ + 1; + wn = snrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + wa = r_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]); + if (wn == 0.f) { + tau = 0.f; + } else { + wb = a[i__ + (*ku + i__) * a_dim1] + wa; + i__2 = *n - *ku - i__; + r__1 = 1.f / wb; + sscal_(&i__2, &r__1, &a[i__ + (*ku + i__ + 1) * a_dim1], + lda); + a[i__ + (*ku + i__) * a_dim1] = 1.f; + tau = wb / wa; + } + +/* apply reflection to A(i+1:m,ku+i:n) from the right */ + + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + sgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (* + ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * + a_dim1], lda, &c_b13, &work[1], &c__1); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + r__1 = -tau; + sger_(&i__2, &i__3, &r__1, &work[1], &c__1, &a[i__ + (*ku + + i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * + a_dim1], lda); + a[i__ + (*ku + i__) * a_dim1] = -wa; + } + } else { + +/* annihilate superdiagonal elements first (necessary if */ +/* KU = 0) */ + +/* Computing MIN */ + i__2 = *n - 1 - *ku; + if (i__ <= f2cmin(i__2,*m)) { + +/* generate reflection to annihilate A(i,ku+i+1:n) */ + + i__2 = *n - *ku - i__ + 1; + wn = snrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + wa = r_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]); + if (wn == 0.f) { + tau = 0.f; + } else { + wb = a[i__ + (*ku + i__) * a_dim1] + wa; + i__2 = *n - *ku - i__; + r__1 = 1.f / wb; + sscal_(&i__2, &r__1, &a[i__ + (*ku + i__ + 1) * a_dim1], + lda); + a[i__ + (*ku + i__) * a_dim1] = 1.f; + tau = wb / wa; + } + +/* apply reflection to A(i+1:m,ku+i:n) from the right */ + + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + sgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (* + ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * + a_dim1], lda, &c_b13, &work[1], &c__1); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + r__1 = -tau; + sger_(&i__2, &i__3, &r__1, &work[1], &c__1, &a[i__ + (*ku + + i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * + a_dim1], lda); + a[i__ + (*ku + i__) * a_dim1] = -wa; + } + +/* Computing MIN */ + i__2 = *m - 1 - *kl; + if (i__ <= f2cmin(i__2,*n)) { + +/* generate reflection to annihilate A(kl+i+1:m,i) */ + + i__2 = *m - *kl - i__ + 1; + wn = snrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1); + wa = r_sign(&wn, &a[*kl + i__ + i__ * a_dim1]); + if (wn == 0.f) { + tau = 0.f; + } else { + wb = a[*kl + i__ + i__ * a_dim1] + wa; + i__2 = *m - *kl - i__; + r__1 = 1.f / wb; + sscal_(&i__2, &r__1, &a[*kl + i__ + 1 + i__ * a_dim1], & + c__1); + a[*kl + i__ + i__ * a_dim1] = 1.f; + tau = wb / wa; + } + +/* apply reflection to A(kl+i:m,i+1:n) from the left */ + + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + sgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__ + + 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], & + c__1, &c_b13, &work[1], &c__1); + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + r__1 = -tau; + sger_(&i__2, &i__3, &r__1, &a[*kl + i__ + i__ * a_dim1], & + c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * + a_dim1], lda); + a[*kl + i__ + i__ * a_dim1] = -wa; + } + } + + if (i__ <= *n) { + i__2 = *m; + for (j = *kl + i__ + 1; j <= i__2; ++j) { + a[j + i__ * a_dim1] = 0.f; +/* L50: */ + } + } + + if (i__ <= *m) { + i__2 = *n; + for (j = *ku + i__ + 1; j <= i__2; ++j) { + a[i__ + j * a_dim1] = 0.f; +/* L60: */ + } + } +/* L70: */ + } + return 0; + +/* End of SLAGGE */ + +} /* slagge_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slagsy.c b/lapack-netlib/TESTING/MATGEN/slagsy.c new file mode 100644 index 000000000..ff17a4098 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slagsy.c @@ -0,0 +1,702 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAGSY */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, K, LDA, N */ +/* INTEGER ISEED( 4 ) */ +/* REAL A( LDA, * ), D( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAGSY generates a real symmetric matrix A, by pre- and post- */ +/* > multiplying a real diagonal matrix D with a random orthogonal matrix: */ +/* > A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */ +/* > orthogonal transformations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of nonzero subdiagonals within the band of A. */ +/* > 0 <= K <= N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The generated n by n symmetric matrix A (the full matrix is */ +/* > stored). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slagsy_(integer *n, integer *k, real *d__, real *a, + integer *lda, integer *iseed, real *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + extern real sdot_(integer *, real *, integer *, real *, integer *), + snrm2_(integer *, real *, integer *); + integer i__, j; + extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + real alpha; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *), saxpy_( + integer *, real *, real *, integer *, real *, integer *), ssymv_( + char *, integer *, real *, real *, integer *, real *, integer *, + real *, real *, integer *); + real wa, wb, wn; + extern /* Subroutine */ int xerbla_(char *, integer *), slarnv_( + integer *, integer *, integer *, real *); + real tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*k < 0 || *k > *n - 1) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("SLAGSY", &i__1); + return 0; + } + +/* initialize lower triangle of A to diagonal matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.f; +/* L10: */ + } +/* L20: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + i__ * a_dim1] = d__[i__]; +/* L30: */ + } + +/* Generate lower triangle of symmetric matrix */ + + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + slarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = snrm2_(&i__1, &work[1], &c__1); + wa = r_sign(&wn, &work[1]); + if (wn == 0.f) { + tau = 0.f; + } else { + wb = work[1] + wa; + i__1 = *n - i__; + r__1 = 1.f / wb; + sscal_(&i__1, &r__1, &work[2], &c__1); + work[1] = 1.f; + tau = wb / wa; + } + +/* apply random reflection to A(i:n,i:n) from the left */ +/* and the right */ + +/* compute y := tau * A * u */ + + i__1 = *n - i__ + 1; + ssymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], & + c__1, &c_b12, &work[*n + 1], &c__1); + +/* compute v := y - 1/2 * tau * ( y, u ) * u */ + + i__1 = *n - i__ + 1; + alpha = tau * -.5f * sdot_(&i__1, &work[*n + 1], &c__1, &work[1], & + c__1); + i__1 = *n - i__ + 1; + saxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1); + +/* apply the transformation as a rank-2 update to A(i:n,i:n) */ + + i__1 = *n - i__ + 1; + ssyr2_("Lower", &i__1, &c_b19, &work[1], &c__1, &work[*n + 1], &c__1, + &a[i__ + i__ * a_dim1], lda); +/* L40: */ + } + +/* Reduce number of subdiagonals to K */ + + i__1 = *n - 1 - *k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* generate reflection to annihilate A(k+i+1:n,i) */ + + i__2 = *n - *k - i__ + 1; + wn = snrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); + wa = r_sign(&wn, &a[*k + i__ + i__ * a_dim1]); + if (wn == 0.f) { + tau = 0.f; + } else { + wb = a[*k + i__ + i__ * a_dim1] + wa; + i__2 = *n - *k - i__; + r__1 = 1.f / wb; + sscal_(&i__2, &r__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1); + a[*k + i__ + i__ * a_dim1] = 1.f; + tau = wb / wa; + } + +/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */ + + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + sgemv_("Transpose", &i__2, &i__3, &c_b26, &a[*k + i__ + (i__ + 1) * + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, & + work[1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + r__1 = -tau; + sger_(&i__2, &i__3, &r__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[ + 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda); + +/* apply reflection to A(k+i:n,k+i:n) from the left and the right */ + +/* compute y := tau * A * u */ + + i__2 = *n - *k - i__ + 1; + ssymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, + &a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, &work[1], &c__1); + +/* compute v := y - 1/2 * tau * ( y, u ) * u */ + + i__2 = *n - *k - i__ + 1; + alpha = tau * -.5f * sdot_(&i__2, &work[1], &c__1, &a[*k + i__ + i__ * + a_dim1], &c__1); + i__2 = *n - *k - i__ + 1; + saxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & + c__1); + +/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */ + + i__2 = *n - *k - i__ + 1; + ssyr2_("Lower", &i__2, &c_b19, &a[*k + i__ + i__ * a_dim1], &c__1, & + work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda); + + a[*k + i__ + i__ * a_dim1] = -wa; + i__2 = *n; + for (j = *k + i__ + 1; j <= i__2; ++j) { + a[j + i__ * a_dim1] = 0.f; +/* L50: */ + } +/* L60: */ + } + +/* Store full symmetric matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = a[i__ + j * a_dim1]; +/* L70: */ + } +/* L80: */ + } + return 0; + +/* End of SLAGSY */ + +} /* slagsy_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slahilb.c b/lapack-netlib/TESTING/MATGEN/slahilb.c new file mode 100644 index 000000000..a9dafa8a8 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slahilb.c @@ -0,0 +1,626 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAHILB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) */ + +/* INTEGER N, NRHS, LDA, LDX, LDB, INFO */ +/* REAL A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAHILB generates an N by N scaled Hilbert matrix in A along with */ +/* > NRHS right-hand sides in B and solutions in X such that A*X=B. */ +/* > */ +/* > The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */ +/* > entries are integers. The right-hand sides are the first NRHS */ +/* > columns of M * the identity matrix, and the solutions are the */ +/* > first NRHS columns of the inverse Hilbert matrix. */ +/* > */ +/* > The condition number of the Hilbert matrix grows exponentially with */ +/* > its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */ +/* > Hilbert matrices beyond a relatively small dimension cannot be */ +/* > generated exactly without extra precision. Precision is exhausted */ +/* > when the largest entry in the inverse Hilbert matrix is greater than */ +/* > 2 to the power of the number of bits in the fraction of the data type */ +/* > used plus one, which is 24 for single precision. */ +/* > */ +/* > In single, the generated solution is exact for N <= 6 and has */ +/* > small componentwise error for 7 <= N <= 11. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The requested number of right-hand sides. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA, N) */ +/* > The generated scaled Hilbert matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX, NRHS) */ +/* > The generated exact solutions. Currently, the first NRHS */ +/* > columns of the inverse Hilbert matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB, NRHS) */ +/* > The generated right-hand sides. Currently, the first NRHS */ +/* > columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > = 1: N is too large; the data is still generated but may not */ +/* > be not exact. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slahilb_(integer *n, integer *nrhs, real *a, integer * + lda, real *x, integer *ldx, real *b, integer *ldb, real *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2; + real r__1; + + /* Local variables */ + integer i__, j, m, r__, ti, tm; + extern /* Subroutine */ int xerbla_(char *, integer *), slaset_( + char *, integer *, integer *, real *, real *, real *, integer *); + + +/* -- LAPACK test routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ +/* NMAX_EXACT the largest dimension where the generated data is */ +/* exact. */ +/* NMAX_APPROX the largest dimension where the generated data has */ +/* a small componentwise relative error. */ + +/* Test the input arguments */ + + /* Parameter adjustments */ + --work; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0 || *n > 11) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*lda < *n) { + *info = -4; + } else if (*ldx < *n) { + *info = -6; + } else if (*ldb < *n) { + *info = -8; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("SLAHILB", &i__1); + return 0; + } + if (*n > 6) { + *info = 1; + } + +/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */ +/* reasonable N is small enough that integers suffice (up to N = 11). */ + m = 1; + i__1 = (*n << 1) - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + tm = m; + ti = i__; + r__ = tm % ti; + while(r__ != 0) { + tm = ti; + ti = r__; + r__ = tm % ti; + } + m = m / ti * i__; + } + +/* Generate the scaled Hilbert matrix in A */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = (real) m / (i__ + j - 1); + } + } + +/* Generate matrix B as simply the first NRHS columns of M * the */ +/* identity. */ + r__1 = (real) m; + slaset_("Full", n, nrhs, &c_b4, &r__1, &b[b_offset], ldb); + +/* Generate the true solutions in X. Because B = the first NRHS */ +/* columns of M*I, the true solutions are just the first NRHS columns */ +/* of the inverse Hilbert matrix. */ + work[1] = (real) (*n); + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j - + 1); + } + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] = work[i__] * work[j] / (i__ + j - 1); + } + } + + return 0; +} /* slahilb_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slakf2.c b/lapack-netlib/TESTING/MATGEN/slakf2.c new file mode 100644 index 000000000..7335b0b11 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slakf2.c @@ -0,0 +1,614 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAKF2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) */ + +/* INTEGER LDA, LDZ, M, N */ +/* REAL A( LDA, * ), B( LDA, * ), D( LDA, * ), */ +/* $ E( LDA, * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Form the 2*M*N by 2*M*N matrix */ +/* > */ +/* > Z = [ kron(In, A) -kron(B', Im) ] */ +/* > [ kron(In, D) -kron(E', Im) ], */ +/* > */ +/* > where In is the identity matrix of size n and X' is the transpose */ +/* > of X. kron(X, Y) is the Kronecker product between the matrices X */ +/* > and Y. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Size of matrix, must be >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Size of matrix, must be >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL, dimension ( LDA, M ) */ +/* > The matrix A in the output matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A, B, D, and E. ( LDA >= M+N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL, dimension ( LDA, N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL, dimension ( LDA, M ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL, dimension ( LDA, N ) */ +/* > */ +/* > The matrices used in forming the output matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is REAL, dimension ( LDZ, 2*M*N ) */ +/* > The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of Z. ( LDZ >= 2*M*N ) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slakf2_(integer *m, integer *n, real *a, integer *lda, + real *b, real *d__, real *e, real *z__, integer *ldz) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1, + e_offset, z_dim1, z_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, l, ik, jk, mn; + extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, + real *, real *, integer *); + integer mn2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ==================================================================== */ + + +/* Initialize Z */ + + /* Parameter adjustments */ + e_dim1 = *lda; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + d_dim1 = *lda; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + b_dim1 = *lda; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + + /* Function Body */ + mn = *m * *n; + mn2 = mn << 1; + slaset_("Full", &mn2, &mn2, &c_b3, &c_b3, &z__[z_offset], ldz); + + ik = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + +/* form kron(In, A) */ + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m; + for (j = 1; j <= i__3; ++j) { + z__[ik + i__ - 1 + (ik + j - 1) * z_dim1] = a[i__ + j * + a_dim1]; +/* L10: */ + } +/* L20: */ + } + +/* form kron(In, D) */ + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m; + for (j = 1; j <= i__3; ++j) { + z__[ik + mn + i__ - 1 + (ik + j - 1) * z_dim1] = d__[i__ + j * + d_dim1]; +/* L30: */ + } +/* L40: */ + } + + ik += *m; +/* L50: */ + } + + ik = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + jk = mn + 1; + + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + +/* form -kron(B', Im) */ + + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + z__[ik + i__ - 1 + (jk + i__ - 1) * z_dim1] = -b[j + l * + b_dim1]; +/* L60: */ + } + +/* form -kron(E', Im) */ + + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + z__[ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1] = -e[j + l * + e_dim1]; +/* L70: */ + } + + jk += *m; +/* L80: */ + } + + ik += *m; +/* L90: */ + } + + return 0; + +/* End of SLAKF2 */ + +} /* slakf2_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slaran.c b/lapack-netlib/TESTING/MATGEN/slaran.c new file mode 100644 index 000000000..d28258f85 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slaran.c @@ -0,0 +1,527 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLARAN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLARAN( ISEED ) */ + +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARAN returns a random real number from a uniform (0,1) */ +/* > distribution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine uses a multiplicative congruential method with modulus */ +/* > 2**48 and multiplier 33952834046453 (see G.S.Fishman, */ +/* > 'Multiplicative congruential random number generators with modulus */ +/* > 2**b: an exhaustive analysis for b = 32 and a partial analysis for */ +/* > b = 48', Math. Comp. 189, pp 331-344, 1990). */ +/* > */ +/* > 48-bit integers are stored in 4 integer array elements with 12 bits */ +/* > per element. Hence the routine is portable across machines with */ +/* > integers of 32 bits or more. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +real slaran_(integer *iseed) +{ + /* System generated locals */ + real ret_val; + + /* Local variables */ + real rndout; + integer it1, it2, it3, it4; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + /* Parameter adjustments */ + --iseed; + + /* Function Body */ +L10: + +/* multiply the seed by the multiplier modulo 2**48 */ + + it4 = iseed[4] * 2549; + it3 = it4 / 4096; + it4 -= it3 << 12; + it3 = it3 + iseed[3] * 2549 + iseed[4] * 2508; + it2 = it3 / 4096; + it3 -= it2 << 12; + it2 = it2 + iseed[2] * 2549 + iseed[3] * 2508 + iseed[4] * 322; + it1 = it2 / 4096; + it2 -= it1 << 12; + it1 = it1 + iseed[1] * 2549 + iseed[2] * 2508 + iseed[3] * 322 + iseed[4] + * 494; + it1 %= 4096; + +/* return updated seed */ + + iseed[1] = it1; + iseed[2] = it2; + iseed[3] = it3; + iseed[4] = it4; + +/* convert 48-bit integer to a real number in the interval (0,1) */ + + rndout = ((real) it1 + ((real) it2 + ((real) it3 + (real) it4 * + 2.44140625e-4f) * 2.44140625e-4f) * 2.44140625e-4f) * + 2.44140625e-4f; + + if (rndout == 1.f) { +/* If a real number has n bits of precision, and the first */ +/* n bits of the 48-bit integer above happen to be all 1 (which */ +/* will occur about once every 2**n calls), then SLARAN will */ +/* be rounded to exactly 1.0. In IEEE single precision arithmetic, */ +/* this will happen relatively often since n = 24. */ +/* Since SLARAN is not supposed to return exactly 0.0 or 1.0 */ +/* (and some callers of SLARAN, such as CLARND, depend on that), */ +/* the statistically correct thing to do in this situation is */ +/* simply to iterate again. */ +/* N.B. the case SLARAN = 0.0 should not be possible. */ + + goto L10; + } + + ret_val = rndout; + return ret_val; + +/* End of SLARAN */ + +} /* slaran_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slarge.c b/lapack-netlib/TESTING/MATGEN/slarge.c new file mode 100644 index 000000000..966cd457a --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slarge.c @@ -0,0 +1,579 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLARGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARGE( N, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, LDA, N */ +/* INTEGER ISEED( 4 ) */ +/* REAL A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARGE pre- and post-multiplies a real general n by n matrix A */ +/* > with a random orthogonal matrix: A = U*D*U'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the original n by n matrix A. */ +/* > On exit, A is overwritten by U*A*U' for some random */ +/* > orthogonal matrix U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slarge_(integer *n, real *a, integer *lda, integer * + iseed, real *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + extern real snrm2_(integer *, real *, integer *); + integer i__; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *); + real wa, wb, wn; + extern /* Subroutine */ int xerbla_(char *, integer *), slarnv_( + integer *, integer *, integer *, real *); + real tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*lda < f2cmax(1,*n)) { + *info = -3; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("SLARGE", &i__1); + return 0; + } + +/* pre- and post-multiply A by random orthogonal matrix */ + + for (i__ = *n; i__ >= 1; --i__) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + slarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = snrm2_(&i__1, &work[1], &c__1); + wa = r_sign(&wn, &work[1]); + if (wn == 0.f) { + tau = 0.f; + } else { + wb = work[1] + wa; + i__1 = *n - i__; + r__1 = 1.f / wb; + sscal_(&i__1, &r__1, &work[2], &c__1); + work[1] = 1.f; + tau = wb / wa; + } + +/* multiply A(i:n,1:n) by random reflection from the left */ + + i__1 = *n - i__ + 1; + sgemv_("Transpose", &i__1, n, &c_b8, &a[i__ + a_dim1], lda, &work[1], + &c__1, &c_b10, &work[*n + 1], &c__1); + i__1 = *n - i__ + 1; + r__1 = -tau; + sger_(&i__1, n, &r__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__ + + a_dim1], lda); + +/* multiply A(1:n,i:n) by random reflection from the right */ + + i__1 = *n - i__ + 1; + sgemv_("No transpose", n, &i__1, &c_b8, &a[i__ * a_dim1 + 1], lda, & + work[1], &c__1, &c_b10, &work[*n + 1], &c__1); + i__1 = *n - i__ + 1; + r__1 = -tau; + sger_(n, &i__1, &r__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ * + a_dim1 + 1], lda); +/* L10: */ + } + return 0; + +/* End of SLARGE */ + +} /* slarge_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slarnd.c b/lapack-netlib/TESTING/MATGEN/slarnd.c new file mode 100644 index 000000000..163cc08cf --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slarnd.c @@ -0,0 +1,508 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLARND */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLARND( IDIST, ISEED ) */ + +/* INTEGER IDIST */ +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARND returns a random real number from a uniform or normal */ +/* > distribution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > Specifies the distribution of the random numbers: */ +/* > = 1: uniform (0,1) */ +/* > = 2: uniform (-1,1) */ +/* > = 3: normal (0,1) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine calls the auxiliary routine SLARAN to generate a random */ +/* > real number from a uniform (0,1) distribution. The Box-Muller method */ +/* > is used to transform numbers from a uniform to a normal distribution. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +real slarnd_(integer *idist, integer *iseed) +{ + /* System generated locals */ + real ret_val; + + /* Local variables */ + real t1, t2; + extern real slaran_(integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Generate a real random number from a uniform (0,1) distribution */ + + /* Parameter adjustments */ + --iseed; + + /* Function Body */ + t1 = slaran_(&iseed[1]); + + if (*idist == 1) { + +/* uniform (0,1) */ + + ret_val = t1; + } else if (*idist == 2) { + +/* uniform (-1,1) */ + + ret_val = t1 * 2.f - 1.f; + } else if (*idist == 3) { + +/* normal (0,1) */ + + t2 = slaran_(&iseed[1]); + ret_val = sqrt(log(t1) * -2.f) * cos(t2 * + 6.2831853071795864769252867663f); + } + return ret_val; + +/* End of SLARND */ + +} /* slarnd_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slaror.c b/lapack-netlib/TESTING/MATGEN/slaror.c new file mode 100644 index 000000000..d7075fa21 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slaror.c @@ -0,0 +1,718 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAROR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) */ + +/* CHARACTER INIT, SIDE */ +/* INTEGER INFO, LDA, M, N */ +/* INTEGER ISEED( 4 ) */ +/* REAL A( LDA, * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAROR pre- or post-multiplies an M by N matrix A by a random */ +/* > orthogonal matrix U, overwriting A. A may optionally be initialized */ +/* > to the identity matrix before multiplying by U. U is generated using */ +/* > the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > Specifies whether A is multiplied on the left or right by U. */ +/* > = 'L': Multiply A on the left (premultiply) by U */ +/* > = 'R': Multiply A on the right (postmultiply) by U' */ +/* > = 'C' or 'T': Multiply A on the left by U and the right */ +/* > by U' (Here, U' means U-transpose.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INIT */ +/* > \verbatim */ +/* > INIT is CHARACTER*1 */ +/* > Specifies whether or not A should be initialized to the */ +/* > identity matrix. */ +/* > = 'I': Initialize A to (a section of) the identity matrix */ +/* > before applying U. */ +/* > = 'N': No initialization. Apply U to the input matrix A. */ +/* > */ +/* > INIT = 'I' may be used to generate square or rectangular */ +/* > orthogonal matrices: */ +/* > */ +/* > For M = N and SIDE = 'L' or 'R', the rows will be orthogonal */ +/* > to each other, as will the columns. */ +/* > */ +/* > If M < N, SIDE = 'R' produces a dense matrix whose rows are */ +/* > orthogonal and whose columns are not, while SIDE = 'L' */ +/* > produces a matrix whose rows are orthogonal, and whose first */ +/* > M columns are orthogonal, and whose remaining columns are */ +/* > zero. */ +/* > */ +/* > If M > N, SIDE = 'L' produces a dense matrix whose columns */ +/* > are orthogonal and whose rows are not, while SIDE = 'R' */ +/* > produces a matrix whose columns are orthogonal, and whose */ +/* > first M rows are orthogonal, and whose remaining rows are */ +/* > zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA, N) */ +/* > On entry, the array A. */ +/* > On exit, overwritten by U A ( if SIDE = 'L' ), */ +/* > or by A U ( if SIDE = 'R' ), */ +/* > or by U A U' ( if SIDE = 'C' or 'T'). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. The array elements should be between 0 and 4095; */ +/* > if not they will be reduced mod 4096. Also, ISEED(4) must */ +/* > be odd. The random number generator uses a linear */ +/* > congruential sequence limited to small integers, and so */ +/* > should produce machine independent random numbers. The */ +/* > values of ISEED are changed on exit, and can be used in the */ +/* > next call to SLAROR to continue the same random number */ +/* > sequence. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (3*MAX( M, N )) */ +/* > Workspace of length */ +/* > 2*M + N if SIDE = 'L', */ +/* > 2*N + M if SIDE = 'R', */ +/* > 3*N if SIDE = 'C' or 'T'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > An error flag. It is set to: */ +/* > = 0: normal return */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > = 1: if the random numbers generated by SLARND are bad. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slaror_(char *side, char *init, integer *m, integer *n, + real *a, integer *lda, integer *iseed, real *x, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real r__1; + + /* Local variables */ + integer kbeg, jcol; + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + integer irow; + extern real snrm2_(integer *, real *, integer *); + integer j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *); + integer ixfrm, itype, nxfrm; + real xnorm; + extern /* Subroutine */ int xerbla_(char *, integer *); + real factor; + extern real slarnd_(integer *, integer *); + extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, + real *, real *, integer *); + real xnorms; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --x; + + /* Function Body */ + *info = 0; + if (*n == 0 || *m == 0) { + return 0; + } + + itype = 0; + if (lsame_(side, "L")) { + itype = 1; + } else if (lsame_(side, "R")) { + itype = 2; + } else if (lsame_(side, "C") || lsame_(side, "T")) { + itype = 3; + } + +/* Check for argument errors. */ + + if (itype == 0) { + *info = -1; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0 || itype == 3 && *n != *m) { + *info = -4; + } else if (*lda < *m) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAROR", &i__1); + return 0; + } + + if (itype == 1) { + nxfrm = *m; + } else { + nxfrm = *n; + } + +/* Initialize A to the identity matrix if desired */ + + if (lsame_(init, "I")) { + slaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda); + } + +/* If no rotation possible, multiply by random +/-1 */ + +/* Compute rotation by computing Householder transformations */ +/* H(2), H(3), ..., H(nhouse) */ + + i__1 = nxfrm; + for (j = 1; j <= i__1; ++j) { + x[j] = 0.f; +/* L10: */ + } + + i__1 = nxfrm; + for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) { + kbeg = nxfrm - ixfrm + 1; + +/* Generate independent normal( 0, 1 ) random numbers */ + + i__2 = nxfrm; + for (j = kbeg; j <= i__2; ++j) { + x[j] = slarnd_(&c__3, &iseed[1]); +/* L20: */ + } + +/* Generate a Householder transformation from the random vector X */ + + xnorm = snrm2_(&ixfrm, &x[kbeg], &c__1); + xnorms = r_sign(&xnorm, &x[kbeg]); + r__1 = -x[kbeg]; + x[kbeg + nxfrm] = r_sign(&c_b10, &r__1); + factor = xnorms * (xnorms + x[kbeg]); + if (abs(factor) < 1e-20f) { + *info = 1; + xerbla_("SLAROR", info); + return 0; + } else { + factor = 1.f / factor; + } + x[kbeg] += xnorms; + +/* Apply Householder transformation to A */ + + if (itype == 1 || itype == 3) { + +/* Apply H(k) from the left. */ + + sgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], & + c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1); + r__1 = -factor; + sger_(&ixfrm, n, &r__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], & + c__1, &a[kbeg + a_dim1], lda); + + } + + if (itype == 2 || itype == 3) { + +/* Apply H(k) from the right. */ + + sgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[ + kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1); + r__1 = -factor; + sger_(m, &ixfrm, &r__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], & + c__1, &a[kbeg * a_dim1 + 1], lda); + + } +/* L30: */ + } + + r__1 = slarnd_(&c__3, &iseed[1]); + x[nxfrm * 2] = r_sign(&c_b10, &r__1); + +/* Scale the matrix A by D. */ + + if (itype == 1 || itype == 3) { + i__1 = *m; + for (irow = 1; irow <= i__1; ++irow) { + sscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda); +/* L40: */ + } + } + + if (itype == 2 || itype == 3) { + i__1 = *n; + for (jcol = 1; jcol <= i__1; ++jcol) { + sscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1); +/* L50: */ + } + } + return 0; + +/* End of SLAROR */ + +} /* slaror_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slarot.c b/lapack-netlib/TESTING/MATGEN/slarot.c new file mode 100644 index 000000000..67b623fb7 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slarot.c @@ -0,0 +1,709 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAROT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, */ +/* XRIGHT ) */ + +/* LOGICAL LLEFT, LRIGHT, LROWS */ +/* INTEGER LDA, NL */ +/* REAL C, S, XLEFT, XRIGHT */ +/* REAL A( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAROT applies a (Givens) rotation to two adjacent rows or */ +/* > columns, where one element of the first and/or last column/row */ +/* > for use on matrices stored in some format other than GE, so */ +/* > that elements of the matrix may be used or modified for which */ +/* > no array element is provided. */ +/* > */ +/* > One example is a symmetric matrix in SB format (bandwidth=4), for */ +/* > which UPLO='L': Two adjacent rows will have the format: */ +/* > */ +/* > row j: C> C> C> C> C> . . . . */ +/* > row j+1: C> C> C> C> C> . . . . */ +/* > */ +/* > '*' indicates elements for which storage is provided, */ +/* > '.' indicates elements for which no storage is provided, but */ +/* > are not necessarily zero; their values are determined by */ +/* > symmetry. ' ' indicates elements which are necessarily zero, */ +/* > and have no storage provided. */ +/* > */ +/* > Those columns which have two '*'s can be handled by SROT. */ +/* > Those columns which have no '*'s can be ignored, since as long */ +/* > as the Givens rotations are carefully applied to preserve */ +/* > symmetry, their values are determined. */ +/* > Those columns which have one '*' have to be handled separately, */ +/* > by using separate variables "p" and "q": */ +/* > */ +/* > row j: C> C> C> C> C> p . . . */ +/* > row j+1: q C> C> C> C> C> . . . . */ +/* > */ +/* > The element p would have to be set correctly, then that column */ +/* > is rotated, setting p to its new value. The next call to */ +/* > SLAROT would rotate columns j and j+1, using p, and restore */ +/* > symmetry. The element q would start out being zero, and be */ +/* > made non-zero by the rotation. Later, rotations would presumably */ +/* > be chosen to zero q out. */ +/* > */ +/* > Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */ +/* > ------- ------- --------- */ +/* > */ +/* > General dense matrix: */ +/* > */ +/* > CALL SLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */ +/* > A(i,1),LDA, DUMMY, DUMMY) */ +/* > */ +/* > General banded matrix in GB format: */ +/* > */ +/* > j = MAX(1, i-KL ) */ +/* > NL = MIN( N, i+KU+1 ) + 1-j */ +/* > CALL SLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */ +/* > A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > [ note that i+1-j is just MIN(i,KL+1) ] */ +/* > */ +/* > Symmetric banded matrix in SY format, bandwidth K, */ +/* > lower triangle only: */ +/* > */ +/* > j = MAX(1, i-K ) */ +/* > NL = MIN( K+1, i ) + 1 */ +/* > CALL SLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */ +/* > A(i,j), LDA, XLEFT, XRIGHT ) */ +/* > */ +/* > Same, but upper triangle only: */ +/* > */ +/* > NL = MIN( K+1, N-i ) + 1 */ +/* > CALL SLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */ +/* > A(i,i), LDA, XLEFT, XRIGHT ) */ +/* > */ +/* > Symmetric banded matrix in SB format, bandwidth K, */ +/* > lower triangle only: */ +/* > */ +/* > [ same as for SY, except:] */ +/* > . . . . */ +/* > A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > [ note that i+1-j is just MIN(i,K+1) ] */ +/* > */ +/* > Same, but upper triangle only: */ +/* > . . . */ +/* > A(K+1,i), LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > Rotating columns is just the transpose of rotating rows, except */ +/* > for GB and SB: (rotating columns i and i+1) */ +/* > */ +/* > GB: */ +/* > j = MAX(1, i-KU ) */ +/* > NL = MIN( N, i+KL+1 ) + 1-j */ +/* > CALL SLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */ +/* > A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ +/* > */ +/* > [note that KU+j+1-i is just MAX(1,KU+2-i)] */ +/* > */ +/* > SB: (upper triangle) */ +/* > */ +/* > . . . . . . */ +/* > A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ +/* > */ +/* > SB: (lower triangle) */ +/* > */ +/* > . . . . . . */ +/* > A(1,i),LDA-1, XTOP, XBOTTM ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > LROWS - LOGICAL */ +/* > If .TRUE., then SLAROT will rotate two rows. If .FALSE., */ +/* > then it will rotate two columns. */ +/* > Not modified. */ +/* > */ +/* > LLEFT - LOGICAL */ +/* > If .TRUE., then XLEFT will be used instead of the */ +/* > corresponding element of A for the first element in the */ +/* > second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */ +/* > If .FALSE., then the corresponding element of A will be */ +/* > used. */ +/* > Not modified. */ +/* > */ +/* > LRIGHT - LOGICAL */ +/* > If .TRUE., then XRIGHT will be used instead of the */ +/* > corresponding element of A for the last element in the */ +/* > first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */ +/* > .FALSE., then the corresponding element of A will be used. */ +/* > Not modified. */ +/* > */ +/* > NL - INTEGER */ +/* > The length of the rows (if LROWS=.TRUE.) or columns (if */ +/* > LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are */ +/* > used, the columns/rows they are in should be included in */ +/* > NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */ +/* > least 2. The number of rows/columns to be rotated */ +/* > exclusive of those involving XLEFT and/or XRIGHT may */ +/* > not be negative, i.e., NL minus how many of LLEFT and */ +/* > LRIGHT are .TRUE. must be at least zero; if not, XERBLA */ +/* > will be called. */ +/* > Not modified. */ +/* > */ +/* > C, S - REAL */ +/* > Specify the Givens rotation to be applied. If LROWS is */ +/* > true, then the matrix ( c s ) */ +/* > (-s c ) is applied from the left; */ +/* > if false, then the transpose thereof is applied from the */ +/* > right. For a Givens rotation, C**2 + S**2 should be 1, */ +/* > but this is not checked. */ +/* > Not modified. */ +/* > */ +/* > A - REAL array. */ +/* > The array containing the rows/columns to be rotated. The */ +/* > first element of A should be the upper left element to */ +/* > be rotated. */ +/* > Read and modified. */ +/* > */ +/* > LDA - INTEGER */ +/* > The "effective" leading dimension of A. If A contains */ +/* > a matrix stored in GE or SY format, then this is just */ +/* > the leading dimension of A as dimensioned in the calling */ +/* > routine. If A contains a matrix stored in band (GB or SB) */ +/* > format, then this should be *one less* than the leading */ +/* > dimension used in the calling routine. Thus, if */ +/* > A were dimensioned A(LDA,*) in SLAROT, then A(1,j) would */ +/* > be the j-th element in the first of the two rows */ +/* > to be rotated, and A(2,j) would be the j-th in the second, */ +/* > regardless of how the array may be stored in the calling */ +/* > routine. [A cannot, however, actually be dimensioned thus, */ +/* > since for band format, the row number may exceed LDA, which */ +/* > is not legal FORTRAN.] */ +/* > If LROWS=.TRUE., then LDA must be at least 1, otherwise */ +/* > it must be at least NL minus the number of .TRUE. values */ +/* > in XLEFT and XRIGHT. */ +/* > Not modified. */ +/* > */ +/* > XLEFT - REAL */ +/* > If LLEFT is .TRUE., then XLEFT will be used and modified */ +/* > instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */ +/* > (if LROWS=.FALSE.). */ +/* > Read and modified. */ +/* > */ +/* > XRIGHT - REAL */ +/* > If LRIGHT is .TRUE., then XRIGHT will be used and modified */ +/* > instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */ +/* > (if LROWS=.FALSE.). */ +/* > Read and modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slarot_(logical *lrows, logical *lleft, logical *lright, + integer *nl, real *c__, real *s, real *a, integer *lda, real *xleft, + real *xright) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer iinc; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + integer inext, ix, iy, nt; + real xt[2], yt[2]; + extern /* Subroutine */ int xerbla_(char *, integer *); + integer iyt; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Set up indices, arrays for ends */ + + /* Parameter adjustments */ + --a; + + /* Function Body */ + if (*lrows) { + iinc = *lda; + inext = 1; + } else { + iinc = 1; + inext = *lda; + } + + if (*lleft) { + nt = 1; + ix = iinc + 1; + iy = *lda + 2; + xt[0] = a[1]; + yt[0] = *xleft; + } else { + nt = 0; + ix = 1; + iy = inext + 1; + } + + if (*lright) { + iyt = inext + 1 + (*nl - 1) * iinc; + ++nt; + xt[nt - 1] = *xright; + yt[nt - 1] = a[iyt]; + } + +/* Check for errors */ + + if (*nl < nt) { + xerbla_("SLAROT", &c__4); + return 0; + } + if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) { + xerbla_("SLAROT", &c__8); + return 0; + } + +/* Rotate */ + + i__1 = *nl - nt; + srot_(&i__1, &a[ix], &iinc, &a[iy], &iinc, c__, s); + srot_(&nt, xt, &c__1, yt, &c__1, c__, s); + +/* Stuff values back into XLEFT, XRIGHT, etc. */ + + if (*lleft) { + a[1] = xt[0]; + *xleft = yt[0]; + } + + if (*lright) { + *xright = xt[nt - 1]; + a[iyt] = yt[nt - 1]; + } + + return 0; + +/* End of SLAROT */ + +} /* slarot_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slatm1.c b/lapack-netlib/TESTING/MATGEN/slatm1.c new file mode 100644 index 000000000..12fd07fcc --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slatm1.c @@ -0,0 +1,699 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATM1 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) */ + +/* INTEGER IDIST, INFO, IRSIGN, MODE, N */ +/* REAL COND */ +/* INTEGER ISEED( 4 ) */ +/* REAL D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATM1 computes the entries of D(1..N) as specified by */ +/* > MODE, COND and IRSIGN. IDIST and ISEED determine the generation */ +/* > of random numbers. SLATM1 is called by SLATMR to generate */ +/* > random test matrices for LAPACK programs. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry describes how D is to be computed: */ +/* > MODE = 0 means do not change D. */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is REAL */ +/* > On entry, used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IRSIGN */ +/* > \verbatim */ +/* > IRSIGN is INTEGER */ +/* > On entry, if MODE neither -6, 0 nor 6, determines sign of */ +/* > entries of D */ +/* > 0 => leave entries of D unchanged */ +/* > 1 => multiply each entry of D by 1 or -1 with probability .5 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => UNIFORM( 0, 1 ) */ +/* > 2 => UNIFORM( -1, 1 ) */ +/* > 3 => NORMAL( 0, 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. The random number generator uses a */ +/* > linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to SLATM1 */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension ( N ) */ +/* > Array to be computed according to MODE, COND and IRSIGN. */ +/* > May be changed on exit if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of entries of D. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > 0 => normal termination */ +/* > -1 => if MODE not in range -6 to 6 */ +/* > -2 => if MODE neither -6, 0 nor 6, and */ +/* > IRSIGN neither 0 nor 1 */ +/* > -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */ +/* > -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */ +/* > -7 => if N negative */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slatm1_(integer *mode, real *cond, integer *irsign, + integer *idist, integer *iseed, real *d__, integer *n, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + real temp; + integer i__; + real alpha; + extern /* Subroutine */ int xerbla_(char *, integer *); + extern real slaran_(integer *); + extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real + *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and Test the input parameters. Initialize flags & seed. */ + + /* Parameter adjustments */ + --d__; + --iseed; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Set INFO if an error */ + + if (*mode < -6 || *mode > 6) { + *info = -1; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && * + irsign != 1)) { + *info = -2; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) { + *info = -3; + } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) { + *info = -4; + } else if (*n < 0) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLATM1", &i__1); + return 0; + } + +/* Compute D according to COND and MODE */ + + if (*mode != 0) { + switch (abs(*mode)) { + case 1: goto L10; + case 2: goto L30; + case 3: goto L50; + case 4: goto L70; + case 5: goto L90; + case 6: goto L110; + } + +/* One large D value: */ + +L10: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = 1.f / *cond; +/* L20: */ + } + d__[1] = 1.f; + goto L120; + +/* One small D value: */ + +L30: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = 1.f; +/* L40: */ + } + d__[*n] = 1.f / *cond; + goto L120; + +/* Exponentially distributed D values: */ + +L50: + d__[1] = 1.f; + if (*n > 1) { + d__1 = (doublereal) (*cond); + d__2 = (doublereal) (-1.f / (real) (*n - 1)); + alpha = pow_dd(&d__1, &d__2); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ - 1; + d__[i__] = pow_ri(&alpha, &i__2); +/* L60: */ + } + } + goto L120; + +/* Arithmetically distributed D values: */ + +L70: + d__[1] = 1.f; + if (*n > 1) { + temp = 1.f / *cond; + alpha = (1.f - temp) / (real) (*n - 1); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + d__[i__] = (real) (*n - i__) * alpha + temp; +/* L80: */ + } + } + goto L120; + +/* Randomly distributed D values on ( 1/COND , 1): */ + +L90: + alpha = log(1.f / *cond); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = exp(alpha * slaran_(&iseed[1])); +/* L100: */ + } + goto L120; + +/* Randomly distributed D values from IDIST */ + +L110: + slarnv_(idist, &iseed[1], n, &d__[1]); + +L120: + +/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */ +/* random signs to D */ + + if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = slaran_(&iseed[1]); + if (temp > .5f) { + d__[i__] = -d__[i__]; + } +/* L130: */ + } + } + +/* Reverse if MODE < 0 */ + + if (*mode < 0) { + i__1 = *n / 2; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = d__[i__]; + d__[i__] = d__[*n + 1 - i__]; + d__[*n + 1 - i__] = temp; +/* L140: */ + } + } + + } + + return 0; + +/* End of SLATM1 */ + +} /* slatm1_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slatm2.c b/lapack-netlib/TESTING/MATGEN/slatm2.c new file mode 100644 index 000000000..67b2b9a5b --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slatm2.c @@ -0,0 +1,698 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATM2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLATM2( M, N, I, J, KL, KU, IDIST, */ +/* ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) */ + + +/* INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N */ +/* REAL SPARSE */ + + +/* INTEGER ISEED( 4 ), IWORK( * ) */ +/* REAL D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATM2 returns the (I,J) entry of a random matrix of dimension */ +/* > (M, N) described by the other parameters. It is called by the */ +/* > SLATMR routine in order to build random test matrices. No error */ +/* > checking on parameters is done, because this routine is called in */ +/* > a tight loop by SLATMR which has already checked the parameters. */ +/* > */ +/* > Use of SLATM2 differs from SLATM3 in the order in which the random */ +/* > number generator is called to fill in random matrix entries. */ +/* > With SLATM2, the generator is called to fill in the pivoted matrix */ +/* > columnwise. With SLATM3, the generator is called to fill in the */ +/* > matrix columnwise, after which it is pivoted. Thus, SLATM3 can */ +/* > be used to construct random matrices which differ only in their */ +/* > order of rows and/or columns. SLATM2 is used to construct band */ +/* > matrices while avoiding calling the random number generator for */ +/* > entries outside the band (and therefore generating random numbers */ +/* > */ +/* > The matrix whose (I,J) entry is returned is constructed as */ +/* > follows (this routine only computes one entry): */ +/* > */ +/* > If I is outside (1..M) or J is outside (1..N), return zero */ +/* > (this is convenient for generating matrices in band format). */ +/* > */ +/* > Generate a matrix A with random entries of distribution IDIST. */ +/* > */ +/* > Set the diagonal to D. */ +/* > */ +/* > Grade the matrix, if desired, from the left (by DL) and/or */ +/* > from the right (by DR or DL) as specified by IGRADE. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > IPVTNG and IWORK. */ +/* > */ +/* > Band the matrix to have lower bandwidth KL and upper */ +/* > bandwidth KU. */ +/* > */ +/* > Set random entries to zero as specified by SPARSE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > Row of entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J */ +/* > \verbatim */ +/* > J is INTEGER */ +/* > Column of entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > Lower bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > Upper bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => UNIFORM( 0, 1 ) */ +/* > 2 => UNIFORM( -1, 1 ) */ +/* > 3 => NORMAL( 0, 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array of dimension ( 4 ) */ +/* > Seed for random number generator. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array of dimension ( MIN( I , J ) ) */ +/* > Diagonal entries of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGRADE */ +/* > \verbatim */ +/* > IGRADE is INTEGER */ +/* > Specifies grading of matrix as follows: */ +/* > 0 => no grading */ +/* > 1 => matrix premultiplied by diag( DL ) */ +/* > 2 => matrix postmultiplied by diag( DR ) */ +/* > 3 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > 4 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > 5 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is REAL array ( I or J, as appropriate ) */ +/* > Left scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DR */ +/* > \verbatim */ +/* > DR is REAL array ( I or J, as appropriate ) */ +/* > Right scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPVTNG */ +/* > \verbatim */ +/* > IPVTNG is INTEGER */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 0 => none. */ +/* > 1 => row pivoting. */ +/* > 2 => column pivoting. */ +/* > 3 => full pivoting, i.e., on both sides. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array ( I or J, as appropriate ) */ +/* > This array specifies the permutation used. The */ +/* > row (or column) in position K was originally in */ +/* > position IWORK( K ). */ +/* > This differs from IWORK for SLATM3. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is REAL between 0. and 1. */ +/* > On entry specifies the sparsity of the matrix */ +/* > if sparse matrix is to be generated. */ +/* > SPARSE should lie between 0 and 1. */ +/* > A uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +real slatm2_(integer *m, integer *n, integer *i__, integer *j, integer *kl, + integer *ku, integer *idist, integer *iseed, real *d__, integer * + igrade, real *dl, real *dr, integer *ipvtng, integer *iwork, real * + sparse) +{ + /* System generated locals */ + real ret_val; + + /* Local variables */ + integer isub, jsub; + real temp; + extern real slaran_(integer *), slarnd_(integer *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + + + + +/* ===================================================================== */ + + + + + + + +/* ----------------------------------------------------------------------- */ + + + +/* Check for I and J in range */ + + /* Parameter adjustments */ + --iwork; + --dr; + --dl; + --d__; + --iseed; + + /* Function Body */ + if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) { + ret_val = 0.f; + return ret_val; + } + +/* Check for banding */ + + if (*j > *i__ + *ku || *j < *i__ - *kl) { + ret_val = 0.f; + return ret_val; + } + +/* Check for sparsity */ + + if (*sparse > 0.f) { + if (slaran_(&iseed[1]) < *sparse) { + ret_val = 0.f; + return ret_val; + } + } + +/* Compute subscripts depending on IPVTNG */ + + if (*ipvtng == 0) { + isub = *i__; + jsub = *j; + } else if (*ipvtng == 1) { + isub = iwork[*i__]; + jsub = *j; + } else if (*ipvtng == 2) { + isub = *i__; + jsub = iwork[*j]; + } else if (*ipvtng == 3) { + isub = iwork[*i__]; + jsub = iwork[*j]; + } + +/* Compute entry and grade it according to IGRADE */ + + if (isub == jsub) { + temp = d__[isub]; + } else { + temp = slarnd_(idist, &iseed[1]); + } + if (*igrade == 1) { + temp *= dl[isub]; + } else if (*igrade == 2) { + temp *= dr[jsub]; + } else if (*igrade == 3) { + temp = temp * dl[isub] * dr[jsub]; + } else if (*igrade == 4 && isub != jsub) { + temp = temp * dl[isub] / dl[jsub]; + } else if (*igrade == 5) { + temp = temp * dl[isub] * dl[jsub]; + } + ret_val = temp; + return ret_val; + +/* End of SLATM2 */ + +} /* slatm2_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slatm3.c b/lapack-netlib/TESTING/MATGEN/slatm3.c new file mode 100644 index 000000000..903f201b8 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slatm3.c @@ -0,0 +1,716 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATM3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, */ +/* IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, */ +/* SPARSE ) */ + + +/* INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, */ +/* $ KU, M, N */ +/* REAL SPARSE */ + + +/* INTEGER ISEED( 4 ), IWORK( * ) */ +/* REAL D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATM3 returns the (ISUB,JSUB) entry of a random matrix of */ +/* > dimension (M, N) described by the other parameters. (ISUB,JSUB) */ +/* > is the final position of the (I,J) entry after pivoting */ +/* > according to IPVTNG and IWORK. SLATM3 is called by the */ +/* > SLATMR routine in order to build random test matrices. No error */ +/* > checking on parameters is done, because this routine is called in */ +/* > a tight loop by SLATMR which has already checked the parameters. */ +/* > */ +/* > Use of SLATM3 differs from SLATM2 in the order in which the random */ +/* > number generator is called to fill in random matrix entries. */ +/* > With SLATM2, the generator is called to fill in the pivoted matrix */ +/* > columnwise. With SLATM3, the generator is called to fill in the */ +/* > matrix columnwise, after which it is pivoted. Thus, SLATM3 can */ +/* > be used to construct random matrices which differ only in their */ +/* > order of rows and/or columns. SLATM2 is used to construct band */ +/* > matrices while avoiding calling the random number generator for */ +/* > entries outside the band (and therefore generating random numbers */ +/* > in different orders for different pivot orders). */ +/* > */ +/* > The matrix whose (ISUB,JSUB) entry is returned is constructed as */ +/* > follows (this routine only computes one entry): */ +/* > */ +/* > If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */ +/* > (this is convenient for generating matrices in band format). */ +/* > */ +/* > Generate a matrix A with random entries of distribution IDIST. */ +/* > */ +/* > Set the diagonal to D. */ +/* > */ +/* > Grade the matrix, if desired, from the left (by DL) and/or */ +/* > from the right (by DR or DL) as specified by IGRADE. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > IPVTNG and IWORK. */ +/* > */ +/* > Band the matrix to have lower bandwidth KL and upper */ +/* > bandwidth KU. */ +/* > */ +/* > Set random entries to zero as specified by SPARSE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > Row of unpivoted entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J */ +/* > \verbatim */ +/* > J is INTEGER */ +/* > Column of unpivoted entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISUB */ +/* > \verbatim */ +/* > ISUB is INTEGER */ +/* > Row of pivoted entry to be returned. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JSUB */ +/* > \verbatim */ +/* > JSUB is INTEGER */ +/* > Column of pivoted entry to be returned. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > Lower bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > Upper bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => UNIFORM( 0, 1 ) */ +/* > 2 => UNIFORM( -1, 1 ) */ +/* > 3 => NORMAL( 0, 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array of dimension ( 4 ) */ +/* > Seed for random number generator. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array of dimension ( MIN( I , J ) ) */ +/* > Diagonal entries of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGRADE */ +/* > \verbatim */ +/* > IGRADE is INTEGER */ +/* > Specifies grading of matrix as follows: */ +/* > 0 => no grading */ +/* > 1 => matrix premultiplied by diag( DL ) */ +/* > 2 => matrix postmultiplied by diag( DR ) */ +/* > 3 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > 4 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > 5 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is REAL array ( I or J, as appropriate ) */ +/* > Left scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DR */ +/* > \verbatim */ +/* > DR is REAL array ( I or J, as appropriate ) */ +/* > Right scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPVTNG */ +/* > \verbatim */ +/* > IPVTNG is INTEGER */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 0 => none. */ +/* > 1 => row pivoting. */ +/* > 2 => column pivoting. */ +/* > 3 => full pivoting, i.e., on both sides. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array ( I or J, as appropriate ) */ +/* > This array specifies the permutation used. The */ +/* > row (or column) originally in position K is in */ +/* > position IWORK( K ) after pivoting. */ +/* > This differs from IWORK for SLATM2. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is REAL between 0. and 1. */ +/* > On entry specifies the sparsity of the matrix */ +/* > if sparse matrix is to be generated. */ +/* > SPARSE should lie between 0 and 1. */ +/* > A uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +real slatm3_(integer *m, integer *n, integer *i__, integer *j, integer *isub, + integer *jsub, integer *kl, integer *ku, integer *idist, integer * + iseed, real *d__, integer *igrade, real *dl, real *dr, integer * + ipvtng, integer *iwork, real *sparse) +{ + /* System generated locals */ + real ret_val; + + /* Local variables */ + real temp; + extern real slaran_(integer *), slarnd_(integer *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + + + + +/* ===================================================================== */ + + + + + + + +/* ----------------------------------------------------------------------- */ + + + +/* Check for I and J in range */ + + /* Parameter adjustments */ + --iwork; + --dr; + --dl; + --d__; + --iseed; + + /* Function Body */ + if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) { + *isub = *i__; + *jsub = *j; + ret_val = 0.f; + return ret_val; + } + +/* Compute subscripts depending on IPVTNG */ + + if (*ipvtng == 0) { + *isub = *i__; + *jsub = *j; + } else if (*ipvtng == 1) { + *isub = iwork[*i__]; + *jsub = *j; + } else if (*ipvtng == 2) { + *isub = *i__; + *jsub = iwork[*j]; + } else if (*ipvtng == 3) { + *isub = iwork[*i__]; + *jsub = iwork[*j]; + } + +/* Check for banding */ + + if (*jsub > *isub + *ku || *jsub < *isub - *kl) { + ret_val = 0.f; + return ret_val; + } + +/* Check for sparsity */ + + if (*sparse > 0.f) { + if (slaran_(&iseed[1]) < *sparse) { + ret_val = 0.f; + return ret_val; + } + } + +/* Compute entry and grade it according to IGRADE */ + + if (*i__ == *j) { + temp = d__[*i__]; + } else { + temp = slarnd_(idist, &iseed[1]); + } + if (*igrade == 1) { + temp *= dl[*i__]; + } else if (*igrade == 2) { + temp *= dr[*j]; + } else if (*igrade == 3) { + temp = temp * dl[*i__] * dr[*j]; + } else if (*igrade == 4 && *i__ != *j) { + temp = temp * dl[*i__] / dl[*j]; + } else if (*igrade == 5) { + temp = temp * dl[*i__] * dl[*j]; + } + ret_val = temp; + return ret_val; + +/* End of SLATM3 */ + +} /* slatm3_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slatm5.c b/lapack-netlib/TESTING/MATGEN/slatm5.c new file mode 100644 index 000000000..764f33e3f --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slatm5.c @@ -0,0 +1,972 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATM5 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, */ +/* E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, */ +/* QBLCKB ) */ + +/* INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, */ +/* $ PRTYPE, QBLCKA, QBLCKB */ +/* REAL ALPHA */ +/* REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), */ +/* $ D( LDD, * ), E( LDE, * ), F( LDF, * ), */ +/* $ L( LDL, * ), R( LDR, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATM5 generates matrices involved in the Generalized Sylvester */ +/* > equation: */ +/* > */ +/* > A * R - L * B = C */ +/* > D * R - L * E = F */ +/* > */ +/* > They also satisfy (the diagonalization condition) */ +/* > */ +/* > [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] ) */ +/* > [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] ) */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PRTYPE */ +/* > \verbatim */ +/* > PRTYPE is INTEGER */ +/* > "Points" to a certain type of the matrices to generate */ +/* > (see further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Specifies the order of A and D and the number of rows in */ +/* > C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Specifies the order of B and E and the number of columns in */ +/* > C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA, M). */ +/* > On exit A M-by-M is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB, N). */ +/* > On exit B N-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC, N). */ +/* > On exit C M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of C. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (LDD, M). */ +/* > On exit D M-by-M is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDD */ +/* > \verbatim */ +/* > LDD is INTEGER */ +/* > The leading dimension of D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (LDE, N). */ +/* > On exit E N-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDE */ +/* > \verbatim */ +/* > LDE is INTEGER */ +/* > The leading dimension of E. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] F */ +/* > \verbatim */ +/* > F is REAL array, dimension (LDF, N). */ +/* > On exit F M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of F. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is REAL array, dimension (LDR, N). */ +/* > On exit R M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDR */ +/* > \verbatim */ +/* > LDR is INTEGER */ +/* > The leading dimension of R. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is REAL array, dimension (LDL, N). */ +/* > On exit L M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDL */ +/* > \verbatim */ +/* > LDL is INTEGER */ +/* > The leading dimension of L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > Parameter used in generating PRTYPE = 1 and 5 matrices. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QBLCKA */ +/* > \verbatim */ +/* > QBLCKA is INTEGER */ +/* > When PRTYPE = 3, specifies the distance between 2-by-2 */ +/* > blocks on the diagonal in A. Otherwise, QBLCKA is not */ +/* > referenced. QBLCKA > 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QBLCKB */ +/* > \verbatim */ +/* > QBLCKB is INTEGER */ +/* > When PRTYPE = 3, specifies the distance between 2-by-2 */ +/* > blocks on the diagonal in B. Otherwise, QBLCKB is not */ +/* > referenced. QBLCKB > 1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup real_matgen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */ +/* > */ +/* > A : if (i == j) then A(i, j) = 1.0 */ +/* > if (j == i + 1) then A(i, j) = -1.0 */ +/* > else A(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > B : if (i == j) then B(i, j) = 1.0 - ALPHA */ +/* > if (j == i + 1) then B(i, j) = 1.0 */ +/* > else B(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > D : if (i == j) then D(i, j) = 1.0 */ +/* > else D(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > E : if (i == j) then E(i, j) = 1.0 */ +/* > else E(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > L = R are chosen from [-10...10], */ +/* > which specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */ +/* > */ +/* > A : if (i <= j) then A(i, j) = [-1...1] */ +/* > else A(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > if (PRTYPE = 3) then */ +/* > A(k + 1, k + 1) = A(k, k) */ +/* > A(k + 1, k) = [-1...1] */ +/* > sign(A(k, k + 1) = -(sin(A(k + 1, k)) */ +/* > k = 1, M - 1, QBLCKA */ +/* > */ +/* > B : if (i <= j) then B(i, j) = [-1...1] */ +/* > else B(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > if (PRTYPE = 3) then */ +/* > B(k + 1, k + 1) = B(k, k) */ +/* > B(k + 1, k) = [-1...1] */ +/* > sign(B(k, k + 1) = -(sign(B(k + 1, k)) */ +/* > k = 1, N - 1, QBLCKB */ +/* > */ +/* > D : if (i <= j) then D(i, j) = [-1...1]. */ +/* > else D(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > */ +/* > E : if (i <= j) then D(i, j) = [-1...1] */ +/* > else E(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > L, R are chosen from [-10...10], */ +/* > which specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 4 Full */ +/* > A(i, j) = [-10...10] */ +/* > D(i, j) = [-1...1] i,j = 1...M */ +/* > B(i, j) = [-10...10] */ +/* > E(i, j) = [-1...1] i,j = 1...N */ +/* > R(i, j) = [-10...10] */ +/* > L(i, j) = [-1...1] i = 1..M ,j = 1...N */ +/* > */ +/* > L, R specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 5 special case common and/or close eigs. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slatm5_(integer *prtype, integer *m, integer *n, real *a, + integer *lda, real *b, integer *ldb, real *c__, integer *ldc, real * + d__, integer *ldd, real *e, integer *lde, real *f, integer *ldf, real + *r__, integer *ldr, real *l, integer *ldl, real *alpha, integer * + qblcka, integer *qblckb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset, + r_dim1, r_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + real imeps, reeps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + r_dim1 = *ldr; + r_offset = 1 + r_dim1 * 1; + r__ -= r_offset; + l_dim1 = *ldl; + l_offset = 1 + l_dim1 * 1; + l -= l_offset; + + /* Function Body */ + if (*prtype == 1) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + if (i__ == j) { + a[i__ + j * a_dim1] = 1.f; + d__[i__ + j * d_dim1] = 1.f; + } else if (i__ == j - 1) { + a[i__ + j * a_dim1] = -1.f; + d__[i__ + j * d_dim1] = 0.f; + } else { + a[i__ + j * a_dim1] = 0.f; + d__[i__ + j * d_dim1] = 0.f; + } +/* L10: */ + } +/* L20: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (i__ == j) { + b[i__ + j * b_dim1] = 1.f - *alpha; + e[i__ + j * e_dim1] = 1.f; + } else if (i__ == j - 1) { + b[i__ + j * b_dim1] = 1.f; + e[i__ + j * e_dim1] = 0.f; + } else { + b[i__ + j * b_dim1] = 0.f; + e[i__ + j * e_dim1] = 0.f; + } +/* L30: */ + } +/* L40: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + r__[i__ + j * r_dim1] = (.5f - sin((real) (i__ / j))) * 20.f; + l[i__ + j * l_dim1] = r__[i__ + j * r_dim1]; +/* L50: */ + } +/* L60: */ + } + + } else if (*prtype == 2 || *prtype == 3) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + if (i__ <= j) { + a[i__ + j * a_dim1] = (.5f - sin((real) i__)) * 2.f; + d__[i__ + j * d_dim1] = (.5f - sin((real) (i__ * j))) * + 2.f; + } else { + a[i__ + j * a_dim1] = 0.f; + d__[i__ + j * d_dim1] = 0.f; + } +/* L70: */ + } +/* L80: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (i__ <= j) { + b[i__ + j * b_dim1] = (.5f - sin((real) (i__ + j))) * 2.f; + e[i__ + j * e_dim1] = (.5f - sin((real) j)) * 2.f; + } else { + b[i__ + j * b_dim1] = 0.f; + e[i__ + j * e_dim1] = 0.f; + } +/* L90: */ + } +/* L100: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + r__[i__ + j * r_dim1] = (.5f - sin((real) (i__ * j))) * 20.f; + l[i__ + j * l_dim1] = (.5f - sin((real) (i__ + j))) * 20.f; +/* L110: */ + } +/* L120: */ + } + + if (*prtype == 3) { + if (*qblcka <= 1) { + *qblcka = 2; + } + i__1 = *m - 1; + i__2 = *qblcka; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { + a[k + 1 + (k + 1) * a_dim1] = a[k + k * a_dim1]; + a[k + 1 + k * a_dim1] = -sin(a[k + (k + 1) * a_dim1]); +/* L130: */ + } + + if (*qblckb <= 1) { + *qblckb = 2; + } + i__2 = *n - 1; + i__1 = *qblckb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { + b[k + 1 + (k + 1) * b_dim1] = b[k + k * b_dim1]; + b[k + 1 + k * b_dim1] = -sin(b[k + (k + 1) * b_dim1]); +/* L140: */ + } + } + + } else if (*prtype == 4) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + a[i__ + j * a_dim1] = (.5f - sin((real) (i__ * j))) * 20.f; + d__[i__ + j * d_dim1] = (.5f - sin((real) (i__ + j))) * 2.f; +/* L150: */ + } +/* L160: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + b[i__ + j * b_dim1] = (.5f - sin((real) (i__ + j))) * 20.f; + e[i__ + j * e_dim1] = (.5f - sin((real) (i__ * j))) * 2.f; +/* L170: */ + } +/* L180: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + r__[i__ + j * r_dim1] = (.5f - sin((real) (j / i__))) * 20.f; + l[i__ + j * l_dim1] = (.5f - sin((real) (i__ * j))) * 2.f; +/* L190: */ + } +/* L200: */ + } + + } else if (*prtype >= 5) { + reeps = 20.f / *alpha; + imeps = -1.5f / *alpha; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + r__[i__ + j * r_dim1] = (.5f - sin((real) (i__ * j))) * * + alpha / 20.f; + l[i__ + j * l_dim1] = (.5f - sin((real) (i__ + j))) * *alpha / + 20.f; +/* L210: */ + } +/* L220: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__ + i__ * d_dim1] = 1.f; +/* L230: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ <= 4) { + a[i__ + i__ * a_dim1] = 1.f; + if (i__ > 2) { + a[i__ + i__ * a_dim1] = reeps + 1.f; + } + if (i__ % 2 != 0 && i__ < *m) { + a[i__ + (i__ + 1) * a_dim1] = imeps; + } else if (i__ > 1) { + a[i__ + (i__ - 1) * a_dim1] = -imeps; + } + } else if (i__ <= 8) { + if (i__ <= 6) { + a[i__ + i__ * a_dim1] = reeps; + } else { + a[i__ + i__ * a_dim1] = -reeps; + } + if (i__ % 2 != 0 && i__ < *m) { + a[i__ + (i__ + 1) * a_dim1] = 1.f; + } else if (i__ > 1) { + a[i__ + (i__ - 1) * a_dim1] = -1.f; + } + } else { + a[i__ + i__ * a_dim1] = 1.f; + if (i__ % 2 != 0 && i__ < *m) { + a[i__ + (i__ + 1) * a_dim1] = imeps * 2; + } else if (i__ > 1) { + a[i__ + (i__ - 1) * a_dim1] = -imeps * 2; + } + } +/* L240: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__ + i__ * e_dim1] = 1.f; + if (i__ <= 4) { + b[i__ + i__ * b_dim1] = -1.f; + if (i__ > 2) { + b[i__ + i__ * b_dim1] = 1.f - reeps; + } + if (i__ % 2 != 0 && i__ < *n) { + b[i__ + (i__ + 1) * b_dim1] = imeps; + } else if (i__ > 1) { + b[i__ + (i__ - 1) * b_dim1] = -imeps; + } + } else if (i__ <= 8) { + if (i__ <= 6) { + b[i__ + i__ * b_dim1] = reeps; + } else { + b[i__ + i__ * b_dim1] = -reeps; + } + if (i__ % 2 != 0 && i__ < *n) { + b[i__ + (i__ + 1) * b_dim1] = imeps + 1.f; + } else if (i__ > 1) { + b[i__ + (i__ - 1) * b_dim1] = -1.f - imeps; + } + } else { + b[i__ + i__ * b_dim1] = 1.f - reeps; + if (i__ % 2 != 0 && i__ < *n) { + b[i__ + (i__ + 1) * b_dim1] = imeps * 2; + } else if (i__ > 1) { + b[i__ + (i__ - 1) * b_dim1] = -imeps * 2; + } + } +/* L250: */ + } + } + +/* Compute rhs (C, F) */ + + sgemm_("N", "N", m, n, m, &c_b29, &a[a_offset], lda, &r__[r_offset], ldr, + &c_b30, &c__[c_offset], ldc); + sgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &b[b_offset], ldb, & + c_b29, &c__[c_offset], ldc); + sgemm_("N", "N", m, n, m, &c_b29, &d__[d_offset], ldd, &r__[r_offset], + ldr, &c_b30, &f[f_offset], ldf); + sgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &e[e_offset], lde, & + c_b29, &f[f_offset], ldf); + +/* End of SLATM5 */ + + return 0; +} /* slatm5_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slatm6.c b/lapack-netlib/TESTING/MATGEN/slatm6.c new file mode 100644 index 000000000..58c701187 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slatm6.c @@ -0,0 +1,748 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATM6 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, */ +/* BETA, WX, WY, S, DIF ) */ + +/* INTEGER LDA, LDX, LDY, N, TYPE */ +/* REAL ALPHA, BETA, WX, WY */ +/* REAL A( LDA, * ), B( LDA, * ), DIF( * ), S( * ), */ +/* $ X( LDX, * ), Y( LDY, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATM6 generates test matrices for the generalized eigenvalue */ +/* > problem, their corresponding right and left eigenvector matrices, */ +/* > and also reciprocal condition numbers for all eigenvalues and */ +/* > the reciprocal condition numbers of eigenvectors corresponding to */ +/* > the 1th and 5th eigenvalues. */ +/* > */ +/* > Test Matrices */ +/* > ============= */ +/* > */ +/* > Two kinds of test matrix pairs */ +/* > */ +/* > (A, B) = inverse(YH) * (Da, Db) * inverse(X) */ +/* > */ +/* > are used in the tests: */ +/* > */ +/* > Type 1: */ +/* > Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */ +/* > 0 2+a 0 0 0 0 1 0 0 0 */ +/* > 0 0 3+a 0 0 0 0 1 0 0 */ +/* > 0 0 0 4+a 0 0 0 0 1 0 */ +/* > 0 0 0 0 5+a , 0 0 0 0 1 , and */ +/* > */ +/* > Type 2: */ +/* > Da = 1 -1 0 0 0 Db = 1 0 0 0 0 */ +/* > 1 1 0 0 0 0 1 0 0 0 */ +/* > 0 0 1 0 0 0 0 1 0 0 */ +/* > 0 0 0 1+a 1+b 0 0 0 1 0 */ +/* > 0 0 0 -1-b 1+a , 0 0 0 0 1 . */ +/* > */ +/* > In both cases the same inverse(YH) and inverse(X) are used to compute */ +/* > (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */ +/* > */ +/* > YH: = 1 0 -y y -y X = 1 0 -x -x x */ +/* > 0 1 -y y -y 0 1 x -x -x */ +/* > 0 0 1 0 0 0 0 1 0 0 */ +/* > 0 0 0 1 0 0 0 0 1 0 */ +/* > 0 0 0 0 1, 0 0 0 0 1 , */ +/* > */ +/* > where a, b, x and y will have all values independently of each other. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TYPE */ +/* > \verbatim */ +/* > TYPE is INTEGER */ +/* > Specifies the problem type (see further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Size of the matrices A and B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA, N). */ +/* > On exit A N-by-N is initialized according to TYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A and of B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDA, N). */ +/* > On exit B N-by-N is initialized according to TYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX, N). */ +/* > On exit X is the N-by-N matrix of right eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of X. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Y */ +/* > \verbatim */ +/* > Y is REAL array, dimension (LDY, N). */ +/* > On exit Y is the N-by-N matrix of left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is REAL */ +/* > */ +/* > Weighting constants for matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WX */ +/* > \verbatim */ +/* > WX is REAL */ +/* > Constant for right eigenvector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WY */ +/* > \verbatim */ +/* > WY is REAL */ +/* > Constant for left eigenvector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > S(i) is the reciprocal condition number for eigenvalue i. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is REAL array, dimension (N) */ +/* > DIF(i) is the reciprocal condition number for eigenvector i. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slatm6_(integer *type__, integer *n, real *a, integer * + lda, real *b, real *x, integer *ldx, real *y, integer *ldy, real * + alpha, real *beta, real *wx, real *wy, real *s, real *dif) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1, + y_offset, i__1, i__2; + + /* Local variables */ + integer info; + real work[100]; + integer i__, j; + real z__[144] /* was [12][12] */; + extern /* Subroutine */ int slakf2_(integer *, integer *, real *, integer + *, real *, real *, real *, real *, integer *), sgesvd_(char *, + char *, integer *, integer *, real *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Generate test problem ... */ +/* (Da, Db) ... */ + + /* Parameter adjustments */ + b_dim1 = *lda; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --s; + --dif; + + /* Function Body */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + + if (i__ == j) { + a[i__ + i__ * a_dim1] = (real) i__ + *alpha; + b[i__ + i__ * b_dim1] = 1.f; + } else { + a[i__ + j * a_dim1] = 0.f; + b[i__ + j * b_dim1] = 0.f; + } + +/* L10: */ + } +/* L20: */ + } + +/* Form X and Y */ + + slacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy); + y[y_dim1 + 3] = -(*wy); + y[y_dim1 + 4] = *wy; + y[y_dim1 + 5] = -(*wy); + y[(y_dim1 << 1) + 3] = -(*wy); + y[(y_dim1 << 1) + 4] = *wy; + y[(y_dim1 << 1) + 5] = -(*wy); + + slacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx); + x[x_dim1 * 3 + 1] = -(*wx); + x[(x_dim1 << 2) + 1] = -(*wx); + x[x_dim1 * 5 + 1] = *wx; + x[x_dim1 * 3 + 2] = *wx; + x[(x_dim1 << 2) + 2] = -(*wx); + x[x_dim1 * 5 + 2] = -(*wx); + +/* Form (A, B) */ + + b[b_dim1 * 3 + 1] = *wx + *wy; + b[b_dim1 * 3 + 2] = -(*wx) + *wy; + b[(b_dim1 << 2) + 1] = *wx - *wy; + b[(b_dim1 << 2) + 2] = *wx - *wy; + b[b_dim1 * 5 + 1] = -(*wx) + *wy; + b[b_dim1 * 5 + 2] = *wx + *wy; + if (*type__ == 1) { + a[a_dim1 * 3 + 1] = *wx * a[a_dim1 + 1] + *wy * a[a_dim1 * 3 + 3]; + a[a_dim1 * 3 + 2] = -(*wx) * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * + 3 + 3]; + a[(a_dim1 << 2) + 1] = *wx * a[a_dim1 + 1] - *wy * a[(a_dim1 << 2) + + 4]; + a[(a_dim1 << 2) + 2] = *wx * a[(a_dim1 << 1) + 2] - *wy * a[(a_dim1 << + 2) + 4]; + a[a_dim1 * 5 + 1] = -(*wx) * a[a_dim1 + 1] + *wy * a[a_dim1 * 5 + 5]; + a[a_dim1 * 5 + 2] = *wx * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * 5 + + 5]; + } else if (*type__ == 2) { + a[a_dim1 * 3 + 1] = *wx * 2.f + *wy; + a[a_dim1 * 3 + 2] = *wy; + a[(a_dim1 << 2) + 1] = -(*wy) * (*alpha + 2.f + *beta); + a[(a_dim1 << 2) + 2] = *wx * 2.f - *wy * (*alpha + 2.f + *beta); + a[a_dim1 * 5 + 1] = *wx * -2.f + *wy * (*alpha - *beta); + a[a_dim1 * 5 + 2] = *wy * (*alpha - *beta); + a[a_dim1 + 1] = 1.f; + a[(a_dim1 << 1) + 1] = -1.f; + a[a_dim1 + 2] = 1.f; + a[(a_dim1 << 1) + 2] = a[a_dim1 + 1]; + a[a_dim1 * 3 + 3] = 1.f; + a[(a_dim1 << 2) + 4] = *alpha + 1.f; + a[a_dim1 * 5 + 4] = *beta + 1.f; + a[(a_dim1 << 2) + 5] = -a[a_dim1 * 5 + 4]; + a[a_dim1 * 5 + 5] = a[(a_dim1 << 2) + 4]; + } + +/* Compute condition numbers */ + + if (*type__ == 1) { + + s[1] = 1.f / sqrt((*wy * 3.f * *wy + 1.f) / (a[a_dim1 + 1] * a[a_dim1 + + 1] + 1.f)); + s[2] = 1.f / sqrt((*wy * 3.f * *wy + 1.f) / (a[(a_dim1 << 1) + 2] * a[ + (a_dim1 << 1) + 2] + 1.f)); + s[3] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a[a_dim1 * 3 + 3] * a[ + a_dim1 * 3 + 3] + 1.f)); + s[4] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a[(a_dim1 << 2) + 4] * a[ + (a_dim1 << 2) + 4] + 1.f)); + s[5] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a[a_dim1 * 5 + 5] * a[ + a_dim1 * 5 + 5] + 1.f)); + + slakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[ + b_offset], &b[(b_dim1 << 1) + 2], z__, &c__12); + sgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, & + work[9], &c__1, &work[10], &c__40, &info); + dif[1] = work[7]; + + slakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[ + b_offset], &b[b_dim1 * 5 + 5], z__, &c__12); + sgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, & + work[9], &c__1, &work[10], &c__40, &info); + dif[5] = work[7]; + + } else if (*type__ == 2) { + + s[1] = 1.f / sqrt(*wy * *wy + .33333333333333331f); + s[2] = s[1]; + s[3] = 1.f / sqrt(*wx * *wx + .5f); + s[4] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / ((*alpha + 1.f) * (*alpha + + 1.f) + 1.f + (*beta + 1.f) * (*beta + 1.f))); + s[5] = s[4]; + + slakf2_(&c__2, &c__3, &a[a_offset], lda, &a[a_dim1 * 3 + 3], &b[ + b_offset], &b[b_dim1 * 3 + 3], z__, &c__12); + sgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1, + &work[13], &c__1, &work[14], &c__60, &info); + dif[1] = work[11]; + + slakf2_(&c__3, &c__2, &a[a_offset], lda, &a[(a_dim1 << 2) + 4], &b[ + b_offset], &b[(b_dim1 << 2) + 4], z__, &c__12); + sgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1, + &work[13], &c__1, &work[14], &c__60, &info); + dif[5] = work[11]; + + } + + return 0; + +/* End of SLATM6 */ + +} /* slatm6_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slatm7.c b/lapack-netlib/TESTING/MATGEN/slatm7.c new file mode 100644 index 000000000..784bd6d62 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slatm7.c @@ -0,0 +1,701 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATM7 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N, */ +/* RANK, INFO ) */ + +/* REAL COND */ +/* INTEGER IDIST, INFO, IRSIGN, MODE, N, RANK */ +/* REAL D( * ) */ +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATM7 computes the entries of D as specified by MODE */ +/* > COND and IRSIGN. IDIST and ISEED determine the generation */ +/* > of random numbers. SLATM7 is called by SLATMT to generate */ +/* > random test matrices. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > MODE - INTEGER */ +/* > On entry describes how D is to be computed: */ +/* > MODE = 0 means do not change D. */ +/* > */ +/* > MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */ +/* > MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK */ +/* > */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > Not modified. */ +/* > */ +/* > COND - REAL */ +/* > On entry, used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > */ +/* > IRSIGN - INTEGER */ +/* > On entry, if MODE neither -6, 0 nor 6, determines sign of */ +/* > entries of D */ +/* > 0 => leave entries of D unchanged */ +/* > 1 => multiply each entry of D by 1 or -1 with probability .5 */ +/* > */ +/* > IDIST - CHARACTER*1 */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => UNIFORM( 0, 1 ) */ +/* > 2 => UNIFORM( -1, 1 ) */ +/* > 3 => NORMAL( 0, 1 ) */ +/* > Not modified. */ +/* > */ +/* > ISEED - INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. The random number generator uses a */ +/* > linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to SLATM7 */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > */ +/* > D - REAL array, dimension ( MIN( M , N ) ) */ +/* > Array to be computed according to MODE, COND and IRSIGN. */ +/* > May be changed on exit if MODE is nonzero. */ +/* > */ +/* > N - INTEGER */ +/* > Number of entries of D. Not modified. */ +/* > */ +/* > RANK - INTEGER */ +/* > The rank of matrix to be generated for modes 1,2,3 only. */ +/* > D( RANK+1:N ) = 0. */ +/* > Not modified. */ +/* > */ +/* > INFO - INTEGER */ +/* > 0 => normal termination */ +/* > -1 => if MODE not in range -6 to 6 */ +/* > -2 => if MODE neither -6, 0 nor 6, and */ +/* > IRSIGN neither 0 nor 1 */ +/* > -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */ +/* > -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */ +/* > -7 => if N negative */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slatm7_(integer *mode, real *cond, integer *irsign, + integer *idist, integer *iseed, real *d__, integer *n, integer *rank, + integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + real temp; + integer i__; + real alpha; + extern /* Subroutine */ int xerbla_(char *, integer *); + extern real slaran_(integer *); + extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real + *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and Test the input parameters. Initialize flags & seed. */ + + /* Parameter adjustments */ + --d__; + --iseed; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Set INFO if an error */ + + if (*mode < -6 || *mode > 6) { + *info = -1; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && * + irsign != 1)) { + *info = -2; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) { + *info = -3; + } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) { + *info = -4; + } else if (*n < 0) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLATM7", &i__1); + return 0; + } + +/* Compute D according to COND and MODE */ + + if (*mode != 0) { + switch (abs(*mode)) { + case 1: goto L100; + case 2: goto L130; + case 3: goto L160; + case 4: goto L190; + case 5: goto L210; + case 6: goto L230; + } + +/* One large D value: */ + +L100: + i__1 = *rank; + for (i__ = 2; i__ <= i__1; ++i__) { + d__[i__] = 1.f / *cond; +/* L110: */ + } + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + d__[i__] = 0.f; +/* L120: */ + } + d__[1] = 1.f; + goto L240; + +/* One small D value: */ + +L130: + i__1 = *rank - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = 1.f; +/* L140: */ + } + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + d__[i__] = 0.f; +/* L150: */ + } + d__[*rank] = 1.f / *cond; + goto L240; + +/* Exponentially distributed D values: */ + +L160: + d__[1] = 1.f; + if (*n > 1 && *rank > 1) { + d__1 = (doublereal) (*cond); + d__2 = (doublereal) (-1.f / (real) (*rank - 1)); + alpha = pow_dd(&d__1, &d__2); + i__1 = *rank; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__ - 1; + d__[i__] = pow_ri(&alpha, &i__2); +/* L170: */ + } + i__1 = *n; + for (i__ = *rank + 1; i__ <= i__1; ++i__) { + d__[i__] = 0.f; +/* L180: */ + } + } + goto L240; + +/* Arithmetically distributed D values: */ + +L190: + d__[1] = 1.f; + if (*n > 1) { + temp = 1.f / *cond; + alpha = (1.f - temp) / (real) (*n - 1); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + d__[i__] = (real) (*n - i__) * alpha + temp; +/* L200: */ + } + } + goto L240; + +/* Randomly distributed D values on ( 1/COND , 1): */ + +L210: + alpha = log(1.f / *cond); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = exp(alpha * slaran_(&iseed[1])); +/* L220: */ + } + goto L240; + +/* Randomly distributed D values from IDIST */ + +L230: + slarnv_(idist, &iseed[1], n, &d__[1]); + +L240: + +/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */ +/* random signs to D */ + + if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = slaran_(&iseed[1]); + if (temp > .5f) { + d__[i__] = -d__[i__]; + } +/* L250: */ + } + } + +/* Reverse if MODE < 0 */ + + if (*mode < 0) { + i__1 = *n / 2; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = d__[i__]; + d__[i__] = d__[*n + 1 - i__]; + d__[*n + 1 - i__] = temp; +/* L260: */ + } + } + + } + + return 0; + +/* End of SLATM7 */ + +} /* slatm7_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slatme.c b/lapack-netlib/TESTING/MATGEN/slatme.c new file mode 100644 index 000000000..2d72d31e7 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slatme.c @@ -0,0 +1,1152 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATME */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, */ +/* RSIGN, */ +/* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, */ +/* A, */ +/* LDA, WORK, INFO ) */ + +/* CHARACTER DIST, RSIGN, SIM, UPPER */ +/* INTEGER INFO, KL, KU, LDA, MODE, MODES, N */ +/* REAL ANORM, COND, CONDS, DMAX */ +/* CHARACTER EI( * ) */ +/* INTEGER ISEED( 4 ) */ +/* REAL A( LDA, * ), D( * ), DS( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATME generates random non-symmetric square matrices with */ +/* > specified eigenvalues for testing LAPACK programs. */ +/* > */ +/* > SLATME operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > 1. Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and RSIGN */ +/* > as described below. */ +/* > */ +/* > 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', */ +/* > or MODE=5), certain pairs of adjacent elements of D are */ +/* > interpreted as the real and complex parts of a complex */ +/* > conjugate pair; A thus becomes block diagonal, with 1x1 */ +/* > and 2x2 blocks. */ +/* > */ +/* > 3. If UPPER='T', the upper triangle of A is set to random values */ +/* > out of distribution DIST. */ +/* > */ +/* > 4. If SIM='T', A is multiplied on the left by a random matrix */ +/* > X, whose singular values are specified by DS, MODES, and */ +/* > CONDS, and on the right by X inverse. */ +/* > */ +/* > 5. If KL < N-1, the lower bandwidth is reduced to KL using */ +/* > Householder transformations. If KU < N-1, the upper */ +/* > bandwidth is reduced to KU. */ +/* > */ +/* > 6. If ANORM is not negative, the matrix is scaled to have */ +/* > maximum-element-norm ANORM. */ +/* > */ +/* > (Note: since the matrix cannot be reduced beyond Hessenberg form, */ +/* > no packing options are available.) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns (or rows) of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values, and for the */ +/* > upper triangle (see UPPER). */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to SLATME */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension ( N ) */ +/* > This array is used to specify the eigenvalues of A. If */ +/* > MODE=0, then D is assumed to contain the eigenvalues (but */ +/* > see the description of EI), otherwise they will be */ +/* > computed according to MODE, COND, DMAX, and RSIGN and */ +/* > placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D (with EI) as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. Each odd-even pair */ +/* > of elements will be either used as two real */ +/* > eigenvalues or as the real and imaginary part */ +/* > of a complex conjugate pair of eigenvalues; */ +/* > the choice of which is done is random, with */ +/* > 50-50 probability, for each pair. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is between 1 and 4, D has entries ranging */ +/* > from 1 to 1/COND, if between -1 and -4, D has entries */ +/* > ranging from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is REAL */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is REAL */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))). Note that DMAX need not be */ +/* > positive: if DMAX is negative (or zero), D will be */ +/* > scaled by a negative number (or zero). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EI */ +/* > \verbatim */ +/* > EI is CHARACTER*1 array, dimension ( N ) */ +/* > If MODE is 0, and EI(1) is not ' ' (space character), */ +/* > this array specifies which elements of D (on input) are */ +/* > real eigenvalues and which are the real and imaginary parts */ +/* > of a complex conjugate pair of eigenvalues. The elements */ +/* > of EI may then only have the values 'R' and 'I'. If */ +/* > EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is */ +/* > CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex */ +/* > conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th */ +/* > eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', */ +/* > nor may two adjacent elements of EI both have the value 'I'. */ +/* > If MODE is not 0, then EI is ignored. If MODE is 0 and */ +/* > EI(1)=' ', then the eigenvalues will all be real. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RSIGN */ +/* > \verbatim */ +/* > RSIGN is CHARACTER*1 */ +/* > If MODE is not 0, 6, or -6, and RSIGN='T', then the */ +/* > elements of D, as computed according to MODE and COND, will */ +/* > be multiplied by a random sign (+1 or -1). If RSIGN='F', */ +/* > they will not be. RSIGN may only have the values 'T' or */ +/* > 'F'. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPPER */ +/* > \verbatim */ +/* > UPPER is CHARACTER*1 */ +/* > If UPPER='T', then the elements of A above the diagonal */ +/* > (and above the 2x2 diagonal blocks, if A has complex */ +/* > eigenvalues) will be set to random numbers out of DIST. */ +/* > If UPPER='F', they will not. UPPER may only have the */ +/* > values 'T' or 'F'. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIM */ +/* > \verbatim */ +/* > SIM is CHARACTER*1 */ +/* > If SIM='T', then A will be operated on by a "similarity */ +/* > transform", i.e., multiplied on the left by a matrix X and */ +/* > on the right by X inverse. X = U S V, where U and V are */ +/* > random unitary matrices and S is a (diagonal) matrix of */ +/* > singular values specified by DS, MODES, and CONDS. If */ +/* > SIM='F', then A will not be transformed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DS */ +/* > \verbatim */ +/* > DS is REAL array, dimension ( N ) */ +/* > This array is used to specify the singular values of X, */ +/* > in the same way that D specifies the eigenvalues of A. */ +/* > If MODE=0, the DS contains the singular values, which */ +/* > may not be zero. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODES */ +/* > \verbatim */ +/* > MODES is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDS */ +/* > \verbatim */ +/* > CONDS is REAL */ +/* > Same as MODE and COND, but for specifying the diagonal */ +/* > of S. MODES=-6 and +6 are not allowed (since they would */ +/* > result in randomly ill-conditioned eigenvalues.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. KL=1 */ +/* > specifies upper Hessenberg form. If KL is at least N-1, */ +/* > then A will have full lower bandwidth. KL must be at */ +/* > least 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. KU=1 */ +/* > specifies lower Hessenberg form. If KU is at least N-1, */ +/* > then A will have full upper bandwidth; if KU and KL */ +/* > are both at least N-1, then A will be dense. Only one of */ +/* > KU and KL may be less than N-1. KU must be at least 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > If ANORM is not negative, then A will be scaled by a non- */ +/* > negative real number to make the maximum-element-norm of A */ +/* > to be ANORM. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. LDA must be at least N. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension ( 3*N ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => N negative */ +/* > -2 => DIST illegal string */ +/* > -5 => MODE not in range -6 to 6 */ +/* > -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or */ +/* > two adjacent elements of EI are 'I'. */ +/* > -9 => RSIGN is not 'T' or 'F' */ +/* > -10 => UPPER is not 'T' or 'F' */ +/* > -11 => SIM is not 'T' or 'F' */ +/* > -12 => MODES=0 and DS has a zero singular value. */ +/* > -13 => MODES is not in the range -5 to 5. */ +/* > -14 => MODES is nonzero and CONDS is less than 1. */ +/* > -15 => KL is less than 1. */ +/* > -16 => KU is less than 1, or KL and KU are both less than */ +/* > N-1. */ +/* > -19 => LDA is less than N. */ +/* > 1 => Error return from SLATM1 (computing D) */ +/* > 2 => Cannot scale to DMAX (f2cmax. eigenvalue is 0) */ +/* > 3 => Error return from SLATM1 (computing DS) */ +/* > 4 => Error return from SLARGE */ +/* > 5 => Zero singular value from SLATM1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slatme_(integer *n, char *dist, integer *iseed, real * + d__, integer *mode, real *cond, real *dmax__, char *ei, char *rsign, + char *upper, char *sim, real *ds, integer *modes, real *conds, + integer *kl, integer *ku, real *anorm, real *a, integer *lda, real * + work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real r__1, r__2, r__3; + + /* Local variables */ + logical bads; + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + integer isim; + real temp; + logical badei; + integer i__, j; + real alpha; + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real tempa[1]; + integer icols; + logical useei; + integer idist; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *); + integer irows; + extern /* Subroutine */ int slatm1_(integer *, real *, integer *, integer + *, integer *, real *, integer *, integer *); + integer ic, jc, ir, jr; + extern real slange_(char *, integer *, integer *, real *, integer *, real + *); + extern /* Subroutine */ int slarge_(integer *, real *, integer *, integer + *, real *, integer *), slarfg_(integer *, real *, real *, integer + *, real *), xerbla_(char *, integer *); + extern real slaran_(integer *); + integer irsign; + extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, + real *, real *, integer *); + integer iupper; + extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real + *); + real xnorms; + integer jcr; + real tau; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + --ei; + --ds; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Check EI */ + + useei = TRUE_; + badei = FALSE_; + if (lsame_(ei + 1, " ") || *mode != 0) { + useei = FALSE_; + } else { + if (lsame_(ei + 1, "R")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + if (lsame_(ei + j, "I")) { + if (lsame_(ei + (j - 1), "I")) { + badei = TRUE_; + } + } else { + if (! lsame_(ei + j, "R")) { + badei = TRUE_; + } + } +/* L10: */ + } + } else { + badei = TRUE_; + } + } + +/* Decode RSIGN */ + + if (lsame_(rsign, "T")) { + irsign = 1; + } else if (lsame_(rsign, "F")) { + irsign = 0; + } else { + irsign = -1; + } + +/* Decode UPPER */ + + if (lsame_(upper, "T")) { + iupper = 1; + } else if (lsame_(upper, "F")) { + iupper = 0; + } else { + iupper = -1; + } + +/* Decode SIM */ + + if (lsame_(sim, "T")) { + isim = 1; + } else if (lsame_(sim, "F")) { + isim = 0; + } else { + isim = -1; + } + +/* Check DS, if MODES=0 and ISIM=1 */ + + bads = FALSE_; + if (*modes == 0 && isim == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (ds[j] == 0.f) { + bads = TRUE_; + } +/* L20: */ + } + } + +/* Set INFO if an error */ + + if (*n < 0) { + *info = -1; + } else if (idist == -1) { + *info = -2; + } else if (abs(*mode) > 6) { + *info = -5; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) { + *info = -6; + } else if (badei) { + *info = -8; + } else if (irsign == -1) { + *info = -9; + } else if (iupper == -1) { + *info = -10; + } else if (isim == -1) { + *info = -11; + } else if (bads) { + *info = -12; + } else if (isim == 1 && abs(*modes) > 5) { + *info = -13; + } else if (isim == 1 && *modes != 0 && *conds < 1.f) { + *info = -14; + } else if (*kl < 1) { + *info = -15; + } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) { + *info = -16; + } else if (*lda < f2cmax(1,*n)) { + *info = -19; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLATME", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L30: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up diagonal of A */ + +/* Compute D according to COND and MODE */ + + slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = temp, r__3 = (r__1 = d__[i__], abs(r__1)); + temp = f2cmax(r__2,r__3); +/* L40: */ + } + + if (temp > 0.f) { + alpha = *dmax__ / temp; + } else if (*dmax__ != 0.f) { + *info = 2; + return 0; + } else { + alpha = 0.f; + } + + sscal_(n, &alpha, &d__[1], &c__1); + + } + + slaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda); + i__1 = *lda + 1; + scopy_(n, &d__[1], &c__1, &a[a_offset], &i__1); + +/* Set up complex conjugate pairs */ + + if (*mode == 0) { + if (useei) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + if (lsame_(ei + j, "I")) { + a[j - 1 + j * a_dim1] = a[j + j * a_dim1]; + a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1]; + a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1]; + } +/* L50: */ + } + } + + } else if (abs(*mode) == 5) { + + i__1 = *n; + for (j = 2; j <= i__1; j += 2) { + if (slaran_(&iseed[1]) > .5f) { + a[j - 1 + j * a_dim1] = a[j + j * a_dim1]; + a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1]; + a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1]; + } +/* L60: */ + } + } + +/* 3) If UPPER='T', set upper triangle of A to random numbers. */ +/* (but don't modify the corners of 2x2 blocks.) */ + + if (iupper != 0) { + i__1 = *n; + for (jc = 2; jc <= i__1; ++jc) { + if (a[jc - 1 + jc * a_dim1] != 0.f) { + jr = jc - 2; + } else { + jr = jc - 1; + } + slarnv_(&idist, &iseed[1], &jr, &a[jc * a_dim1 + 1]); +/* L70: */ + } + } + +/* 4) If SIM='T', apply similarity transformation. */ + +/* -1 */ +/* Transform is X A X , where X = U S V, thus */ + +/* it is U S V A V' (1/S) U' */ + + if (isim != 0) { + +/* Compute S (singular values of the eigenvector matrix) */ +/* according to CONDS and MODES */ + + slatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo); + if (iinfo != 0) { + *info = 3; + return 0; + } + +/* Multiply by V and V' */ + + slarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo); + if (iinfo != 0) { + *info = 4; + return 0; + } + +/* Multiply by S and (1/S) */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sscal_(n, &ds[j], &a[j + a_dim1], lda); + if (ds[j] != 0.f) { + r__1 = 1.f / ds[j]; + sscal_(n, &r__1, &a[j * a_dim1 + 1], &c__1); + } else { + *info = 5; + return 0; + } +/* L80: */ + } + +/* Multiply by U and U' */ + + slarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo); + if (iinfo != 0) { + *info = 4; + return 0; + } + } + +/* 5) Reduce the bandwidth. */ + + if (*kl < *n - 1) { + +/* Reduce bandwidth -- kill column */ + + i__1 = *n - 1; + for (jcr = *kl + 1; jcr <= i__1; ++jcr) { + ic = jcr - *kl; + irows = *n + 1 - jcr; + icols = *n + *kl - jcr; + + scopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1); + xnorms = work[1]; + slarfg_(&irows, &xnorms, &work[2], &c__1, &tau); + work[1] = 1.f; + + sgemv_("T", &irows, &icols, &c_b39, &a[jcr + (ic + 1) * a_dim1], + lda, &work[1], &c__1, &c_b23, &work[irows + 1], &c__1); + r__1 = -tau; + sger_(&irows, &icols, &r__1, &work[1], &c__1, &work[irows + 1], & + c__1, &a[jcr + (ic + 1) * a_dim1], lda); + + sgemv_("N", n, &irows, &c_b39, &a[jcr * a_dim1 + 1], lda, &work[1] + , &c__1, &c_b23, &work[irows + 1], &c__1); + r__1 = -tau; + sger_(n, &irows, &r__1, &work[irows + 1], &c__1, &work[1], &c__1, + &a[jcr * a_dim1 + 1], lda); + + a[jcr + ic * a_dim1] = xnorms; + i__2 = irows - 1; + slaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a[jcr + 1 + ic * + a_dim1], lda); +/* L90: */ + } + } else if (*ku < *n - 1) { + +/* Reduce upper bandwidth -- kill a row at a time. */ + + i__1 = *n - 1; + for (jcr = *ku + 1; jcr <= i__1; ++jcr) { + ir = jcr - *ku; + irows = *n + *ku - jcr; + icols = *n + 1 - jcr; + + scopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1); + xnorms = work[1]; + slarfg_(&icols, &xnorms, &work[2], &c__1, &tau); + work[1] = 1.f; + + sgemv_("N", &irows, &icols, &c_b39, &a[ir + 1 + jcr * a_dim1], + lda, &work[1], &c__1, &c_b23, &work[icols + 1], &c__1); + r__1 = -tau; + sger_(&irows, &icols, &r__1, &work[icols + 1], &c__1, &work[1], & + c__1, &a[ir + 1 + jcr * a_dim1], lda); + + sgemv_("C", &icols, n, &c_b39, &a[jcr + a_dim1], lda, &work[1], & + c__1, &c_b23, &work[icols + 1], &c__1); + r__1 = -tau; + sger_(&icols, n, &r__1, &work[1], &c__1, &work[icols + 1], &c__1, + &a[jcr + a_dim1], lda); + + a[ir + jcr * a_dim1] = xnorms; + i__2 = icols - 1; + slaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a[ir + (jcr + 1) * + a_dim1], lda); +/* L100: */ + } + } + +/* Scale the matrix to have norm ANORM */ + + if (*anorm >= 0.f) { + temp = slange_("M", n, n, &a[a_offset], lda, tempa); + if (temp > 0.f) { + alpha = *anorm / temp; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sscal_(n, &alpha, &a[j * a_dim1 + 1], &c__1); +/* L110: */ + } + } + } + + return 0; + +/* End of SLATME */ + +} /* slatme_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slatmr.c b/lapack-netlib/TESTING/MATGEN/slatmr.c new file mode 100644 index 000000000..77438da78 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slatmr.c @@ -0,0 +1,1768 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATMR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, */ +/* CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, */ +/* PACK, A, LDA, IWORK, INFO ) */ + +/* CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N */ +/* REAL ANORM, COND, CONDL, CONDR, DMAX, SPARSE */ +/* INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) */ +/* REAL A( LDA, * ), D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATMR generates random matrices of various types for testing */ +/* > LAPACK programs. */ +/* > */ +/* > SLATMR operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Generate a matrix A with random entries of distribution DIST */ +/* > which is symmetric if SYM='S', and nonsymmetric */ +/* > if SYM='N'. */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX and RSIGN */ +/* > as described below. */ +/* > */ +/* > Grade the matrix, if desired, from the left and/or right */ +/* > as specified by GRADE. The inputs DL, MODEL, CONDL, DR, */ +/* > MODER and CONDR also determine the grading as described */ +/* > below. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > PIVTNG and IPIVOT. */ +/* > */ +/* > Set random entries to zero, if desired, to get a random sparse */ +/* > matrix as specified by SPARSE. */ +/* > */ +/* > Make A a band matrix, if desired, by zeroing out the matrix */ +/* > outside a band of lower bandwidth KL and upper bandwidth KU. */ +/* > */ +/* > Scale A, if desired, to have maximum entry ANORM. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if symmetric) */ +/* > zero out lower half (if symmetric) */ +/* > store the upper half columnwise (if symmetric or */ +/* > square upper triangular) */ +/* > store the lower half columnwise (if symmetric or */ +/* > square lower triangular) */ +/* > same as upper half rowwise if symmetric */ +/* > store the lower triangle in banded format (if symmetric) */ +/* > store the upper triangle in banded format (if symmetric) */ +/* > store the entire matrix in banded format */ +/* > */ +/* > Note: If two calls to SLATMR differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > */ +/* > If two calls to SLATMR both have full bandwidth (KL = M-1 */ +/* > and KU = N-1), and differ only in the PIVTNG and PACK */ +/* > parameters, then the matrices generated will differ only */ +/* > in the order of the rows and/or columns, and otherwise */ +/* > contain the same data. This consistency cannot be and */ +/* > is not maintained with less than full bandwidth. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate a random matrix . */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to SLATMR */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='S' or 'H', generated matrix is symmetric. */ +/* > If SYM='N', generated matrix is nonsymmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (f2cmin(M,N)) */ +/* > On entry this array specifies the diagonal entries */ +/* > of the diagonal of A. D may either be specified */ +/* > on entry, or set according to MODE and COND as described */ +/* > below. May be changed on exit if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry describes how D is to be used: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is REAL */ +/* > On entry, used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is REAL */ +/* > If MODE neither -6, 0 nor 6, the diagonal is scaled by */ +/* > DMAX / f2cmax(abs(D(i))), so that maximum absolute entry */ +/* > of diagonal is abs(DMAX). If DMAX is negative (or zero), */ +/* > diagonal will be scaled by a negative number (or zero). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RSIGN */ +/* > \verbatim */ +/* > RSIGN is CHARACTER*1 */ +/* > If MODE neither -6, 0 nor 6, specifies sign of diagonal */ +/* > as follows: */ +/* > 'T' => diagonal entries are multiplied by 1 or -1 */ +/* > with probability .5 */ +/* > 'F' => diagonal unchanged */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GRADE */ +/* > \verbatim */ +/* > GRADE is CHARACTER*1 */ +/* > Specifies grading of matrix as follows: */ +/* > 'N' => no grading */ +/* > 'L' => matrix premultiplied by diag( DL ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'R' => matrix postmultiplied by diag( DR ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'B' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'S' or 'H' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > ('S' for symmetric, or 'H' for Hermitian) */ +/* > 'E' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > ( 'E' for eigenvalue invariance) */ +/* > (only if matrix nonsymmetric) */ +/* > Note: if GRADE='E', then M must equal N. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DL */ +/* > \verbatim */ +/* > DL is REAL array, dimension (M) */ +/* > If MODEL=0, then on entry this array specifies the diagonal */ +/* > entries of a diagonal matrix used as described under GRADE */ +/* > above. If MODEL is not zero, then DL will be set according */ +/* > to MODEL and CONDL, analogous to the way D is set according */ +/* > to MODE and COND (except there is no DMAX parameter for DL). */ +/* > If GRADE='E', then DL cannot have zero entries. */ +/* > Not referenced if GRADE = 'N' or 'R'. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODEL */ +/* > \verbatim */ +/* > MODEL is INTEGER */ +/* > This specifies how the diagonal array DL is to be computed, */ +/* > just as MODE specifies how D is to be computed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDL */ +/* > \verbatim */ +/* > CONDL is REAL */ +/* > When MODEL is not zero, this specifies the condition number */ +/* > of the computed DL. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DR */ +/* > \verbatim */ +/* > DR is REAL array, dimension (N) */ +/* > If MODER=0, then on entry this array specifies the diagonal */ +/* > entries of a diagonal matrix used as described under GRADE */ +/* > above. If MODER is not zero, then DR will be set according */ +/* > to MODER and CONDR, analogous to the way D is set according */ +/* > to MODE and COND (except there is no DMAX parameter for DR). */ +/* > Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODER */ +/* > \verbatim */ +/* > MODER is INTEGER */ +/* > This specifies how the diagonal array DR is to be computed, */ +/* > just as MODE specifies how D is to be computed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDR */ +/* > \verbatim */ +/* > CONDR is REAL */ +/* > When MODER is not zero, this specifies the condition number */ +/* > of the computed DR. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVTNG */ +/* > \verbatim */ +/* > PIVTNG is CHARACTER*1 */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 'N' or ' ' => none. */ +/* > 'L' => left or row pivoting (matrix must be nonsymmetric). */ +/* > 'R' => right or column pivoting (matrix must be */ +/* > nonsymmetric). */ +/* > 'B' or 'F' => both or full pivoting, i.e., on both sides. */ +/* > In this case, M must equal N */ +/* > */ +/* > If two calls to SLATMR both have full bandwidth (KL = M-1 */ +/* > and KU = N-1), and differ only in the PIVTNG and PACK */ +/* > parameters, then the matrices generated will differ only */ +/* > in the order of the rows and/or columns, and otherwise */ +/* > contain the same data. This consistency cannot be */ +/* > maintained with less than full bandwidth. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIVOT */ +/* > \verbatim */ +/* > IPIVOT is INTEGER array, dimension (N or M) */ +/* > This array specifies the permutation used. After the */ +/* > basic matrix is generated, the rows, columns, or both */ +/* > are permuted. If, say, row pivoting is selected, SLATMR */ +/* > starts with the *last* row and interchanges the M-th and */ +/* > IPIVOT(M)-th rows, then moves to the next-to-last row, */ +/* > interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, */ +/* > and so on. In terms of "2-cycles", the permutation is */ +/* > (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) */ +/* > where the rightmost cycle is applied first. This is the */ +/* > *inverse* of the effect of pivoting in LINPACK. The idea */ +/* > is that factoring (with pivoting) an identity matrix */ +/* > which has been inverse-pivoted in this way should */ +/* > result in a pivot vector identical to IPIVOT. */ +/* > Not referenced if PIVTNG = 'N'. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > On entry specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL at least M-1 implies the matrix is not */ +/* > banded. Must equal KU if matrix is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > On entry specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU at least N-1 implies the matrix is not */ +/* > banded. Must equal KL if matrix is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is REAL */ +/* > On entry specifies the sparsity of the matrix if a sparse */ +/* > matrix is to be generated. SPARSE should lie between */ +/* > 0 and 1. To generate a sparse matrix, for each matrix entry */ +/* > a uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > On entry specifies maximum entry of output matrix */ +/* > (output matrix will by multiplied by a constant so that */ +/* > its largest absolute entry equal ANORM) */ +/* > if ANORM is nonnegative. If ANORM is negative no scaling */ +/* > is done. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > On entry specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries (if symmetric) */ +/* > 'L' => zero out all superdiagonal entries (if symmetric) */ +/* > 'C' => store the upper triangle columnwise */ +/* > (only if matrix symmetric or square upper triangular) */ +/* > 'R' => store the lower triangle columnwise */ +/* > (only if matrix symmetric or square lower triangular) */ +/* > (same as upper half rowwise if symmetric) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if matrix symmetric) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if matrix symmetric) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, SB or TB - use 'B' or 'Q' */ +/* > PP, SP or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to SLATMR differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On exit A is the desired test matrix. Only those */ +/* > entries of A which are significant on output */ +/* > will be referenced (even if A is in packed or band */ +/* > storage format). The 'unoccupied corners' of A in */ +/* > band format will be zeroed out. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > on entry LDA specifies the first dimension of A as */ +/* > declared in the calling program. */ +/* > If PACK='N', 'U' or 'L', LDA must be at least f2cmax ( 1, M ). */ +/* > If PACK='C' or 'R', LDA must be at least 1. */ +/* > If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) */ +/* > If PACK='Z', LDA must be at least KUU+KLL+1, where */ +/* > KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, M-1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension ( N or M) */ +/* > Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error parameter on exit: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S' or 'H' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string */ +/* > -11 => GRADE illegal string, or GRADE='E' and */ +/* > M not equal to N, or GRADE='L', 'R', 'B' or 'E' and */ +/* > SYM = 'S' or 'H' */ +/* > -12 => GRADE = 'E' and DL contains zero */ +/* > -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', */ +/* > 'S' or 'E' */ +/* > -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', */ +/* > and MODEL neither -6, 0 nor 6 */ +/* > -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' */ +/* > -17 => CONDR less than 1.0, GRADE='R' or 'B', and */ +/* > MODER neither -6, 0 nor 6 */ +/* > -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and */ +/* > M not equal to N, or PIVTNG='L' or 'R' and SYM='S' */ +/* > or 'H' */ +/* > -19 => IPIVOT contains out of range number and */ +/* > PIVTNG not equal to 'N' */ +/* > -20 => KL negative */ +/* > -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL */ +/* > -22 => SPARSE not in range 0. to 1. */ +/* > -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' */ +/* > and SYM='N', or PACK='C' and SYM='N' and either KL */ +/* > not equal to 0 or N not equal to M, or PACK='R' and */ +/* > SYM='N', and either KU not equal to 0 or N not equal */ +/* > to M */ +/* > -26 => LDA too small */ +/* > 1 => Error return from SLATM1 (computing D) */ +/* > 2 => Cannot scale diagonal to DMAX (f2cmax. entry is 0) */ +/* > 3 => Error return from SLATM1 (computing DL) */ +/* > 4 => Error return from SLATM1 (computing DR) */ +/* > 5 => ANORM is positive, but matrix constructed prior to */ +/* > attempting to scale it to have norm ANORM, is zero */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slatmr_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__, + char *rsign, char *grade, real *dl, integer *model, real *condl, real + *dr, integer *moder, real *condr, char *pivtng, integer *ipivot, + integer *kl, integer *ku, real *sparse, real *anorm, char *pack, real + *a, integer *lda, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + real r__1, r__2, r__3; + + /* Local variables */ + integer isub, jsub; + real temp; + integer isym, i__, j, k; + real alpha; + integer ipack; + extern logical lsame_(char *, char *); + real tempa[1]; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer iisub, idist, jjsub, mnmin; + logical dzero; + integer mnsub; + real onorm; + integer mxsub, npvts; + extern /* Subroutine */ int slatm1_(integer *, real *, integer *, integer + *, integer *, real *, integer *, integer *); + extern real slatm2_(integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, real *, integer *, real *, real + *, integer *, integer *, real *), slatm3_(integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, real *, integer *, real *, real *, integer * + , integer *, real *); + integer igrade; + extern real slangb_(char *, integer *, integer *, integer *, real *, + integer *, real *), slange_(char *, integer *, integer *, + real *, integer *, real *); + logical fulbnd; + extern /* Subroutine */ int xerbla_(char *, integer *); + logical badpvt; + extern real slansb_(char *, char *, integer *, integer *, real *, integer + *, real *); + integer irsign; + extern real slansp_(char *, char *, integer *, real *, real *); + integer ipvtng; + extern real slansy_(char *, char *, integer *, real *, integer *, real *); + integer kll, kuu; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + --dl; + --dr; + --ipivot; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iwork; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "S")) { + isym = 0; + } else if (lsame_(sym, "N")) { + isym = 1; + } else if (lsame_(sym, "H")) { + isym = 0; + } else { + isym = -1; + } + +/* Decode RSIGN */ + + if (lsame_(rsign, "F")) { + irsign = 0; + } else if (lsame_(rsign, "T")) { + irsign = 1; + } else { + irsign = -1; + } + +/* Decode PIVTNG */ + + if (lsame_(pivtng, "N")) { + ipvtng = 0; + } else if (lsame_(pivtng, " ")) { + ipvtng = 0; + } else if (lsame_(pivtng, "L")) { + ipvtng = 1; + npvts = *m; + } else if (lsame_(pivtng, "R")) { + ipvtng = 2; + npvts = *n; + } else if (lsame_(pivtng, "B")) { + ipvtng = 3; + npvts = f2cmin(*n,*m); + } else if (lsame_(pivtng, "F")) { + ipvtng = 3; + npvts = f2cmin(*n,*m); + } else { + ipvtng = -1; + } + +/* Decode GRADE */ + + if (lsame_(grade, "N")) { + igrade = 0; + } else if (lsame_(grade, "L")) { + igrade = 1; + } else if (lsame_(grade, "R")) { + igrade = 2; + } else if (lsame_(grade, "B")) { + igrade = 3; + } else if (lsame_(grade, "E")) { + igrade = 4; + } else if (lsame_(grade, "H") || lsame_(grade, + "S")) { + igrade = 5; + } else { + igrade = -1; + } + +/* Decode PACK */ + + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + } else if (lsame_(pack, "C")) { + ipack = 3; + } else if (lsame_(pack, "R")) { + ipack = 4; + } else if (lsame_(pack, "B")) { + ipack = 5; + } else if (lsame_(pack, "Q")) { + ipack = 6; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + kll = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + kuu = f2cmin(i__1,i__2); + +/* If inv(DL) is used, check to see if DL has a zero entry. */ + + dzero = FALSE_; + if (igrade == 4 && *model == 0) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (dl[i__] == 0.f) { + dzero = TRUE_; + } +/* L10: */ + } + } + +/* Check values in IPIVOT */ + + badpvt = FALSE_; + if (ipvtng > 0) { + i__1 = npvts; + for (j = 1; j <= i__1; ++j) { + if (ipivot[j] <= 0 || ipivot[j] > npvts) { + badpvt = TRUE_; + } +/* L20: */ + } + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && isym == 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (*mode < -6 || *mode > 6) { + *info = -7; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) { + *info = -8; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) { + *info = -10; + } else if (igrade == -1 || igrade == 4 && *m != *n || igrade >= 1 && + igrade <= 4 && isym == 0) { + *info = -11; + } else if (igrade == 4 && dzero) { + *info = -12; + } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && ( + *model < -6 || *model > 6)) { + *info = -13; + } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) && ( + *model != -6 && *model != 0 && *model != 6) && *condl < 1.f) { + *info = -14; + } else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) { + *info = -16; + } else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 && + *moder != 6) && *condr < 1.f) { + *info = -17; + } else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 || + ipvtng == 2) && isym == 0) { + *info = -18; + } else if (ipvtng != 0 && badpvt) { + *info = -19; + } else if (*kl < 0) { + *info = -20; + } else if (*ku < 0 || isym == 0 && *kl != *ku) { + *info = -21; + } else if (*sparse < 0.f || *sparse > 1.f) { + *info = -22; + } else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 || + ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0 + || *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n)) + { + *info = -24; + } else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < f2cmax(1,*m) || + (ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack == + 6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) { + *info = -26; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLATMR", &i__1); + return 0; + } + +/* Decide if we can pivot consistently */ + + fulbnd = FALSE_; + if (kuu == *n - 1 && kll == *m - 1) { + fulbnd = TRUE_; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L30: */ + } + + iseed[4] = (iseed[4] / 2 << 1) + 1; + +/* 2) Set up D, DL, and DR, if indicated. */ + +/* Compute D according to COND and MODE */ + + slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info); + if (*info != 0) { + *info = 1; + return 0; + } + if (*mode != 0 && *mode != -6 && *mode != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = mnmin; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = temp, r__3 = (r__1 = d__[i__], abs(r__1)); + temp = f2cmax(r__2,r__3); +/* L40: */ + } + if (temp == 0.f && *dmax__ != 0.f) { + *info = 2; + return 0; + } + if (temp != 0.f) { + alpha = *dmax__ / temp; + } else { + alpha = 1.f; + } + i__1 = mnmin; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = alpha * d__[i__]; +/* L50: */ + } + + } + +/* Compute DL if grading set */ + + if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5) { + slatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info); + if (*info != 0) { + *info = 3; + return 0; + } + } + +/* Compute DR if grading set */ + + if (igrade == 2 || igrade == 3) { + slatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info); + if (*info != 0) { + *info = 4; + return 0; + } + } + +/* 3) Generate IWORK if pivoting */ + + if (ipvtng > 0) { + i__1 = npvts; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = i__; +/* L60: */ + } + if (fulbnd) { + i__1 = npvts; + for (i__ = 1; i__ <= i__1; ++i__) { + k = ipivot[i__]; + j = iwork[i__]; + iwork[i__] = iwork[k]; + iwork[k] = j; +/* L70: */ + } + } else { + for (i__ = npvts; i__ >= 1; --i__) { + k = ipivot[i__]; + j = iwork[i__]; + iwork[i__] = iwork[k]; + iwork[k] = j; +/* L80: */ + } + } + } + +/* 4) Generate matrices for each kind of PACKing */ +/* Always sweep matrix columnwise (if symmetric, upper */ +/* half only) so that matrix generated does not depend */ +/* on PACK */ + + if (fulbnd) { + +/* Use SLATM3 so matrices generated with differing PIVOTing only */ +/* differ only in the order of their rows and/or columns. */ + + if (ipack == 0) { + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + a[isub + jsub * a_dim1] = temp; + a[jsub + isub * a_dim1] = temp; +/* L90: */ + } +/* L100: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + a[isub + jsub * a_dim1] = temp; +/* L110: */ + } +/* L120: */ + } + } + + } else if (ipack == 1) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + a[mnsub + mxsub * a_dim1] = temp; + if (mnsub != mxsub) { + a[mxsub + mnsub * a_dim1] = 0.f; + } +/* L130: */ + } +/* L140: */ + } + + } else if (ipack == 2) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + a[mxsub + mnsub * a_dim1] = temp; + if (mnsub != mxsub) { + a[mnsub + mxsub * a_dim1] = 0.f; + } +/* L150: */ + } +/* L160: */ + } + + } else if (ipack == 3) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + +/* Compute K = location of (ISUB,JSUB) entry in packed */ +/* array */ + + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + k = mxsub * (mxsub - 1) / 2 + mnsub; + +/* Convert K to (IISUB,JJSUB) location */ + + jjsub = (k - 1) / *lda + 1; + iisub = k - *lda * (jjsub - 1); + + a[iisub + jjsub * a_dim1] = temp; +/* L170: */ + } +/* L180: */ + } + + } else if (ipack == 4) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + +/* Compute K = location of (I,J) entry in packed array */ + + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mnsub == 1) { + k = mxsub; + } else { + k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n - + mnsub + 2) / 2 + mxsub - mnsub + 1; + } + +/* Convert K to (IISUB,JJSUB) location */ + + jjsub = (k - 1) / *lda + 1; + iisub = k - *lda * (jjsub - 1); + + a[iisub + jjsub * a_dim1] = temp; +/* L190: */ + } +/* L200: */ + } + + } else if (ipack == 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + if (i__ < 1) { + a[j - i__ + 1 + (i__ + *n) * a_dim1] = 0.f; + } else { + temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + a[mxsub - mnsub + 1 + mnsub * a_dim1] = temp; + } +/* L210: */ + } +/* L220: */ + } + + } else if (ipack == 6) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + a[mnsub - mxsub + kuu + 1 + mxsub * a_dim1] = temp; +/* L230: */ + } +/* L240: */ + } + + } else if (ipack == 7) { + + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + a[mnsub - mxsub + kuu + 1 + mxsub * a_dim1] = temp; + if (i__ < 1) { + a[j - i__ + 1 + kuu + (i__ + *n) * a_dim1] = 0.f; + } + if (i__ >= 1 && mnsub != mxsub) { + a[mxsub - mnsub + 1 + kuu + mnsub * a_dim1] = + temp; + } +/* L250: */ + } +/* L260: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + kll; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + temp = slatm3_(m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + a[isub - jsub + kuu + 1 + jsub * a_dim1] = temp; +/* L270: */ + } +/* L280: */ + } + } + + } + + } else { + +/* Use SLATM2 */ + + if (ipack == 0) { + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = slatm2_(m, n, &i__, &j, kl, ku, + &idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + a[j + i__ * a_dim1] = a[i__ + j * a_dim1]; +/* L290: */ + } +/* L300: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = slatm2_(m, n, &i__, &j, kl, ku, + &idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); +/* L310: */ + } +/* L320: */ + } + } + + } else if (ipack == 1) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = slatm2_(m, n, &i__, &j, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + if (i__ != j) { + a[j + i__ * a_dim1] = 0.f; + } +/* L330: */ + } +/* L340: */ + } + + } else if (ipack == 2) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = slatm2_(m, n, &i__, &j, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + if (i__ != j) { + a[i__ + j * a_dim1] = 0.f; + } +/* L350: */ + } +/* L360: */ + } + + } else if (ipack == 3) { + + isub = 0; + jsub = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++isub; + if (isub > *lda) { + isub = 1; + ++jsub; + } + a[isub + jsub * a_dim1] = slatm2_(m, n, &i__, &j, kl, ku, + &idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[ + 1], &ipvtng, &iwork[1], sparse); +/* L370: */ + } +/* L380: */ + } + + } else if (ipack == 4) { + + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + +/* Compute K = location of (I,J) entry in packed array */ + + if (i__ == 1) { + k = j; + } else { + k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n - + i__ + 2) / 2 + j - i__ + 1; + } + +/* Convert K to (ISUB,JSUB) location */ + + jsub = (k - 1) / *lda + 1; + isub = k - *lda * (jsub - 1); + + a[isub + jsub * a_dim1] = slatm2_(m, n, &i__, &j, kl, + ku, &idist, &iseed[1], &d__[1], &igrade, &dl[ + 1], &dr[1], &ipvtng, &iwork[1], sparse); +/* L390: */ + } +/* L400: */ + } + } else { + isub = 0; + jsub = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++isub; + if (isub > *lda) { + isub = 1; + ++jsub; + } + a[isub + jsub * a_dim1] = slatm2_(m, n, &i__, &j, kl, + ku, &idist, &iseed[1], &d__[1], &igrade, &dl[ + 1], &dr[1], &ipvtng, &iwork[1], sparse); +/* L410: */ + } +/* L420: */ + } + } + + } else if (ipack == 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + if (i__ < 1) { + a[j - i__ + 1 + (i__ + *n) * a_dim1] = 0.f; + } else { + a[j - i__ + 1 + i__ * a_dim1] = slatm2_(m, n, &i__, & + j, kl, ku, &idist, &iseed[1], &d__[1], & + igrade, &dl[1], &dr[1], &ipvtng, &iwork[1], + sparse); + } +/* L430: */ + } +/* L440: */ + } + + } else if (ipack == 6) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + a[i__ - j + kuu + 1 + j * a_dim1] = slatm2_(m, n, &i__, & + j, kl, ku, &idist, &iseed[1], &d__[1], &igrade, & + dl[1], &dr[1], &ipvtng, &iwork[1], sparse); +/* L450: */ + } +/* L460: */ + } + + } else if (ipack == 7) { + + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + a[i__ - j + kuu + 1 + j * a_dim1] = slatm2_(m, n, & + i__, &j, kl, ku, &idist, &iseed[1], &d__[1], & + igrade, &dl[1], &dr[1], &ipvtng, &iwork[1], + sparse); + if (i__ < 1) { + a[j - i__ + 1 + kuu + (i__ + *n) * a_dim1] = 0.f; + } + if (i__ >= 1 && i__ != j) { + a[j - i__ + 1 + kuu + i__ * a_dim1] = a[i__ - j + + kuu + 1 + j * a_dim1]; + } +/* L470: */ + } +/* L480: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + kll; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + a[i__ - j + kuu + 1 + j * a_dim1] = slatm2_(m, n, & + i__, &j, kl, ku, &idist, &iseed[1], &d__[1], & + igrade, &dl[1], &dr[1], &ipvtng, &iwork[1], + sparse); +/* L490: */ + } +/* L500: */ + } + } + + } + + } + +/* 5) Scaling the norm */ + + if (ipack == 0) { + onorm = slange_("M", m, n, &a[a_offset], lda, tempa); + } else if (ipack == 1) { + onorm = slansy_("M", "U", n, &a[a_offset], lda, tempa); + } else if (ipack == 2) { + onorm = slansy_("M", "L", n, &a[a_offset], lda, tempa); + } else if (ipack == 3) { + onorm = slansp_("M", "U", n, &a[a_offset], tempa); + } else if (ipack == 4) { + onorm = slansp_("M", "L", n, &a[a_offset], tempa); + } else if (ipack == 5) { + onorm = slansb_("M", "L", n, &kll, &a[a_offset], lda, tempa); + } else if (ipack == 6) { + onorm = slansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa); + } else if (ipack == 7) { + onorm = slangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa); + } + + if (*anorm >= 0.f) { + + if (*anorm > 0.f && onorm == 0.f) { + +/* Desired scaling impossible */ + + *info = 5; + return 0; + + } else if (*anorm > 1.f && onorm < 1.f || *anorm < 1.f && onorm > 1.f) + { + +/* Scale carefully to avoid over / underflow */ + + if (ipack <= 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + r__1 = 1.f / onorm; + sscal_(m, &r__1, &a[j * a_dim1 + 1], &c__1); + sscal_(m, anorm, &a[j * a_dim1 + 1], &c__1); +/* L510: */ + } + + } else if (ipack == 3 || ipack == 4) { + + i__1 = *n * (*n + 1) / 2; + r__1 = 1.f / onorm; + sscal_(&i__1, &r__1, &a[a_offset], &c__1); + i__1 = *n * (*n + 1) / 2; + sscal_(&i__1, anorm, &a[a_offset], &c__1); + + } else if (ipack >= 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = kll + kuu + 1; + r__1 = 1.f / onorm; + sscal_(&i__2, &r__1, &a[j * a_dim1 + 1], &c__1); + i__2 = kll + kuu + 1; + sscal_(&i__2, anorm, &a[j * a_dim1 + 1], &c__1); +/* L520: */ + } + + } + + } else { + +/* Scale straightforwardly */ + + if (ipack <= 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + r__1 = *anorm / onorm; + sscal_(m, &r__1, &a[j * a_dim1 + 1], &c__1); +/* L530: */ + } + + } else if (ipack == 3 || ipack == 4) { + + i__1 = *n * (*n + 1) / 2; + r__1 = *anorm / onorm; + sscal_(&i__1, &r__1, &a[a_offset], &c__1); + + } else if (ipack >= 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = kll + kuu + 1; + r__1 = *anorm / onorm; + sscal_(&i__2, &r__1, &a[j * a_dim1 + 1], &c__1); +/* L540: */ + } + } + + } + + } + +/* End of SLATMR */ + + return 0; +} /* slatmr_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slatms.c b/lapack-netlib/TESTING/MATGEN/slatms.c new file mode 100644 index 000000000..66da7b3b4 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slatms.c @@ -0,0 +1,1765 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATMS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* KL, KU, PACK, A, LDA, WORK, INFO ) */ + +/* CHARACTER DIST, PACK, SYM */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, N */ +/* REAL COND, DMAX */ +/* INTEGER ISEED( 4 ) */ +/* REAL A( LDA, * ), D( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATMS generates random matrices with specified singular values */ +/* > (or symmetric/hermitian with specified eigenvalues) */ +/* > for testing LAPACK programs. */ +/* > */ +/* > SLATMS operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and SYM */ +/* > as described below. */ +/* > */ +/* > Generate a matrix with the appropriate band structure, by one */ +/* > of two methods: */ +/* > */ +/* > Method A: */ +/* > Generate a dense M x N matrix by multiplying D on the left */ +/* > and the right by random unitary matrices, then: */ +/* > */ +/* > Reduce the bandwidth according to KL and KU, using */ +/* > Householder transformations. */ +/* > */ +/* > Method B: */ +/* > Convert the bandwidth-0 (i.e., diagonal) matrix to a */ +/* > bandwidth-1 matrix using Givens rotations, "chasing" */ +/* > out-of-band elements back, much as in QR; then */ +/* > convert the bandwidth-1 to a bandwidth-2 matrix, etc. */ +/* > Note that for reasonably small bandwidths (relative to */ +/* > M and N) this requires less storage, as a dense matrix */ +/* > is not generated. Also, for symmetric matrices, only */ +/* > one triangle is generated. */ +/* > */ +/* > Method A is chosen if the bandwidth is a large fraction of the */ +/* > order of the matrix, and LDA is at least M (so a dense */ +/* > matrix can be stored.) Method B is chosen if the bandwidth */ +/* > is small (< 1/2 N for symmetric, < .3 N+M for */ +/* > non-symmetric), or LDA is less than M and not less than the */ +/* > bandwidth. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if symmetric) */ +/* > zero out lower half (if symmetric) */ +/* > store the upper half columnwise (if symmetric or upper */ +/* > triangular) */ +/* > store the lower half columnwise (if symmetric or lower */ +/* > triangular) */ +/* > store the lower triangle in banded format (if symmetric */ +/* > or lower triangular) */ +/* > store the upper triangle in banded format (if symmetric */ +/* > or upper triangular) */ +/* > store the entire matrix in banded format */ +/* > If Method B is chosen, and band format is specified, then the */ +/* > matrix will be generated in the band format, so no repacking */ +/* > will be necessary. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values. */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to SLATMS */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='S' or 'H', the generated matrix is symmetric, with */ +/* > eigenvalues specified by D, COND, MODE, and DMAX; they */ +/* > may be positive, negative, or zero. */ +/* > If SYM='P', the generated matrix is symmetric, with */ +/* > eigenvalues (= singular values) specified by D, COND, */ +/* > MODE, and DMAX; they will not be negative. */ +/* > If SYM='N', the generated matrix is nonsymmetric, with */ +/* > singular values specified by D, COND, MODE, and DMAX; */ +/* > they will not be negative. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension ( MIN( M , N ) ) */ +/* > This array is used to specify the singular values or */ +/* > eigenvalues of A (see SYM, above.) If MODE=0, then D is */ +/* > assumed to contain the singular/eigenvalues, otherwise */ +/* > they will be computed according to MODE, COND, and DMAX, */ +/* > and placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the singular/eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then */ +/* > the elements of D will also be multiplied by a random */ +/* > sign (i.e., +1 or -1.) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is REAL */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is REAL */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))); thus, the maximum absolute eigen- or */ +/* > singular value (which is to say the norm) will be abs(DMAX). */ +/* > Note that DMAX need not be positive: if DMAX is negative */ +/* > (or zero), D will be scaled by a negative number (or zero). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL being at least M-1 means that the matrix */ +/* > has full lower bandwidth. KL must equal KU if the matrix */ +/* > is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU being at least N-1 means that the matrix */ +/* > has full upper bandwidth. KL must equal KU if the matrix */ +/* > is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > This specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries (if symmetric) */ +/* > 'L' => zero out all superdiagonal entries (if symmetric) */ +/* > 'C' => store the upper triangle columnwise */ +/* > (only if the matrix is symmetric or upper triangular) */ +/* > 'R' => store the lower triangle columnwise */ +/* > (only if the matrix is symmetric or lower triangular) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if matrix symmetric or lower triangular) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if matrix symmetric or upper triangular) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, SB or TB - use 'B' or 'Q' */ +/* > PP, SP or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to SLATMS differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. A is first generated */ +/* > in full (unpacked) form, and then packed, if so specified */ +/* > by PACK. Thus, the first M elements of the first N */ +/* > columns will always be modified. If PACK specifies a */ +/* > packed or banded storage scheme, all LDA elements of the */ +/* > first N columns will be modified; the elements of the */ +/* > array which do not correspond to elements of the generated */ +/* > matrix are set to zero. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */ +/* > LDA must be at least M. If PACK='B' or 'Q', then LDA must */ +/* > be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */ +/* > If PACK='Z', LDA must be large enough to hold the packed */ +/* > array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension ( 3*MAX( N , M ) ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => KL negative */ +/* > -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL */ +/* > -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */ +/* > or PACK='C' or 'Q' and SYM='N' and KL is not zero; */ +/* > or PACK='R' or 'B' and SYM='N' and KU is not zero; */ +/* > or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */ +/* > N. */ +/* > -14 => LDA is less than M, or PACK='Z' and LDA is less than */ +/* > MIN(KU,N-1) + MIN(KL,M-1) + 1. */ +/* > 1 => Error return from SLATM1 */ +/* > 2 => Cannot scale to DMAX (f2cmax. sing. value is 0) */ +/* > 3 => Error return from SLAGGE or SLAGSY */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slatms_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__, + integer *kl, integer *ku, char *pack, real *a, integer *lda, real * + work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real r__1, r__2, r__3; + logical L__1; + + /* Local variables */ + integer ilda, icol; + real temp; + integer irow, isym; + real c__; + integer i__, j, k; + real s, alpha, angle; + integer ipack, ioffg; + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer idist, mnmin, iskew; + real extra, dummy; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), slatm1_(integer *, real *, integer *, integer *, + integer *, real *, integer *, integer *); + integer ic, jc, nc, il, iendch, ir, jr, ipackg, mr; + extern /* Subroutine */ int slagge_(integer *, integer *, integer *, + integer *, real *, real *, integer *, integer *, real *, integer * + ); + integer minlda; + extern /* Subroutine */ int xerbla_(char *, integer *); + extern real slarnd_(integer *, integer *); + logical iltemp, givens; + integer ioffst, irsign; + extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real * + ), slaset_(char *, integer *, integer *, real *, real *, real *, + integer *), slagsy_(integer *, integer *, real *, real *, + integer *, integer *, real *, integer *), slarot_(logical *, + logical *, logical *, integer *, real *, real *, real *, integer * + , real *, real *); + logical ilextr, topdwn; + integer ir1, ir2, isympk, jch, llb, jkl, jku, uub; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "N")) { + isym = 1; + irsign = 0; + } else if (lsame_(sym, "P")) { + isym = 2; + irsign = 0; + } else if (lsame_(sym, "S")) { + isym = 2; + irsign = 1; + } else if (lsame_(sym, "H")) { + isym = 2; + irsign = 1; + } else { + isym = -1; + } + +/* Decode PACK */ + + isympk = 0; + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + isympk = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + isympk = 1; + } else if (lsame_(pack, "C")) { + ipack = 3; + isympk = 2; + } else if (lsame_(pack, "R")) { + ipack = 4; + isympk = 3; + } else if (lsame_(pack, "B")) { + ipack = 5; + isympk = 3; + } else if (lsame_(pack, "Q")) { + ipack = 6; + isympk = 2; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + llb = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + uub = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *m, i__2 = *n + llb; + mr = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *n, i__2 = *m + uub; + nc = f2cmin(i__1,i__2); + + if (ipack == 5 || ipack == 6) { + minlda = uub + 1; + } else if (ipack == 7) { + minlda = llb + uub + 1; + } else { + minlda = *m; + } + +/* Use Givens rotation method if bandwidth small enough, */ +/* or if LDA is too small to store the matrix unpacked. */ + + givens = FALSE_; + if (isym == 1) { +/* Computing MAX */ + i__1 = 1, i__2 = mr + nc; + if ((real) (llb + uub) < (real) f2cmax(i__1,i__2) * .3f) { + givens = TRUE_; + } + } else { + if (llb << 1 < *m) { + givens = TRUE_; + } + } + if (*lda < *m && *lda >= minlda) { + givens = TRUE_; + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && isym != 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (abs(*mode) > 6) { + *info = -7; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) { + *info = -8; + } else if (*kl < 0) { + *info = -10; + } else if (*ku < 0 || isym != 1 && *kl != *ku) { + *info = -11; + } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym + == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk + != 0 && *m != *n) { + *info = -12; + } else if (*lda < f2cmax(1,minlda)) { + *info = -14; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLATMS", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L10: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up D if indicated. */ + +/* Compute D according to COND and MODE */ + + slatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, &iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + +/* Choose Top-Down if D is (apparently) increasing, */ +/* Bottom-Up if D is (apparently) decreasing. */ + + if (abs(d__[1]) <= (r__1 = d__[mnmin], abs(r__1))) { + topdwn = TRUE_; + } else { + topdwn = FALSE_; + } + + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = mnmin; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = temp, r__3 = (r__1 = d__[i__], abs(r__1)); + temp = f2cmax(r__2,r__3); +/* L20: */ + } + + if (temp > 0.f) { + alpha = *dmax__ / temp; + } else { + *info = 2; + return 0; + } + + sscal_(&mnmin, &alpha, &d__[1], &c__1); + + } + +/* 3) Generate Banded Matrix using Givens rotations. */ +/* Also the special case of UUB=LLB=0 */ + +/* Compute Addressing constants to cover all */ +/* storage formats. Whether GE, SY, GB, or SB, */ +/* upper or lower triangle or both, */ +/* the (i,j)-th element is in */ +/* A( i - ISKEW*j + IOFFST, j ) */ + + if (ipack > 4) { + ilda = *lda - 1; + iskew = 1; + if (ipack > 5) { + ioffst = uub + 1; + } else { + ioffst = 1; + } + } else { + ilda = *lda; + iskew = 0; + ioffst = 0; + } + +/* IPACKG is the format that the matrix is generated in. If this is */ +/* different from IPACK, then the matrix must be repacked at the */ +/* end. It also signals how to compute the norm, for scaling. */ + + ipackg = 0; + slaset_("Full", lda, n, &c_b22, &c_b22, &a[a_offset], lda); + +/* Diagonal Matrix -- We are done, unless it */ +/* is to be stored SP/PP/TP (PACK='R' or 'C') */ + + if (llb == 0 && uub == 0) { + i__1 = ilda + 1; + scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &i__1) + ; + if (ipack <= 2 || ipack >= 5) { + ipackg = ipack; + } + + } else if (givens) { + +/* Check whether to use Givens rotations, */ +/* Householder transformations, or nothing. */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + if (ipack > 4) { + ipackg = ipack; + } else { + ipackg = 0; + } + + i__1 = ilda + 1; + scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], & + i__1); + + if (topdwn) { + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* Last row actually rotated is M */ +/* Last column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__3 = *m + jku; + i__2 = f2cmin(i__3,*n) + jkl - 1; + for (jr = 1; jr <= i__2; ++jr) { + extra = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__4 = jr - jkl; + icol = f2cmax(i__3,i__4); + if (jr < *m) { +/* Computing MIN */ + i__3 = *n, i__4 = jr + jku; + il = f2cmin(i__3,i__4) + 1 - icol; + L__1 = jr > jkl; + slarot_(&c_true, &L__1, &c_false, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ir = jr; + ic = icol; + i__3 = -jkl - jku; + for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ir < *m) { + slartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &c__, & + s, &dummy); + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + temp = 0.f; + iltemp = jch > jku; + r__1 = -s; + slarot_(&c_false, &iltemp, &c_true, &il, &c__, & + r__1, &a[irow - iskew * ic + ioffst + ic * + a_dim1], &ilda, &temp, &extra); + if (iltemp) { + slartg_(&a[irow + 1 - iskew * (ic + 1) + + ioffst + (ic + 1) * a_dim1], &temp, & + c__, &s, &dummy); +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + extra = 0.f; + L__1 = jch > jku + jkl; + r__1 = -s; + slarot_(&c_true, &L__1, &c_true, &il, &c__, & + r__1, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, & + temp); + ic = icol; + ir = irow; + } +/* L30: */ + } +/* L40: */ + } +/* L50: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* Computing MIN */ + i__3 = *n + jkl; + i__2 = f2cmin(i__3,*m) + jku - 1; + for (jc = 1; jc <= i__2; ++jc) { + extra = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__4 = jc - jku; + irow = f2cmax(i__3,i__4); + if (jc < *n) { +/* Computing MIN */ + i__3 = *m, i__4 = jc + jkl; + il = f2cmin(i__3,i__4) + 1 - irow; + L__1 = jc > jku; + slarot_(&c_false, &L__1, &c_false, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ic = jc; + ir = irow; + i__3 = -jkl - jku; + for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ic < *n) { + slartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &c__, & + s, &dummy); + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + temp = 0.f; + iltemp = jch > jkl; + r__1 = -s; + slarot_(&c_true, &iltemp, &c_true, &il, &c__, & + r__1, &a[ir - iskew * icol + ioffst + + icol * a_dim1], &ilda, &temp, &extra); + if (iltemp) { + slartg_(&a[ir + 1 - iskew * (icol + 1) + + ioffst + (icol + 1) * a_dim1], &temp, + &c__, &s, &dummy); +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + extra = 0.f; + L__1 = jch > jkl + jku; + r__1 = -s; + slarot_(&c_false, &L__1, &c_true, &il, &c__, & + r__1, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, & + temp); + ic = icol; + ir = irow; + } +/* L60: */ + } +/* L70: */ + } +/* L80: */ + } + + } else { + +/* Bottom-Up -- Start at the bottom right. */ + + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* First row actually rotated is M */ +/* First column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n + jkl; + iendch = f2cmin(i__2,i__3) - 1; +/* Computing MIN */ + i__2 = *m + jku; + i__3 = 1 - jkl; + for (jc = f2cmin(i__2,*n) - 1; jc >= i__3; --jc) { + extra = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__2 = 1, i__4 = jc - jku + 1; + irow = f2cmax(i__2,i__4); + if (jc > 0) { +/* Computing MIN */ + i__2 = *m, i__4 = jc + jkl + 1; + il = f2cmin(i__2,i__4) + 1 - irow; + L__1 = jc + jkl < *m; + slarot_(&c_false, &c_false, &L__1, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ic = jc; + i__2 = iendch; + i__4 = jkl + jku; + for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <= + i__2; jch += i__4) { + ilextr = ic > 0; + if (ilextr) { + slartg_(&a[jch - iskew * ic + ioffst + ic * + a_dim1], &extra, &c__, &s, &dummy); + } + ic = f2cmax(1,ic); +/* Computing MIN */ + i__5 = *n - 1, i__6 = jch + jku; + icol = f2cmin(i__5,i__6); + iltemp = jch + jku < *n; + temp = 0.f; + i__5 = icol + 2 - ic; + slarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, & + s, &a[jch - iskew * ic + ioffst + ic * + a_dim1], &ilda, &extra, &temp); + if (iltemp) { + slartg_(&a[jch - iskew * icol + ioffst + icol + * a_dim1], &temp, &c__, &s, &dummy); +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra = 0.f; + L__1 = jch + jkl + jku <= iendch; + slarot_(&c_false, &c_true, &L__1, &il, &c__, & + s, &a[jch - iskew * icol + ioffst + + icol * a_dim1], &ilda, &temp, &extra); + ic = icol; + } +/* L90: */ + } +/* L100: */ + } +/* L110: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* First row actually rotated is MIN( N+JKL, M ) */ +/* First column actually rotated is N */ + +/* Computing MIN */ + i__3 = *n, i__4 = *m + jku; + iendch = f2cmin(i__3,i__4) - 1; +/* Computing MIN */ + i__3 = *n + jkl; + i__4 = 1 - jku; + for (jr = f2cmin(i__3,*m) - 1; jr >= i__4; --jr) { + extra = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__2 = jr - jkl + 1; + icol = f2cmax(i__3,i__2); + if (jr > 0) { +/* Computing MIN */ + i__3 = *n, i__2 = jr + jku + 1; + il = f2cmin(i__3,i__2) + 1 - icol; + L__1 = jr + jku < *n; + slarot_(&c_true, &c_false, &L__1, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ir = jr; + i__3 = iendch; + i__2 = jkl + jku; + for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <= + i__3; jch += i__2) { + ilextr = ir > 0; + if (ilextr) { + slartg_(&a[ir - iskew * jch + ioffst + jch * + a_dim1], &extra, &c__, &s, &dummy); + } + ir = f2cmax(1,ir); +/* Computing MIN */ + i__5 = *m - 1, i__6 = jch + jkl; + irow = f2cmin(i__5,i__6); + iltemp = jch + jkl < *m; + temp = 0.f; + i__5 = irow + 2 - ir; + slarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, & + s, &a[ir - iskew * jch + ioffst + jch * + a_dim1], &ilda, &extra, &temp); + if (iltemp) { + slartg_(&a[irow - iskew * jch + ioffst + jch * + a_dim1], &temp, &c__, &s, &dummy); +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra = 0.f; + L__1 = jch + jkl + jku <= iendch; + slarot_(&c_true, &c_true, &L__1, &il, &c__, & + s, &a[irow - iskew * jch + ioffst + + jch * a_dim1], &ilda, &temp, &extra); + ir = irow; + } +/* L120: */ + } +/* L130: */ + } +/* L140: */ + } + } + + } else { + +/* Symmetric -- A = U D U' */ + + ipackg = ipack; + ioffg = ioffst; + + if (topdwn) { + +/* Top-Down -- Generate Upper triangle only */ + + if (ipack >= 5) { + ipackg = 6; + ioffg = uub + 1; + } else { + ipackg = 1; + } + i__1 = ilda + 1; + scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1], + &i__1); + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + i__4 = *n - 1; + for (jc = 1; jc <= i__4; ++jc) { +/* Computing MAX */ + i__2 = 1, i__3 = jc - k; + irow = f2cmax(i__2,i__3); +/* Computing MIN */ + i__2 = jc + 1, i__3 = k + 2; + il = f2cmin(i__2,i__3); + extra = 0.f; + temp = a[jc - iskew * (jc + 1) + ioffg + (jc + 1) * + a_dim1]; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = sin(angle); + L__1 = jc > k; + slarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[ + irow - iskew * jc + ioffg + jc * a_dim1], & + ilda, &extra, &temp); +/* Computing MIN */ + i__3 = k, i__5 = *n - jc; + i__2 = f2cmin(i__3,i__5) + 1; + slarot_(&c_true, &c_true, &c_false, &i__2, &c__, &s, & + a[(1 - iskew) * jc + ioffg + jc * a_dim1], & + ilda, &temp, &dummy); + +/* Chase EXTRA back up the matrix */ + + icol = jc; + i__2 = -k; + for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1; + jch += i__2) { + slartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg + + (icol + 1) * a_dim1], &extra, &c__, &s, & + dummy); + temp = a[jch - iskew * (jch + 1) + ioffg + (jch + + 1) * a_dim1]; + i__3 = k + 2; + r__1 = -s; + slarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + r__1, &a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &temp, &extra); +/* Computing MAX */ + i__3 = 1, i__5 = jch - k; + irow = f2cmax(i__3,i__5); +/* Computing MIN */ + i__3 = jch + 1, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra = 0.f; + L__1 = jch > k; + r__1 = -s; + slarot_(&c_false, &L__1, &c_true, &il, &c__, & + r__1, &a[irow - iskew * jch + ioffg + jch + * a_dim1], &ilda, &extra, &temp); + icol = jch; +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + +/* If we need lower triangle, copy from upper. Note that */ +/* the order of copying is chosen to work for 'q' -> 'b' */ + + if (ipack != ipackg && ipack != 3) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst - iskew * jc; +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + a[jr + irow + jc * a_dim1] = a[jc - iskew * jr + + ioffg + jr * a_dim1]; +/* L180: */ + } +/* L190: */ + } + if (ipack == 5) { + i__1 = *n; + for (jc = *n - uub + 1; jc <= i__1; ++jc) { + i__4 = uub + 1; + for (jr = *n + 2 - jc; jr <= i__4; ++jr) { + a[jr + jc * a_dim1] = 0.f; +/* L200: */ + } +/* L210: */ + } + } + if (ipackg == 6) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } else { + +/* Bottom-Up -- Generate Lower triangle only */ + + if (ipack >= 5) { + ipackg = 5; + if (ipack == 6) { + ioffg = 1; + } + } else { + ipackg = 2; + } + i__1 = ilda + 1; + scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1], + &i__1); + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + for (jc = *n - 1; jc >= 1; --jc) { +/* Computing MIN */ + i__4 = *n + 1 - jc, i__2 = k + 2; + il = f2cmin(i__4,i__2); + extra = 0.f; + temp = a[(1 - iskew) * jc + 1 + ioffg + jc * a_dim1]; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = -sin(angle); + L__1 = *n - jc > k; + slarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[( + 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda, + &temp, &extra); +/* Computing MAX */ + i__4 = 1, i__2 = jc - k + 1; + icol = f2cmax(i__4,i__2); + i__4 = jc + 2 - icol; + slarot_(&c_true, &c_false, &c_true, &i__4, &c__, &s, & + a[jc - iskew * icol + ioffg + icol * a_dim1], + &ilda, &dummy, &temp); + +/* Chase EXTRA back down the matrix */ + + icol = jc; + i__4 = *n - 1; + i__2 = k; + for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <= + i__4; jch += i__2) { + slartg_(&a[jch - iskew * icol + ioffg + icol * + a_dim1], &extra, &c__, &s, &dummy); + temp = a[(1 - iskew) * jch + 1 + ioffg + jch * + a_dim1]; + i__3 = k + 2; + slarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[jch - iskew * icol + ioffg + icol * + a_dim1], &ilda, &extra, &temp); +/* Computing MIN */ + i__3 = *n + 1 - jch, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra = 0.f; + L__1 = *n - jch > k; + slarot_(&c_false, &c_true, &L__1, &il, &c__, &s, & + a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &temp, &extra); + icol = jch; +/* L220: */ + } +/* L230: */ + } +/* L240: */ + } + +/* If we need upper triangle, copy from lower. Note that */ +/* the order of copying is chosen to work for 'b' -> 'q' */ + + if (ipack != ipackg && ipack != 4) { + for (jc = *n; jc >= 1; --jc) { + irow = ioffst - iskew * jc; +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + a[jr + irow + jc * a_dim1] = a[jc - iskew * jr + + ioffg + jr * a_dim1]; +/* L250: */ + } +/* L260: */ + } + if (ipack == 6) { + i__1 = uub; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.f; +/* L270: */ + } +/* L280: */ + } + } + if (ipackg == 5) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } + } + + } else { + +/* 4) Generate Banded Matrix by first */ +/* Rotating by random Unitary matrices, */ +/* then reducing the bandwidth using Householder */ +/* transformations. */ + +/* Note: we should get here only if LDA .ge. N */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + slagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[ + 1], &work[1], &iinfo); + } else { + +/* Symmetric -- A = U D U' */ + + slagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[1], + &iinfo); + + } + if (iinfo != 0) { + *info = 3; + return 0; + } + } + +/* 5) Pack the matrix */ + + if (ipack != ipackg) { + if (ipack == 1) { + +/* 'U' -- Upper triangular, not packed */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.f; +/* L290: */ + } +/* L300: */ + } + + } else if (ipack == 2) { + +/* 'L' -- Lower triangular, not packed */ + + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.f; +/* L310: */ + } +/* L320: */ + } + + } else if (ipack == 3) { + +/* 'C' -- Upper triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + a[irow + icol * a_dim1] = a[i__ + j * a_dim1]; +/* L330: */ + } +/* L340: */ + } + + } else if (ipack == 4) { + +/* 'R' -- Lower triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + a[irow + icol * a_dim1] = a[i__ + j * a_dim1]; +/* L350: */ + } +/* L360: */ + } + + } else if (ipack >= 5) { + +/* 'B' -- The lower triangle is packed as a band matrix. */ +/* 'Q' -- The upper triangle is packed as a band matrix. */ +/* 'Z' -- The whole matrix is packed as a band matrix. */ + + if (ipack == 5) { + uub = 0; + } + if (ipack == 6) { + llb = 0; + } + + i__1 = uub; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = j + llb; + for (i__ = f2cmin(i__2,*m); i__ >= 1; --i__) { + a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1]; +/* L370: */ + } +/* L380: */ + } + + i__1 = *n; + for (j = uub + 2; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = j + llb; + i__2 = f2cmin(i__4,*m); + for (i__ = j - uub; i__ <= i__2; ++i__) { + a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1]; +/* L390: */ + } +/* L400: */ + } + } + +/* If packed, zero out extraneous elements. */ + +/* Symmetric/Triangular Packed -- */ +/* zero out everything after A(IROW,ICOL) */ + + if (ipack == 3 || ipack == 4) { + i__1 = *m; + for (jc = icol; jc <= i__1; ++jc) { + i__2 = *lda; + for (jr = irow + 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.f; +/* L410: */ + } + irow = 0; +/* L420: */ + } + + } else if (ipack >= 5) { + +/* Packed Band -- */ +/* 1st row is now in A( UUB+2-j, j), zero above it */ +/* m-th row is now in A( M+UUB-j,j), zero below it */ +/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */ +/* zero below it, too. */ + + ir1 = uub + llb + 2; + ir2 = uub + *m + 2; + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.f; +/* L430: */ + } +/* Computing MAX */ +/* Computing MIN */ + i__3 = ir1, i__5 = ir2 - jc; + i__2 = 1, i__4 = f2cmin(i__3,i__5); + i__6 = *lda; + for (jr = f2cmax(i__2,i__4); jr <= i__6; ++jr) { + a[jr + jc * a_dim1] = 0.f; +/* L440: */ + } +/* L450: */ + } + } + } + + return 0; + +/* End of SLATMS */ + +} /* slatms_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/slatmt.c b/lapack-netlib/TESTING/MATGEN/slatmt.c new file mode 100644 index 000000000..a2eb68e6f --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/slatmt.c @@ -0,0 +1,1776 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLATMT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* RANK, KL, KU, PACK, A, LDA, WORK, INFO ) */ + +/* REAL COND, DMAX */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK */ +/* CHARACTER DIST, PACK, SYM */ +/* REAL A( LDA, * ), D( * ), WORK( * ) */ +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATMT generates random matrices with specified singular values */ +/* > (or symmetric/hermitian with specified eigenvalues) */ +/* > for testing LAPACK programs. */ +/* > */ +/* > SLATMT operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and SYM */ +/* > as described below. */ +/* > */ +/* > Generate a matrix with the appropriate band structure, by one */ +/* > of two methods: */ +/* > */ +/* > Method A: */ +/* > Generate a dense M x N matrix by multiplying D on the left */ +/* > and the right by random unitary matrices, then: */ +/* > */ +/* > Reduce the bandwidth according to KL and KU, using */ +/* > Householder transformations. */ +/* > */ +/* > Method B: */ +/* > Convert the bandwidth-0 (i.e., diagonal) matrix to a */ +/* > bandwidth-1 matrix using Givens rotations, "chasing" */ +/* > out-of-band elements back, much as in QR; then */ +/* > convert the bandwidth-1 to a bandwidth-2 matrix, etc. */ +/* > Note that for reasonably small bandwidths (relative to */ +/* > M and N) this requires less storage, as a dense matrix */ +/* > is not generated. Also, for symmetric matrices, only */ +/* > one triangle is generated. */ +/* > */ +/* > Method A is chosen if the bandwidth is a large fraction of the */ +/* > order of the matrix, and LDA is at least M (so a dense */ +/* > matrix can be stored.) Method B is chosen if the bandwidth */ +/* > is small (< 1/2 N for symmetric, < .3 N+M for */ +/* > non-symmetric), or LDA is less than M and not less than the */ +/* > bandwidth. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if symmetric) */ +/* > zero out lower half (if symmetric) */ +/* > store the upper half columnwise (if symmetric or upper */ +/* > triangular) */ +/* > store the lower half columnwise (if symmetric or lower */ +/* > triangular) */ +/* > store the lower triangle in banded format (if symmetric */ +/* > or lower triangular) */ +/* > store the upper triangle in banded format (if symmetric */ +/* > or upper triangular) */ +/* > store the entire matrix in banded format */ +/* > If Method B is chosen, and band format is specified, then the */ +/* > matrix will be generated in the band format, so no repacking */ +/* > will be necessary. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values. */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to SLATMT */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='S' or 'H', the generated matrix is symmetric, with */ +/* > eigenvalues specified by D, COND, MODE, and DMAX; they */ +/* > may be positive, negative, or zero. */ +/* > If SYM='P', the generated matrix is symmetric, with */ +/* > eigenvalues (= singular values) specified by D, COND, */ +/* > MODE, and DMAX; they will not be negative. */ +/* > If SYM='N', the generated matrix is nonsymmetric, with */ +/* > singular values specified by D, COND, MODE, and DMAX; */ +/* > they will not be negative. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension ( MIN( M , N ) ) */ +/* > This array is used to specify the singular values or */ +/* > eigenvalues of A (see SYM, above.) If MODE=0, then D is */ +/* > assumed to contain the singular/eigenvalues, otherwise */ +/* > they will be computed according to MODE, COND, and DMAX, */ +/* > and placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the singular/eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D as input */ +/* > */ +/* > MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */ +/* > MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) */ +/* > */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then */ +/* > the elements of D will also be multiplied by a random */ +/* > sign (i.e., +1 or -1.) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is REAL */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is REAL */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))); thus, the maximum absolute eigen- or */ +/* > singular value (which is to say the norm) will be abs(DMAX). */ +/* > Note that DMAX need not be positive: if DMAX is negative */ +/* > (or zero), D will be scaled by a negative number (or zero). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The rank of matrix to be generated for modes 1,2,3 only. */ +/* > D( RANK+1:N ) = 0. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL being at least M-1 means that the matrix */ +/* > has full lower bandwidth. KL must equal KU if the matrix */ +/* > is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU being at least N-1 means that the matrix */ +/* > has full upper bandwidth. KL must equal KU if the matrix */ +/* > is symmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > This specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries (if symmetric) */ +/* > 'L' => zero out all superdiagonal entries (if symmetric) */ +/* > 'C' => store the upper triangle columnwise */ +/* > (only if the matrix is symmetric or upper triangular) */ +/* > 'R' => store the lower triangle columnwise */ +/* > (only if the matrix is symmetric or lower triangular) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if matrix symmetric or lower triangular) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if matrix symmetric or upper triangular) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, SB or TB - use 'B' or 'Q' */ +/* > PP, SP or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to SLATMT differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. A is first generated */ +/* > in full (unpacked) form, and then packed, if so specified */ +/* > by PACK. Thus, the first M elements of the first N */ +/* > columns will always be modified. If PACK specifies a */ +/* > packed or banded storage scheme, all LDA elements of the */ +/* > first N columns will be modified; the elements of the */ +/* > array which do not correspond to elements of the generated */ +/* > matrix are set to zero. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */ +/* > LDA must be at least M. If PACK='B' or 'Q', then LDA must */ +/* > be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */ +/* > If PACK='Z', LDA must be large enough to hold the packed */ +/* > array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension ( 3*MAX( N , M ) ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => KL negative */ +/* > -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL */ +/* > -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */ +/* > or PACK='C' or 'Q' and SYM='N' and KL is not zero; */ +/* > or PACK='R' or 'B' and SYM='N' and KU is not zero; */ +/* > or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */ +/* > N. */ +/* > -14 => LDA is less than M, or PACK='Z' and LDA is less than */ +/* > MIN(KU,N-1) + MIN(KL,M-1) + 1. */ +/* > 1 => Error return from SLATM7 */ +/* > 2 => Cannot scale to DMAX (f2cmax. sing. value is 0) */ +/* > 3 => Error return from SLAGGE or SLAGSY */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup real_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int slatmt_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, real *d__, integer *mode, real *cond, real *dmax__, + integer *rank, integer *kl, integer *ku, char *pack, real *a, integer + *lda, real *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real r__1, r__2, r__3; + logical L__1; + + /* Local variables */ + integer ilda, icol; + real temp; + integer irow, isym; + real c__; + integer i__, j, k; + real s, alpha, angle; + integer ipack, ioffg; + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer idist, mnmin, iskew; + real extra, dummy; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), slatm7_(integer *, real *, integer *, integer *, + integer *, real *, integer *, integer *, integer *); + integer ic, jc, nc, il, iendch, ir, jr, ipackg, mr; + extern /* Subroutine */ int slagge_(integer *, integer *, integer *, + integer *, real *, real *, integer *, integer *, real *, integer * + ); + integer minlda; + extern /* Subroutine */ int xerbla_(char *, integer *); + extern real slarnd_(integer *, integer *); + integer ioffst, irsign; + logical givens, iltemp; + extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real * + ), slaset_(char *, integer *, integer *, real *, real *, real *, + integer *), slagsy_(integer *, integer *, real *, real *, + integer *, integer *, real *, integer *), slarot_(logical *, + logical *, logical *, integer *, real *, real *, real *, integer * + , real *, real *); + logical ilextr, topdwn; + integer ir1, ir2, isympk, jch, llb, jkl, jku, uub; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "N")) { + isym = 1; + irsign = 0; + } else if (lsame_(sym, "P")) { + isym = 2; + irsign = 0; + } else if (lsame_(sym, "S")) { + isym = 2; + irsign = 1; + } else if (lsame_(sym, "H")) { + isym = 2; + irsign = 1; + } else { + isym = -1; + } + +/* Decode PACK */ + + isympk = 0; + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + isympk = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + isympk = 1; + } else if (lsame_(pack, "C")) { + ipack = 3; + isympk = 2; + } else if (lsame_(pack, "R")) { + ipack = 4; + isympk = 3; + } else if (lsame_(pack, "B")) { + ipack = 5; + isympk = 3; + } else if (lsame_(pack, "Q")) { + ipack = 6; + isympk = 2; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + llb = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + uub = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *m, i__2 = *n + llb; + mr = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *n, i__2 = *m + uub; + nc = f2cmin(i__1,i__2); + + if (ipack == 5 || ipack == 6) { + minlda = uub + 1; + } else if (ipack == 7) { + minlda = llb + uub + 1; + } else { + minlda = *m; + } + +/* Use Givens rotation method if bandwidth small enough, */ +/* or if LDA is too small to store the matrix unpacked. */ + + givens = FALSE_; + if (isym == 1) { +/* Computing MAX */ + i__1 = 1, i__2 = mr + nc; + if ((real) (llb + uub) < (real) f2cmax(i__1,i__2) * .3f) { + givens = TRUE_; + } + } else { + if (llb << 1 < *m) { + givens = TRUE_; + } + } + if (*lda < *m && *lda >= minlda) { + givens = TRUE_; + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && isym != 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (abs(*mode) > 6) { + *info = -7; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.f) { + *info = -8; + } else if (*kl < 0) { + *info = -10; + } else if (*ku < 0 || isym != 1 && *kl != *ku) { + *info = -11; + } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym + == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk + != 0 && *m != *n) { + *info = -12; + } else if (*lda < f2cmax(1,minlda)) { + *info = -14; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLATMT", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L100: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up D if indicated. */ + +/* Compute D according to COND and MODE */ + + slatm7_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, rank, & + iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + +/* Choose Top-Down if D is (apparently) increasing, */ +/* Bottom-Up if D is (apparently) decreasing. */ + + if (abs(d__[1]) <= (r__1 = d__[*rank], abs(r__1))) { + topdwn = TRUE_; + } else { + topdwn = FALSE_; + } + + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = *rank; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = temp, r__3 = (r__1 = d__[i__], abs(r__1)); + temp = f2cmax(r__2,r__3); +/* L110: */ + } + + if (temp > 0.f) { + alpha = *dmax__ / temp; + } else { + *info = 2; + return 0; + } + + sscal_(rank, &alpha, &d__[1], &c__1); + + } + +/* 3) Generate Banded Matrix using Givens rotations. */ +/* Also the special case of UUB=LLB=0 */ + +/* Compute Addressing constants to cover all */ +/* storage formats. Whether GE, SY, GB, or SB, */ +/* upper or lower triangle or both, */ +/* the (i,j)-th element is in */ +/* A( i - ISKEW*j + IOFFST, j ) */ + + if (ipack > 4) { + ilda = *lda - 1; + iskew = 1; + if (ipack > 5) { + ioffst = uub + 1; + } else { + ioffst = 1; + } + } else { + ilda = *lda; + iskew = 0; + ioffst = 0; + } + +/* IPACKG is the format that the matrix is generated in. If this is */ +/* different from IPACK, then the matrix must be repacked at the */ +/* end. It also signals how to compute the norm, for scaling. */ + + ipackg = 0; + slaset_("Full", lda, n, &c_b22, &c_b22, &a[a_offset], lda); + +/* Diagonal Matrix -- We are done, unless it */ +/* is to be stored SP/PP/TP (PACK='R' or 'C') */ + + if (llb == 0 && uub == 0) { + i__1 = ilda + 1; + scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], &i__1) + ; + if (ipack <= 2 || ipack >= 5) { + ipackg = ipack; + } + + } else if (givens) { + +/* Check whether to use Givens rotations, */ +/* Householder transformations, or nothing. */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + if (ipack > 4) { + ipackg = ipack; + } else { + ipackg = 0; + } + + i__1 = ilda + 1; + scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffst + a_dim1], & + i__1); + + if (topdwn) { + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* Last row actually rotated is M */ +/* Last column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__3 = *m + jku; + i__2 = f2cmin(i__3,*n) + jkl - 1; + for (jr = 1; jr <= i__2; ++jr) { + extra = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__4 = jr - jkl; + icol = f2cmax(i__3,i__4); + if (jr < *m) { +/* Computing MIN */ + i__3 = *n, i__4 = jr + jku; + il = f2cmin(i__3,i__4) + 1 - icol; + L__1 = jr > jkl; + slarot_(&c_true, &L__1, &c_false, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ir = jr; + ic = icol; + i__3 = -jkl - jku; + for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ir < *m) { + slartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &c__, & + s, &dummy); + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + temp = 0.f; + iltemp = jch > jku; + r__1 = -s; + slarot_(&c_false, &iltemp, &c_true, &il, &c__, & + r__1, &a[irow - iskew * ic + ioffst + ic * + a_dim1], &ilda, &temp, &extra); + if (iltemp) { + slartg_(&a[irow + 1 - iskew * (ic + 1) + + ioffst + (ic + 1) * a_dim1], &temp, & + c__, &s, &dummy); +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + extra = 0.f; + L__1 = jch > jku + jkl; + r__1 = -s; + slarot_(&c_true, &L__1, &c_true, &il, &c__, & + r__1, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, & + temp); + ic = icol; + ir = irow; + } +/* L120: */ + } +/* L130: */ + } +/* L140: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* Computing MIN */ + i__3 = *n + jkl; + i__2 = f2cmin(i__3,*m) + jku - 1; + for (jc = 1; jc <= i__2; ++jc) { + extra = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__4 = jc - jku; + irow = f2cmax(i__3,i__4); + if (jc < *n) { +/* Computing MIN */ + i__3 = *m, i__4 = jc + jkl; + il = f2cmin(i__3,i__4) + 1 - irow; + L__1 = jc > jku; + slarot_(&c_false, &L__1, &c_false, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ic = jc; + ir = irow; + i__3 = -jkl - jku; + for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ic < *n) { + slartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &c__, & + s, &dummy); + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + temp = 0.f; + iltemp = jch > jkl; + r__1 = -s; + slarot_(&c_true, &iltemp, &c_true, &il, &c__, & + r__1, &a[ir - iskew * icol + ioffst + + icol * a_dim1], &ilda, &temp, &extra); + if (iltemp) { + slartg_(&a[ir + 1 - iskew * (icol + 1) + + ioffst + (icol + 1) * a_dim1], &temp, + &c__, &s, &dummy); +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + extra = 0.f; + L__1 = jch > jkl + jku; + r__1 = -s; + slarot_(&c_false, &L__1, &c_true, &il, &c__, & + r__1, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, & + temp); + ic = icol; + ir = irow; + } +/* L150: */ + } +/* L160: */ + } +/* L170: */ + } + + } else { + +/* Bottom-Up -- Start at the bottom right. */ + + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* First row actually rotated is M */ +/* First column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n + jkl; + iendch = f2cmin(i__2,i__3) - 1; +/* Computing MIN */ + i__2 = *m + jku; + i__3 = 1 - jkl; + for (jc = f2cmin(i__2,*n) - 1; jc >= i__3; --jc) { + extra = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__2 = 1, i__4 = jc - jku + 1; + irow = f2cmax(i__2,i__4); + if (jc > 0) { +/* Computing MIN */ + i__2 = *m, i__4 = jc + jkl + 1; + il = f2cmin(i__2,i__4) + 1 - irow; + L__1 = jc + jkl < *m; + slarot_(&c_false, &c_false, &L__1, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ic = jc; + i__2 = iendch; + i__4 = jkl + jku; + for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <= + i__2; jch += i__4) { + ilextr = ic > 0; + if (ilextr) { + slartg_(&a[jch - iskew * ic + ioffst + ic * + a_dim1], &extra, &c__, &s, &dummy); + } + ic = f2cmax(1,ic); +/* Computing MIN */ + i__5 = *n - 1, i__6 = jch + jku; + icol = f2cmin(i__5,i__6); + iltemp = jch + jku < *n; + temp = 0.f; + i__5 = icol + 2 - ic; + slarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, & + s, &a[jch - iskew * ic + ioffst + ic * + a_dim1], &ilda, &extra, &temp); + if (iltemp) { + slartg_(&a[jch - iskew * icol + ioffst + icol + * a_dim1], &temp, &c__, &s, &dummy); +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra = 0.f; + L__1 = jch + jkl + jku <= iendch; + slarot_(&c_false, &c_true, &L__1, &il, &c__, & + s, &a[jch - iskew * icol + ioffst + + icol * a_dim1], &ilda, &temp, &extra); + ic = icol; + } +/* L180: */ + } +/* L190: */ + } +/* L200: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* First row actually rotated is MIN( N+JKL, M ) */ +/* First column actually rotated is N */ + +/* Computing MIN */ + i__3 = *n, i__4 = *m + jku; + iendch = f2cmin(i__3,i__4) - 1; +/* Computing MIN */ + i__3 = *n + jkl; + i__4 = 1 - jku; + for (jr = f2cmin(i__3,*m) - 1; jr >= i__4; --jr) { + extra = 0.f; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = sin(angle); +/* Computing MAX */ + i__3 = 1, i__2 = jr - jkl + 1; + icol = f2cmax(i__3,i__2); + if (jr > 0) { +/* Computing MIN */ + i__3 = *n, i__2 = jr + jku + 1; + il = f2cmin(i__3,i__2) + 1 - icol; + L__1 = jr + jku < *n; + slarot_(&c_true, &c_false, &L__1, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ir = jr; + i__3 = iendch; + i__2 = jkl + jku; + for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <= + i__3; jch += i__2) { + ilextr = ir > 0; + if (ilextr) { + slartg_(&a[ir - iskew * jch + ioffst + jch * + a_dim1], &extra, &c__, &s, &dummy); + } + ir = f2cmax(1,ir); +/* Computing MIN */ + i__5 = *m - 1, i__6 = jch + jkl; + irow = f2cmin(i__5,i__6); + iltemp = jch + jkl < *m; + temp = 0.f; + i__5 = irow + 2 - ir; + slarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, & + s, &a[ir - iskew * jch + ioffst + jch * + a_dim1], &ilda, &extra, &temp); + if (iltemp) { + slartg_(&a[irow - iskew * jch + ioffst + jch * + a_dim1], &temp, &c__, &s, &dummy); +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra = 0.f; + L__1 = jch + jkl + jku <= iendch; + slarot_(&c_true, &c_true, &L__1, &il, &c__, & + s, &a[irow - iskew * jch + ioffst + + jch * a_dim1], &ilda, &temp, &extra); + ir = irow; + } +/* L210: */ + } +/* L220: */ + } +/* L230: */ + } + } + + } else { + +/* Symmetric -- A = U D U' */ + + ipackg = ipack; + ioffg = ioffst; + + if (topdwn) { + +/* Top-Down -- Generate Upper triangle only */ + + if (ipack >= 5) { + ipackg = 6; + ioffg = uub + 1; + } else { + ipackg = 1; + } + i__1 = ilda + 1; + scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1], + &i__1); + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + i__4 = *n - 1; + for (jc = 1; jc <= i__4; ++jc) { +/* Computing MAX */ + i__2 = 1, i__3 = jc - k; + irow = f2cmax(i__2,i__3); +/* Computing MIN */ + i__2 = jc + 1, i__3 = k + 2; + il = f2cmin(i__2,i__3); + extra = 0.f; + temp = a[jc - iskew * (jc + 1) + ioffg + (jc + 1) * + a_dim1]; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = sin(angle); + L__1 = jc > k; + slarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[ + irow - iskew * jc + ioffg + jc * a_dim1], & + ilda, &extra, &temp); +/* Computing MIN */ + i__3 = k, i__5 = *n - jc; + i__2 = f2cmin(i__3,i__5) + 1; + slarot_(&c_true, &c_true, &c_false, &i__2, &c__, &s, & + a[(1 - iskew) * jc + ioffg + jc * a_dim1], & + ilda, &temp, &dummy); + +/* Chase EXTRA back up the matrix */ + + icol = jc; + i__2 = -k; + for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1; + jch += i__2) { + slartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg + + (icol + 1) * a_dim1], &extra, &c__, &s, & + dummy); + temp = a[jch - iskew * (jch + 1) + ioffg + (jch + + 1) * a_dim1]; + i__3 = k + 2; + r__1 = -s; + slarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + r__1, &a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &temp, &extra); +/* Computing MAX */ + i__3 = 1, i__5 = jch - k; + irow = f2cmax(i__3,i__5); +/* Computing MIN */ + i__3 = jch + 1, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra = 0.f; + L__1 = jch > k; + r__1 = -s; + slarot_(&c_false, &L__1, &c_true, &il, &c__, & + r__1, &a[irow - iskew * jch + ioffg + jch + * a_dim1], &ilda, &extra, &temp); + icol = jch; +/* L240: */ + } +/* L250: */ + } +/* L260: */ + } + +/* If we need lower triangle, copy from upper. Note that */ +/* the order of copying is chosen to work for 'q' -> 'b' */ + + if (ipack != ipackg && ipack != 3) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst - iskew * jc; +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + a[jr + irow + jc * a_dim1] = a[jc - iskew * jr + + ioffg + jr * a_dim1]; +/* L270: */ + } +/* L280: */ + } + if (ipack == 5) { + i__1 = *n; + for (jc = *n - uub + 1; jc <= i__1; ++jc) { + i__4 = uub + 1; + for (jr = *n + 2 - jc; jr <= i__4; ++jr) { + a[jr + jc * a_dim1] = 0.f; +/* L290: */ + } +/* L300: */ + } + } + if (ipackg == 6) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } else { + +/* Bottom-Up -- Generate Lower triangle only */ + + if (ipack >= 5) { + ipackg = 5; + if (ipack == 6) { + ioffg = 1; + } + } else { + ipackg = 2; + } + i__1 = ilda + 1; + scopy_(&mnmin, &d__[1], &c__1, &a[1 - iskew + ioffg + a_dim1], + &i__1); + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + for (jc = *n - 1; jc >= 1; --jc) { +/* Computing MIN */ + i__4 = *n + 1 - jc, i__2 = k + 2; + il = f2cmin(i__4,i__2); + extra = 0.f; + temp = a[(1 - iskew) * jc + 1 + ioffg + jc * a_dim1]; + angle = slarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663f; + c__ = cos(angle); + s = -sin(angle); + L__1 = *n - jc > k; + slarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[( + 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda, + &temp, &extra); +/* Computing MAX */ + i__4 = 1, i__2 = jc - k + 1; + icol = f2cmax(i__4,i__2); + i__4 = jc + 2 - icol; + slarot_(&c_true, &c_false, &c_true, &i__4, &c__, &s, & + a[jc - iskew * icol + ioffg + icol * a_dim1], + &ilda, &dummy, &temp); + +/* Chase EXTRA back down the matrix */ + + icol = jc; + i__4 = *n - 1; + i__2 = k; + for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <= + i__4; jch += i__2) { + slartg_(&a[jch - iskew * icol + ioffg + icol * + a_dim1], &extra, &c__, &s, &dummy); + temp = a[(1 - iskew) * jch + 1 + ioffg + jch * + a_dim1]; + i__3 = k + 2; + slarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[jch - iskew * icol + ioffg + icol * + a_dim1], &ilda, &extra, &temp); +/* Computing MIN */ + i__3 = *n + 1 - jch, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra = 0.f; + L__1 = *n - jch > k; + slarot_(&c_false, &c_true, &L__1, &il, &c__, &s, & + a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &temp, &extra); + icol = jch; +/* L310: */ + } +/* L320: */ + } +/* L330: */ + } + +/* If we need upper triangle, copy from lower. Note that */ +/* the order of copying is chosen to work for 'b' -> 'q' */ + + if (ipack != ipackg && ipack != 4) { + for (jc = *n; jc >= 1; --jc) { + irow = ioffst - iskew * jc; +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + a[jr + irow + jc * a_dim1] = a[jc - iskew * jr + + ioffg + jr * a_dim1]; +/* L340: */ + } +/* L350: */ + } + if (ipack == 6) { + i__1 = uub; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.f; +/* L360: */ + } +/* L370: */ + } + } + if (ipackg == 5) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } + } + + } else { + +/* 4) Generate Banded Matrix by first */ +/* Rotating by random Unitary matrices, */ +/* then reducing the bandwidth using Householder */ +/* transformations. */ + +/* Note: we should get here only if LDA .ge. N */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + slagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[ + 1], &work[1], &iinfo); + } else { + +/* Symmetric -- A = U D U' */ + + slagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[1], + &iinfo); + + } + if (iinfo != 0) { + *info = 3; + return 0; + } + } + +/* 5) Pack the matrix */ + + if (ipack != ipackg) { + if (ipack == 1) { + +/* 'U' -- Upper triangular, not packed */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.f; +/* L380: */ + } +/* L390: */ + } + + } else if (ipack == 2) { + +/* 'L' -- Lower triangular, not packed */ + + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = 0.f; +/* L400: */ + } +/* L410: */ + } + + } else if (ipack == 3) { + +/* 'C' -- Upper triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + a[irow + icol * a_dim1] = a[i__ + j * a_dim1]; +/* L420: */ + } +/* L430: */ + } + + } else if (ipack == 4) { + +/* 'R' -- Lower triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + a[irow + icol * a_dim1] = a[i__ + j * a_dim1]; +/* L440: */ + } +/* L450: */ + } + + } else if (ipack >= 5) { + +/* 'B' -- The lower triangle is packed as a band matrix. */ +/* 'Q' -- The upper triangle is packed as a band matrix. */ +/* 'Z' -- The whole matrix is packed as a band matrix. */ + + if (ipack == 5) { + uub = 0; + } + if (ipack == 6) { + llb = 0; + } + + i__1 = uub; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = j + llb; + for (i__ = f2cmin(i__2,*m); i__ >= 1; --i__) { + a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1]; +/* L460: */ + } +/* L470: */ + } + + i__1 = *n; + for (j = uub + 2; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = j + llb; + i__2 = f2cmin(i__4,*m); + for (i__ = j - uub; i__ <= i__2; ++i__) { + a[i__ - j + uub + 1 + j * a_dim1] = a[i__ + j * a_dim1]; +/* L480: */ + } +/* L490: */ + } + } + +/* If packed, zero out extraneous elements. */ + +/* Symmetric/Triangular Packed -- */ +/* zero out everything after A(IROW,ICOL) */ + + if (ipack == 3 || ipack == 4) { + i__1 = *m; + for (jc = icol; jc <= i__1; ++jc) { + i__2 = *lda; + for (jr = irow + 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.f; +/* L500: */ + } + irow = 0; +/* L510: */ + } + + } else if (ipack >= 5) { + +/* Packed Band -- */ +/* 1st row is now in A( UUB+2-j, j), zero above it */ +/* m-th row is now in A( M+UUB-j,j), zero below it */ +/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */ +/* zero below it, too. */ + + ir1 = uub + llb + 2; + ir2 = uub + *m + 2; + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + a[jr + jc * a_dim1] = 0.f; +/* L520: */ + } +/* Computing MAX */ +/* Computing MIN */ + i__3 = ir1, i__5 = ir2 - jc; + i__2 = 1, i__4 = f2cmin(i__3,i__5); + i__6 = *lda; + for (jr = f2cmax(i__2,i__4); jr <= i__6; ++jr) { + a[jr + jc * a_dim1] = 0.f; +/* L530: */ + } +/* L540: */ + } + } + } + + return 0; + +/* End of SLATMT */ + +} /* slatmt_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlagge.c b/lapack-netlib/TESTING/MATGEN/zlagge.c new file mode 100644 index 000000000..e4dc8f9be --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlagge.c @@ -0,0 +1,909 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLAGGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, KL, KU, LDA, M, N */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION D( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAGGE generates a complex general m by n matrix A, by pre- and post- */ +/* > multiplying a real diagonal matrix D with random unitary matrices: */ +/* > A = U*D*V. The lower and upper bandwidths may then be reduced to */ +/* > kl and ku by additional unitary transformations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of nonzero subdiagonals within the band of A. */ +/* > 0 <= KL <= M-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of nonzero superdiagonals within the band of A. */ +/* > 0 <= KU <= N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */ +/* > The diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The generated m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (M+N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlagge_(integer *m, integer *n, integer *kl, integer *ku, + doublereal *d__, doublecomplex *a, integer *lda, integer *iseed, + doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + doublecomplex wa, wb; + doublereal wn; + extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_( + integer *, doublecomplex *, integer *), zlarnv_(integer *, + integer *, integer *, doublecomplex *); + doublecomplex tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0 || *kl > *m - 1) { + *info = -3; + } else if (*ku < 0 || *ku > *n - 1) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -7; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("ZLAGGE", &i__1); + return 0; + } + +/* initialize A to diagonal matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + i__1 = f2cmin(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + i__3 = i__; + a[i__2].r = d__[i__3], a[i__2].i = 0.; +/* L30: */ + } + +/* Quick exit if the user wants a diagonal matrix */ + + if (*kl == 0 && *ku == 0) { + return 0; + } + +/* pre- and post-multiply A by random unitary matrices */ + + for (i__ = f2cmin(*m,*n); i__ >= 1; --i__) { + if (i__ < *m) { + +/* generate random reflection */ + + i__1 = *m - i__ + 1; + zlarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *m - i__ + 1; + wn = dznrm2_(&i__1, &work[1], &c__1); + d__1 = wn / z_abs(&work[1]); + z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__1 = *m - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__1, &z__1, &work[2], &c__1); + work[1].r = 1., work[1].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* multiply A(i:m,i:n) by random reflection from the left */ + + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + zgemv_("Conjugate transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * + a_dim1], lda, &work[1], &c__1, &c_b1, &work[*m + 1], & + c__1); + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&i__1, &i__2, &z__1, &work[1], &c__1, &work[*m + 1], &c__1, + &a[i__ + i__ * a_dim1], lda); + } + if (i__ < *n) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + zlarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = dznrm2_(&i__1, &work[1], &c__1); + d__1 = wn / z_abs(&work[1]); + z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__1 = *n - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__1, &z__1, &work[2], &c__1); + work[1].r = 1., work[1].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* multiply A(i:m,i:n) by random reflection from the right */ + + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + zgemv_("No transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * a_dim1] + , lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1); + i__1 = *m - i__ + 1; + i__2 = *n - i__ + 1; + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&i__1, &i__2, &z__1, &work[*n + 1], &c__1, &work[1], &c__1, + &a[i__ + i__ * a_dim1], lda); + } +/* L40: */ + } + +/* Reduce number of subdiagonals to KL and number of superdiagonals */ +/* to KU */ + +/* Computing MAX */ + i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku; + i__1 = f2cmax(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + if (*kl <= *ku) { + +/* annihilate subdiagonal elements first (necessary if KL = 0) */ + +/* Computing MIN */ + i__2 = *m - 1 - *kl; + if (i__ <= f2cmin(i__2,*n)) { + +/* generate reflection to annihilate A(kl+i+1:m,i) */ + + i__2 = *m - *kl - i__ + 1; + wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1); + d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]); + i__2 = *kl + i__ + i__ * a_dim1; + z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + i__2 = *kl + i__ + i__ * a_dim1; + z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__2 = *m - *kl - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], & + c__1); + i__2 = *kl + i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* apply reflection to A(kl+i:m,i+1:n) from the left */ + + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl + + i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * + a_dim1], &c__1, &c_b1, &work[1], &c__1); + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], & + c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * + a_dim1], lda); + i__2 = *kl + i__ + i__ * a_dim1; + z__1.r = -wa.r, z__1.i = -wa.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + +/* Computing MIN */ + i__2 = *n - 1 - *ku; + if (i__ <= f2cmin(i__2,*m)) { + +/* generate reflection to annihilate A(i,ku+i+1:n) */ + + i__2 = *n - *ku - i__ + 1; + wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]); + i__2 = i__ + (*ku + i__) * a_dim1; + z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + i__2 = i__ + (*ku + i__) * a_dim1; + z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__2 = *n - *ku - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1], + lda); + i__2 = i__ + (*ku + i__) * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* apply reflection to A(i+1:m,ku+i:n) from the right */ + + i__2 = *n - *ku - i__ + 1; + zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku + + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1], + lda, &c_b1, &work[1], &c__1); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku + + i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * + a_dim1], lda); + i__2 = i__ + (*ku + i__) * a_dim1; + z__1.r = -wa.r, z__1.i = -wa.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } else { + +/* annihilate superdiagonal elements first (necessary if */ +/* KU = 0) */ + +/* Computing MIN */ + i__2 = *n - 1 - *ku; + if (i__ <= f2cmin(i__2,*m)) { + +/* generate reflection to annihilate A(i,ku+i+1:n) */ + + i__2 = *n - *ku - i__ + 1; + wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]); + i__2 = i__ + (*ku + i__) * a_dim1; + z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + i__2 = i__ + (*ku + i__) * a_dim1; + z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__2 = *n - *ku - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1], + lda); + i__2 = i__ + (*ku + i__) * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* apply reflection to A(i+1:m,ku+i:n) from the right */ + + i__2 = *n - *ku - i__ + 1; + zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku + + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1], + lda, &c_b1, &work[1], &c__1); + i__2 = *m - i__; + i__3 = *n - *ku - i__ + 1; + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku + + i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * + a_dim1], lda); + i__2 = i__ + (*ku + i__) * a_dim1; + z__1.r = -wa.r, z__1.i = -wa.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + +/* Computing MIN */ + i__2 = *m - 1 - *kl; + if (i__ <= f2cmin(i__2,*n)) { + +/* generate reflection to annihilate A(kl+i+1:m,i) */ + + i__2 = *m - *kl - i__ + 1; + wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1); + d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]); + i__2 = *kl + i__ + i__ * a_dim1; + z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + i__2 = *kl + i__ + i__ * a_dim1; + z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__2 = *m - *kl - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], & + c__1); + i__2 = *kl + i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* apply reflection to A(kl+i:m,i+1:n) from the left */ + + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl + + i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * + a_dim1], &c__1, &c_b1, &work[1], &c__1); + i__2 = *m - *kl - i__ + 1; + i__3 = *n - i__; + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], & + c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * + a_dim1], lda); + i__2 = *kl + i__ + i__ * a_dim1; + z__1.r = -wa.r, z__1.i = -wa.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } + + if (i__ <= *n) { + i__2 = *m; + for (j = *kl + i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; +/* L50: */ + } + } + + if (i__ <= *m) { + i__2 = *n; + for (j = *ku + i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; +/* L60: */ + } + } +/* L70: */ + } + return 0; + +/* End of ZLAGGE */ + +} /* zlagge_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlaghe.c b/lapack-netlib/TESTING/MATGEN/zlaghe.c new file mode 100644 index 000000000..2f3d1fb0c --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlaghe.c @@ -0,0 +1,745 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLAGHE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, K, LDA, N */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION D( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAGHE generates a complex hermitian matrix A, by pre- and post- */ +/* > multiplying a real diagonal matrix D with a random unitary matrix: */ +/* > A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */ +/* > unitary transformations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of nonzero subdiagonals within the band of A. */ +/* > 0 <= K <= N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The generated n by n hermitian matrix A (the full matrix is */ +/* > stored). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlaghe_(integer *n, integer *k, doublereal *d__, + doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer i__, j; + doublecomplex alpha; + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), + zhemv_(char *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *), zaxpy_(integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *); + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + doublecomplex wa, wb; + doublereal wn; + extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_( + integer *, integer *, integer *, doublecomplex *); + doublecomplex tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*k < 0 || *k > *n - 1) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("ZLAGHE", &i__1); + return 0; + } + +/* initialize lower triangle of A to diagonal matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + i__3 = i__; + a[i__2].r = d__[i__3], a[i__2].i = 0.; +/* L30: */ + } + +/* Generate lower triangle of hermitian matrix */ + + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + zlarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = dznrm2_(&i__1, &work[1], &c__1); + d__1 = wn / z_abs(&work[1]); + z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__1 = *n - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__1, &z__1, &work[2], &c__1); + work[1].r = 1., work[1].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* apply random reflection to A(i:n,i:n) from the left */ +/* and the right */ + +/* compute y := tau * A * u */ + + i__1 = *n - i__ + 1; + zhemv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], & + c__1, &c_b1, &work[*n + 1], &c__1); + +/* compute v := y - 1/2 * tau * ( y, u ) * u */ + + z__3.r = -.5, z__3.i = 0.; + z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + + z__3.i * tau.r; + i__1 = *n - i__ + 1; + zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i + + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = *n - i__ + 1; + zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1); + +/* apply the transformation as a rank-2 update to A(i:n,i:n) */ + + i__1 = *n - i__ + 1; + z__1.r = -1., z__1.i = 0.; + zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, & + a[i__ + i__ * a_dim1], lda); +/* L40: */ + } + +/* Reduce number of subdiagonals to K */ + + i__1 = *n - 1 - *k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* generate reflection to annihilate A(k+i+1:n,i) */ + + i__2 = *n - *k - i__ + 1; + wn = dznrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); + d__1 = wn / z_abs(&a[*k + i__ + i__ * a_dim1]); + i__2 = *k + i__ + i__ * a_dim1; + z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + i__2 = *k + i__ + i__ * a_dim1; + z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__2 = *n - *k - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__2, &z__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1); + i__2 = *k + i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */ + + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__ + + 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, & + c_b1, &work[1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&i__2, &i__3, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[ + 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda); + +/* apply reflection to A(k+i:n,k+i:n) from the left and the right */ + +/* compute y := tau * A * u */ + + i__2 = *n - *k - i__ + 1; + zhemv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, + &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1); + +/* compute v := y - 1/2 * tau * ( y, u ) * u */ + + z__3.r = -.5, z__3.i = 0.; + z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + + z__3.i * tau.r; + i__2 = *n - *k - i__ + 1; + zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i__ + i__ * a_dim1], & + c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i + + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__2 = *n - *k - i__ + 1; + zaxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & + c__1); + +/* apply hermitian rank-2 update to A(k+i:n,k+i:n) */ + + i__2 = *n - *k - i__ + 1; + z__1.r = -1., z__1.i = 0.; + zher2_("Lower", &i__2, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, & + work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda); + + i__2 = *k + i__ + i__ * a_dim1; + z__1.r = -wa.r, z__1.i = -wa.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = *n; + for (j = *k + i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; +/* L50: */ + } +/* L60: */ + } + +/* Store full hermitian matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + d_cnjg(&z__1, &a[i__ + j * a_dim1]); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L70: */ + } +/* L80: */ + } + return 0; + +/* End of ZLAGHE */ + +} /* zlaghe_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlagsy.c b/lapack-netlib/TESTING/MATGEN/zlagsy.c new file mode 100644 index 000000000..97272220a --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlagsy.c @@ -0,0 +1,796 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLAGSY */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, K, LDA, N */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION D( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAGSY generates a complex symmetric matrix A, by pre- and post- */ +/* > multiplying a real diagonal matrix D with a random unitary matrix: */ +/* > A = U*D*U**T. The semi-bandwidth may then be reduced to k by */ +/* > additional unitary transformations. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of nonzero subdiagonals within the band of A. */ +/* > 0 <= K <= N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The generated n by n symmetric matrix A (the full matrix is */ +/* > stored). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlagsy_(integer *n, integer *k, doublereal *d__, + doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, + i__9; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + integer i__, j; + doublecomplex alpha; + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), + zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *), zsymv_(char *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + integer ii, jj; + doublecomplex wa, wb; + doublereal wn; + extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_( + integer *, doublecomplex *, integer *), zlarnv_(integer *, + integer *, integer *, doublecomplex *); + doublecomplex tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*k < 0 || *k > *n - 1) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("ZLAGSY", &i__1); + return 0; + } + +/* initialize lower triangle of A to diagonal matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + i__3 = i__; + a[i__2].r = d__[i__3], a[i__2].i = 0.; +/* L30: */ + } + +/* Generate lower triangle of symmetric matrix */ + + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + zlarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = dznrm2_(&i__1, &work[1], &c__1); + d__1 = wn / z_abs(&work[1]); + z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__1 = *n - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__1, &z__1, &work[2], &c__1); + work[1].r = 1., work[1].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* apply random reflection to A(i:n,i:n) from the left */ +/* and the right */ + +/* compute y := tau * A * conjg(u) */ + + i__1 = *n - i__ + 1; + zlacgv_(&i__1, &work[1], &c__1); + i__1 = *n - i__ + 1; + zsymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], & + c__1, &c_b1, &work[*n + 1], &c__1); + i__1 = *n - i__ + 1; + zlacgv_(&i__1, &work[1], &c__1); + +/* compute v := y - 1/2 * tau * ( u, y ) * u */ + + z__3.r = -.5, z__3.i = 0.; + z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + + z__3.i * tau.r; + i__1 = *n - i__ + 1; + zdotc_(&z__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i + + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = *n - i__ + 1; + zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1); + +/* apply the transformation as a rank-2 update to A(i:n,i:n) */ + +/* CALL ZSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, */ +/* $ A( I, I ), LDA ) */ + + i__1 = *n; + for (jj = i__; jj <= i__1; ++jj) { + i__2 = *n; + for (ii = jj; ii <= i__2; ++ii) { + i__3 = ii + jj * a_dim1; + i__4 = ii + jj * a_dim1; + i__5 = ii - i__ + 1; + i__6 = *n + jj - i__ + 1; + z__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[ + i__6].i, z__3.i = work[i__5].r * work[i__6].i + work[ + i__5].i * work[i__6].r; + z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i - z__3.i; + i__7 = *n + ii - i__ + 1; + i__8 = jj - i__ + 1; + z__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[ + i__8].i, z__4.i = work[i__7].r * work[i__8].i + work[ + i__7].i * work[i__8].r; + z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L40: */ + } +/* L50: */ + } +/* L60: */ + } + +/* Reduce number of subdiagonals to K */ + + i__1 = *n - 1 - *k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* generate reflection to annihilate A(k+i+1:n,i) */ + + i__2 = *n - *k - i__ + 1; + wn = dznrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); + d__1 = wn / z_abs(&a[*k + i__ + i__ * a_dim1]); + i__2 = *k + i__ + i__ * a_dim1; + z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + i__2 = *k + i__ + i__ * a_dim1; + z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__2 = *n - *k - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__2, &z__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1); + i__2 = *k + i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* apply reflection to A(k+i:n,i+1:k+i-1) from the left */ + + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__ + + 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, & + c_b1, &work[1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = *k - 1; + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&i__2, &i__3, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[ + 1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda); + +/* apply reflection to A(k+i:n,k+i:n) from the left and the right */ + +/* compute y := tau * A * conjg(u) */ + + i__2 = *n - *k - i__ + 1; + zlacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); + i__2 = *n - *k - i__ + 1; + zsymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, + &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1); + i__2 = *n - *k - i__ + 1; + zlacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1); + +/* compute v := y - 1/2 * tau * ( u, y ) * u */ + + z__3.r = -.5, z__3.i = 0.; + z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + + z__3.i * tau.r; + i__2 = *n - *k - i__ + 1; + zdotc_(&z__4, &i__2, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & + c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i + + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__2 = *n - *k - i__ + 1; + zaxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], & + c__1); + +/* apply symmetric rank-2 update to A(k+i:n,k+i:n) */ + +/* CALL ZSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, */ +/* $ A( K+I, K+I ), LDA ) */ + + i__2 = *n; + for (jj = *k + i__; jj <= i__2; ++jj) { + i__3 = *n; + for (ii = jj; ii <= i__3; ++ii) { + i__4 = ii + jj * a_dim1; + i__5 = ii + jj * a_dim1; + i__6 = ii + i__ * a_dim1; + i__7 = jj - *k - i__ + 1; + z__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i, + z__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[ + i__7].r; + z__2.r = a[i__5].r - z__3.r, z__2.i = a[i__5].i - z__3.i; + i__8 = ii - *k - i__ + 1; + i__9 = jj + i__ * a_dim1; + z__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i, + z__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[ + i__9].r; + z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i; + a[i__4].r = z__1.r, a[i__4].i = z__1.i; +/* L70: */ + } +/* L80: */ + } + + i__2 = *k + i__ + i__ * a_dim1; + z__1.r = -wa.r, z__1.i = -wa.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = *n; + for (j = *k + i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; +/* L90: */ + } +/* L100: */ + } + +/* Store full symmetric matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + i__4 = i__ + j * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; +/* L110: */ + } +/* L120: */ + } + return 0; + +/* End of ZLAGSY */ + +} /* zlagsy_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlahilb.c b/lapack-netlib/TESTING/MATGEN/zlahilb.c new file mode 100644 index 000000000..22b0982d8 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlahilb.c @@ -0,0 +1,711 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLAHILB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, */ +/* INFO, PATH) */ + +/* INTEGER N, NRHS, LDA, LDX, LDB, INFO */ +/* DOUBLE PRECISION WORK(N) */ +/* COMPLEX*16 A(LDA,N), X(LDX, NRHS), B(LDB, NRHS) */ +/* CHARACTER*3 PATH */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAHILB generates an N by N scaled Hilbert matrix in A along with */ +/* > NRHS right-hand sides in B and solutions in X such that A*X=B. */ +/* > */ +/* > The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */ +/* > entries are integers. The right-hand sides are the first NRHS */ +/* > columns of M * the identity matrix, and the solutions are the */ +/* > first NRHS columns of the inverse Hilbert matrix. */ +/* > */ +/* > The condition number of the Hilbert matrix grows exponentially with */ +/* > its size, roughly as O(e ** (3.5*N)). Additionally, the inverse */ +/* > Hilbert matrices beyond a relatively small dimension cannot be */ +/* > generated exactly without extra precision. Precision is exhausted */ +/* > when the largest entry in the inverse Hilbert matrix is greater than */ +/* > 2 to the power of the number of bits in the fraction of the data type */ +/* > used plus one, which is 24 for single precision. */ +/* > */ +/* > In single, the generated solution is exact for N <= 6 and has */ +/* > small componentwise error for 7 <= N <= 11. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The requested number of right-hand sides. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA, N) */ +/* > The generated scaled Hilbert matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX array, dimension (LDX, NRHS) */ +/* > The generated exact solutions. Currently, the first NRHS */ +/* > columns of the inverse Hilbert matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB, NRHS) */ +/* > The generated right-hand sides. Currently, the first NRHS */ +/* > columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > = 1: N is too large; the data is still generated but may not */ +/* > be not exact. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PATH */ +/* > \verbatim */ +/* > PATH is CHARACTER*3 */ +/* > The LAPACK path name. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlahilb_(integer *n, integer *nrhs, doublecomplex *a, + integer *lda, doublecomplex *x, integer *ldx, doublecomplex *b, + integer *ldb, doublereal *work, integer *info, char *path) +{ + /* Initialized data */ + + static doublecomplex d1[8] = { {-1.,0.},{0.,1.},{-1.,-1.},{0.,-1.},{1.,0.} + ,{-1.,1.},{1.,1.},{1.,-1.} }; + static doublecomplex d2[8] = { {-1.,0.},{0.,-1.},{-1.,1.},{0.,1.},{1.,0.}, + {-1.,-1.},{1.,-1.},{1.,1.} }; + static doublecomplex invd1[8] = { {-1.,0.},{0.,-1.},{-.5,.5},{0.,1.},{1., + 0.},{-.5,-.5},{.5,-.5},{.5,.5} }; + static doublecomplex invd2[8] = { {-1.,0.},{0.,1.},{-.5,-.5},{0.,-1.},{1., + 0.},{-.5,.5},{.5,.5},{.5,-.5} }; + + /* System generated locals */ + integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2, + i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Local variables */ + integer i__, j, m, r__; + char c2[2]; + integer ti, tm; + extern /* Subroutine */ int xerbla_(char *, integer *); + extern logical lsamen_(integer *, char *, char *); + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + doublecomplex tmp; + + +/* -- LAPACK test routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ +/* NMAX_EXACT the largest dimension where the generated data is */ +/* exact. */ +/* NMAX_APPROX the largest dimension where the generated data has */ +/* a small componentwise relative error. */ +/* ??? complex uses how many bits ??? */ + +/* d's are generated from random permutation of those eight elements. */ + /* Parameter adjustments */ + --work; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2); + +/* Test the input arguments */ + + *info = 0; + if (*n < 0 || *n > 11) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*lda < *n) { + *info = -4; + } else if (*ldx < *n) { + *info = -6; + } else if (*ldb < *n) { + *info = -8; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("ZLAHILB", &i__1); + return 0; + } + if (*n > 6) { + *info = 1; + } + +/* Compute M = the LCM of the integers [1, 2*N-1]. The largest */ +/* reasonable N is small enough that integers suffice (up to N = 11). */ + m = 1; + i__1 = (*n << 1) - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + tm = m; + ti = i__; + r__ = tm % ti; + while(r__ != 0) { + tm = ti; + ti = r__; + r__ = tm % ti; + } + m = m / ti * i__; + } + +/* Generate the scaled Hilbert matrix in A */ +/* If we are testing SY routines, */ +/* take D1_i = D2_i, else, D1_i = D2_i* */ + if (lsamen_(&c__2, c2, "SY")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = j % 8; + d__1 = (doublereal) m / (i__ + j - 1); + z__2.r = d__1 * d1[i__4].r, z__2.i = d__1 * d1[i__4].i; + i__5 = i__ % 8; + z__1.r = z__2.r * d1[i__5].r - z__2.i * d1[i__5].i, z__1.i = + z__2.r * d1[i__5].i + z__2.i * d1[i__5].r; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = j % 8; + d__1 = (doublereal) m / (i__ + j - 1); + z__2.r = d__1 * d1[i__4].r, z__2.i = d__1 * d1[i__4].i; + i__5 = i__ % 8; + z__1.r = z__2.r * d2[i__5].r - z__2.i * d2[i__5].i, z__1.i = + z__2.r * d2[i__5].i + z__2.i * d2[i__5].r; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + } + +/* Generate matrix B as simply the first NRHS columns of M * the */ +/* identity. */ + d__1 = (doublereal) m; + tmp.r = d__1, tmp.i = 0.; + zlaset_("Full", n, nrhs, &c_b6, &tmp, &b[b_offset], ldb); + +/* Generate the true solutions in X. Because B = the first NRHS */ +/* columns of M*I, the true solutions are just the first NRHS columns */ +/* of the inverse Hilbert matrix. */ + work[1] = (doublereal) (*n); + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j - + 1); + } +/* If we are testing SY routines, */ +/* take D1_i = D2_i, else, D1_i = D2_i* */ + if (lsamen_(&c__2, c2, "SY")) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * x_dim1; + i__4 = j % 8; + d__1 = work[i__] * work[j] / (i__ + j - 1); + z__2.r = d__1 * invd1[i__4].r, z__2.i = d__1 * invd1[i__4].i; + i__5 = i__ % 8; + z__1.r = z__2.r * invd1[i__5].r - z__2.i * invd1[i__5].i, + z__1.i = z__2.r * invd1[i__5].i + z__2.i * invd1[i__5] + .r; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } + } + } else { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * x_dim1; + i__4 = j % 8; + d__1 = work[i__] * work[j] / (i__ + j - 1); + z__2.r = d__1 * invd2[i__4].r, z__2.i = d__1 * invd2[i__4].i; + i__5 = i__ % 8; + z__1.r = z__2.r * invd1[i__5].r - z__2.i * invd1[i__5].i, + z__1.i = z__2.r * invd1[i__5].i + z__2.i * invd1[i__5] + .r; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } + } + } + return 0; +} /* zlahilb_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlahilb.f b/lapack-netlib/TESTING/MATGEN/zlahilb.f index e5a317821..cb774abd9 100644 --- a/lapack-netlib/TESTING/MATGEN/zlahilb.f +++ b/lapack-netlib/TESTING/MATGEN/zlahilb.f @@ -166,13 +166,6 @@ * * d's are generated from random permutation of those eight elements. COMPLEX*16 d1(8), d2(8), invd1(8), invd2(8) - DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/ - DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ - - DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0), - $ (-.5,-.5),(.5,-.5),(.5,.5)/ - DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0), - $ (-.5,.5),(.5,.5),(.5,-.5)/ * .. * .. External Subroutines .. EXTERNAL XERBLA @@ -181,6 +174,14 @@ EXTERNAL ZLASET, LSAMEN INTRINSIC DBLE LOGICAL LSAMEN + + DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/ + DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ + + DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0), + $ (-.5,-.5),(.5,-.5),(.5,.5)/ + DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0), + $ (-.5,.5),(.5,.5),(.5,-.5)/ * .. * .. Executable Statements .. C2 = PATH( 2: 3 ) diff --git a/lapack-netlib/TESTING/MATGEN/zlakf2.c b/lapack-netlib/TESTING/MATGEN/zlakf2.c new file mode 100644 index 000000000..107aeea15 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlakf2.c @@ -0,0 +1,622 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLAKF2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) */ + +/* INTEGER LDA, LDZ, M, N */ +/* COMPLEX*16 A( LDA, * ), B( LDA, * ), D( LDA, * ), */ +/* $ E( LDA, * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Form the 2*M*N by 2*M*N matrix */ +/* > */ +/* > Z = [ kron(In, A) -kron(B', Im) ] */ +/* > [ kron(In, D) -kron(E', Im) ], */ +/* > */ +/* > where In is the identity matrix of size n and X' is the transpose */ +/* > of X. kron(X, Y) is the Kronecker product between the matrices X */ +/* > and Y. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Size of matrix, must be >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Size of matrix, must be >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16, dimension ( LDA, M ) */ +/* > The matrix A in the output matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A, B, D, and E. ( LDA >= M+N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX*16, dimension ( LDA, N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is COMPLEX*16, dimension ( LDA, M ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX*16, dimension ( LDA, N ) */ +/* > */ +/* > The matrices used in forming the output matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16, dimension ( LDZ, 2*M*N ) */ +/* > The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of Z. ( LDZ >= 2*M*N ) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlakf2_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *b, doublecomplex *d__, doublecomplex *e, + doublecomplex *z__, integer *ldz) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1, + e_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1; + + /* Local variables */ + integer i__, j, l, ik, jk, mn; + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + integer mn2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ==================================================================== */ + + +/* Initialize Z */ + + /* Parameter adjustments */ + e_dim1 = *lda; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + d_dim1 = *lda; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + b_dim1 = *lda; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + + /* Function Body */ + mn = *m * *n; + mn2 = mn << 1; + zlaset_("Full", &mn2, &mn2, &c_b1, &c_b1, &z__[z_offset], ldz); + + ik = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + +/* form kron(In, A) */ + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m; + for (j = 1; j <= i__3; ++j) { + i__4 = ik + i__ - 1 + (ik + j - 1) * z_dim1; + i__5 = i__ + j * a_dim1; + z__[i__4].r = a[i__5].r, z__[i__4].i = a[i__5].i; +/* L10: */ + } +/* L20: */ + } + +/* form kron(In, D) */ + + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m; + for (j = 1; j <= i__3; ++j) { + i__4 = ik + mn + i__ - 1 + (ik + j - 1) * z_dim1; + i__5 = i__ + j * d_dim1; + z__[i__4].r = d__[i__5].r, z__[i__4].i = d__[i__5].i; +/* L30: */ + } +/* L40: */ + } + + ik += *m; +/* L50: */ + } + + ik = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + jk = mn + 1; + + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + +/* form -kron(B', Im) */ + + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = ik + i__ - 1 + (jk + i__ - 1) * z_dim1; + i__5 = j + l * b_dim1; + z__1.r = -b[i__5].r, z__1.i = -b[i__5].i; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; +/* L60: */ + } + +/* form -kron(E', Im) */ + + i__3 = *m; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1; + i__5 = j + l * e_dim1; + z__1.r = -e[i__5].r, z__1.i = -e[i__5].i; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; +/* L70: */ + } + + jk += *m; +/* L80: */ + } + + ik += *m; +/* L90: */ + } + + return 0; + +/* End of ZLAKF2 */ + +} /* zlakf2_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlarge.c b/lapack-netlib/TESTING/MATGEN/zlarge.c new file mode 100644 index 000000000..0c477a814 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlarge.c @@ -0,0 +1,587 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLARGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARGE( N, A, LDA, ISEED, WORK, INFO ) */ + +/* INTEGER INFO, LDA, N */ +/* INTEGER ISEED( 4 ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARGE pre- and post-multiplies a complex general n by n matrix A */ +/* > with a random unitary matrix: A = U*D*U'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the original n by n matrix A. */ +/* > On exit, A is overwritten by U*A*U' for some random */ +/* > unitary matrix U. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlarge_(integer *n, doublecomplex *a, integer *lda, + integer *iseed, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + doublecomplex wa, wb; + doublereal wn; + extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_( + integer *, integer *, integer *, doublecomplex *); + doublecomplex tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*lda < f2cmax(1,*n)) { + *info = -3; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("ZLARGE", &i__1); + return 0; + } + +/* pre- and post-multiply A by random unitary matrix */ + + for (i__ = *n; i__ >= 1; --i__) { + +/* generate random reflection */ + + i__1 = *n - i__ + 1; + zlarnv_(&c__3, &iseed[1], &i__1, &work[1]); + i__1 = *n - i__ + 1; + wn = dznrm2_(&i__1, &work[1], &c__1); + d__1 = wn / z_abs(&work[1]); + z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i; + wa.r = z__1.r, wa.i = z__1.i; + if (wn == 0.) { + tau.r = 0., tau.i = 0.; + } else { + z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i; + wb.r = z__1.r, wb.i = z__1.i; + i__1 = *n - i__; + z_div(&z__1, &c_b2, &wb); + zscal_(&i__1, &z__1, &work[2], &c__1); + work[1].r = 1., work[1].i = 0.; + z_div(&z__1, &wb, &wa); + d__1 = z__1.r; + tau.r = d__1, tau.i = 0.; + } + +/* multiply A(i:n,1:n) by random reflection from the left */ + + i__1 = *n - i__ + 1; + zgemv_("Conjugate transpose", &i__1, n, &c_b2, &a[i__ + a_dim1], lda, + &work[1], &c__1, &c_b1, &work[*n + 1], &c__1); + i__1 = *n - i__ + 1; + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&i__1, n, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__ + + a_dim1], lda); + +/* multiply A(1:n,i:n) by random reflection from the right */ + + i__1 = *n - i__ + 1; + zgemv_("No transpose", n, &i__1, &c_b2, &a[i__ * a_dim1 + 1], lda, & + work[1], &c__1, &c_b1, &work[*n + 1], &c__1); + i__1 = *n - i__ + 1; + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(n, &i__1, &z__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ + * a_dim1 + 1], lda); +/* L10: */ + } + return 0; + +/* End of ZLARGE */ + +} /* zlarge_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlarnd.c b/lapack-netlib/TESTING/MATGEN/zlarnd.c new file mode 100644 index 000000000..c2cb46603 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlarnd.c @@ -0,0 +1,542 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLARND */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* COMPLEX*16 FUNCTION ZLARND( IDIST, ISEED ) */ + +/* INTEGER IDIST */ +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARND returns a random complex number from a uniform or normal */ +/* > distribution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > Specifies the distribution of the random numbers: */ +/* > = 1: real and imaginary parts each uniform (0,1) */ +/* > = 2: real and imaginary parts each uniform (-1,1) */ +/* > = 3: real and imaginary parts each normal (0,1) */ +/* > = 4: uniformly distributed on the disc abs(z) <= 1 */ +/* > = 5: uniformly distributed on the circle abs(z) = 1 */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine calls the auxiliary routine DLARAN to generate a random */ +/* > real number from a uniform (0,1) distribution. The Box-Muller method */ +/* > is used to transform numbers from a uniform to a normal distribution. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +// VOID zlarnd_(doublecomplex * ret_val, integer *idist, integer *iseed) + +doublecomplex zlarnd_(integer *idist, + integer *iseed) +{ + /* System generated locals */ + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3; + doublecomplex *ret_val =(doublecomplex*)malloc(sizeof(doublecomplex)); + /* Local variables */ + doublereal t1, t2; + extern doublereal dlaran_(integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Generate a pair of real random numbers from a uniform (0,1) */ +/* distribution */ + + /* Parameter adjustments */ + --iseed; +//fprintf(stderr,"iseed %d %d %d %d\n", iseed[1], iseed[2], iseed[3],iseed[4]); + /* Function Body */ + t1 = dlaran_(&iseed[1]); + t2 = dlaran_(&iseed[1]); + + if (*idist == 1) { + +/* real and imaginary parts each uniform (0,1) */ + + z__1.r = t1, z__1.i = t2; + ret_val->r = z__1.r, ret_val->i = z__1.i; + } else if (*idist == 2) { + +/* real and imaginary parts each uniform (-1,1) */ + + d__1 = t1 * 2. - 1.; + d__2 = t2 * 2. - 1.; + z__1.r = d__1, z__1.i = d__2; + ret_val->r = z__1.r, ret_val->i = z__1.i; + } else if (*idist == 3) { + +/* real and imaginary parts each normal (0,1) */ + + d__1 = sqrt(log(t1) * -2.); + d__2 = t2 * 6.2831853071795864769252867663; + z__3.r = 0., z__3.i = d__2; + z_exp(&z__2, &z__3); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + ret_val->r = z__1.r, ret_val->i = z__1.i; + } else if (*idist == 4) { + +/* uniform distribution on the unit disc abs(z) <= 1 */ + + d__1 = sqrt(t1); + d__2 = t2 * 6.2831853071795864769252867663; + z__3.r = 0., z__3.i = d__2; + z_exp(&z__2, &z__3); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + ret_val->r = z__1.r, ret_val->i = z__1.i; + } else if (*idist == 5) { + +/* uniform distribution on the unit circle abs(z) = 1 */ + + d__1 = t2 * 6.2831853071795864769252867663; + z__2.r = 0., z__2.i = d__1; + z_exp(&z__1, &z__2); + ret_val->r = z__1.r, ret_val->i = z__1.i; + } +// fprintf(stderr,"zlarnd returning %f %f\n",ret_val->r, ret_val->i); + return *ret_val; + +/* End of ZLARND */ + +} /* zlarnd_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlaror.c b/lapack-netlib/TESTING/MATGEN/zlaror.c new file mode 100644 index 000000000..816a68828 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlaror.c @@ -0,0 +1,788 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLAROR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) */ + +/* CHARACTER INIT, SIDE */ +/* INTEGER INFO, LDA, M, N */ +/* INTEGER ISEED( 4 ) */ +/* COMPLEX*16 A( LDA, * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAROR pre- or post-multiplies an M by N matrix A by a random */ +/* > unitary matrix U, overwriting A. A may optionally be */ +/* > initialized to the identity matrix before multiplying by U. */ +/* > U is generated using the method of G.W. Stewart */ +/* > ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ). */ +/* > (BLAS-2 version) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > SIDE specifies whether A is multiplied on the left or right */ +/* > by U. */ +/* > SIDE = 'L' Multiply A on the left (premultiply) by U */ +/* > SIDE = 'R' Multiply A on the right (postmultiply) by UC> SIDE = 'C' Multiply A on the lef +t by U and the right by UC> SIDE = 'T' Multiply A on the left by U and the right by U' */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INIT */ +/* > \verbatim */ +/* > INIT is CHARACTER*1 */ +/* > INIT specifies whether or not A should be initialized to */ +/* > the identity matrix. */ +/* > INIT = 'I' Initialize A to (a section of) the */ +/* > identity matrix before applying U. */ +/* > INIT = 'N' No initialization. Apply U to the */ +/* > input matrix A. */ +/* > */ +/* > INIT = 'I' may be used to generate square (i.e., unitary) */ +/* > or rectangular orthogonal matrices (orthogonality being */ +/* > in the sense of ZDOTC): */ +/* > */ +/* > For square matrices, M=N, and SIDE many be either 'L' or */ +/* > 'R'; the rows will be orthogonal to each other, as will the */ +/* > columns. */ +/* > For rectangular matrices where M < N, SIDE = 'R' will */ +/* > produce a dense matrix whose rows will be orthogonal and */ +/* > whose columns will not, while SIDE = 'L' will produce a */ +/* > matrix whose rows will be orthogonal, and whose first M */ +/* > columns will be orthogonal, the remaining columns being */ +/* > zero. */ +/* > For matrices where M > N, just use the previous */ +/* > explanation, interchanging 'L' and 'R' and "rows" and */ +/* > "columns". */ +/* > */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension ( LDA, N ) */ +/* > Input and output array. Overwritten by U A ( if SIDE = 'L' ) */ +/* > or by A U ( if SIDE = 'R' ) */ +/* > or by U A U* ( if SIDE = 'C') */ +/* > or by U A U' ( if SIDE = 'T') on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > Leading dimension of A. Must be at least MAX ( 1, M ). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. The array elements should be between 0 and 4095; */ +/* > if not they will be reduced mod 4096. Also, ISEED(4) must */ +/* > be odd. The random number generator uses a linear */ +/* > congruential sequence limited to small integers, and so */ +/* > should produce machine independent random numbers. The */ +/* > values of ISEED are changed on exit, and can be used in the */ +/* > next call to ZLAROR to continue the same random number */ +/* > sequence. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension ( 3*MAX( M, N ) ) */ +/* > Workspace. Of length: */ +/* > 2*M + N if SIDE = 'L', */ +/* > 2*N + M if SIDE = 'R', */ +/* > 3*N if SIDE = 'C' or 'T'. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > An error flag. It is set to: */ +/* > 0 if no error. */ +/* > 1 if ZLARND returned a bad random number (installation */ +/* > problem) */ +/* > -1 if SIDE is not L, R, C, or T. */ +/* > -3 if M is negative. */ +/* > -4 if N is negative or if SIDE is C or T and N is not equal */ +/* > to M. */ +/* > -6 if LDA is less than M. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlaror_(char *side, char *init, integer *m, integer *n, + doublecomplex *a, integer *lda, integer *iseed, doublecomplex *x, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublecomplex z__1, z__2; + + /* Local variables */ + integer kbeg, jcol; + doublereal xabs; + integer irow, j; + extern logical lsame_(char *, char *); + doublecomplex csign; + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + integer ixfrm; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer itype, nxfrm; + doublereal xnorm; + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *); + doublereal factor; + extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *) + ; + //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, + extern doublecomplex zlarnd_(integer *, + integer *); + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + doublecomplex xnorms; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iseed; + --x; + + /* Function Body */ + *info = 0; + if (*n == 0 || *m == 0) { + return 0; + } + + itype = 0; + if (lsame_(side, "L")) { + itype = 1; + } else if (lsame_(side, "R")) { + itype = 2; + } else if (lsame_(side, "C")) { + itype = 3; + } else if (lsame_(side, "T")) { + itype = 4; + } + +/* Check for argument errors. */ + + if (itype == 0) { + *info = -1; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0 || itype == 3 && *n != *m) { + *info = -4; + } else if (*lda < *m) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAROR", &i__1); + return 0; + } + + if (itype == 1) { + nxfrm = *m; + } else { + nxfrm = *n; + } + +/* Initialize A to the identity matrix if desired */ + + if (lsame_(init, "I")) { + zlaset_("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda); + } + +/* If no rotation possible, still multiply by */ +/* a random complex number from the circle |x| = 1 */ + +/* 2) Compute Rotation by computing Householder */ +/* Transformations H(2), H(3), ..., H(n). Note that the */ +/* order in which they are computed is irrelevant. */ + + i__1 = nxfrm; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + x[i__2].r = 0., x[i__2].i = 0.; +/* L10: */ + } + + i__1 = nxfrm; + for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) { + kbeg = nxfrm - ixfrm + 1; + +/* Generate independent normal( 0, 1 ) random numbers */ + + i__2 = nxfrm; + for (j = kbeg; j <= i__2; ++j) { + i__3 = j; + //zlarnd_(&z__1, &c__3, &iseed[1]); + z__1=zlarnd_(&c__3, &iseed[1]); + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L20: */ + } + +/* Generate a Householder transformation from the random vector X */ + + xnorm = dznrm2_(&ixfrm, &x[kbeg], &c__1); + xabs = z_abs(&x[kbeg]); + if (xabs != 0.) { + i__2 = kbeg; + z__1.r = x[i__2].r / xabs, z__1.i = x[i__2].i / xabs; + csign.r = z__1.r, csign.i = z__1.i; + } else { + csign.r = 1., csign.i = 0.; + } + z__1.r = xnorm * csign.r, z__1.i = xnorm * csign.i; + xnorms.r = z__1.r, xnorms.i = z__1.i; + i__2 = nxfrm + kbeg; + z__1.r = -csign.r, z__1.i = -csign.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + factor = xnorm * (xnorm + xabs); + if (abs(factor) < 1e-20) { + *info = 1; + i__2 = -(*info); + xerbla_("ZLAROR", &i__2); + return 0; + } else { + factor = 1. / factor; + } + i__2 = kbeg; + i__3 = kbeg; + z__1.r = x[i__3].r + xnorms.r, z__1.i = x[i__3].i + xnorms.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + +/* Apply Householder transformation to A */ + + if (itype == 1 || itype == 3 || itype == 4) { + +/* Apply H(k) on the left of A */ + + zgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], & + c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1); + z__2.r = factor, z__2.i = 0.; + z__1.r = -z__2.r, z__1.i = -z__2.i; + zgerc_(&ixfrm, n, &z__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], & + c__1, &a[kbeg + a_dim1], lda); + + } + + if (itype >= 2 && itype <= 4) { + +/* Apply H(k)* (or H(k)') on the right of A */ + + if (itype == 4) { + zlacgv_(&ixfrm, &x[kbeg], &c__1); + } + + zgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg] + , &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1); + z__2.r = factor, z__2.i = 0.; + z__1.r = -z__2.r, z__1.i = -z__2.i; + zgerc_(m, &ixfrm, &z__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], & + c__1, &a[kbeg * a_dim1 + 1], lda); + + } +/* L30: */ + } + + //zlarnd_(&z__1, &c__3, &iseed[1]); + z__1=zlarnd_(&c__3, &iseed[1]); + x[1].r = z__1.r, x[1].i = z__1.i; + xabs = z_abs(&x[1]); + if (xabs != 0.) { + z__1.r = x[1].r / xabs, z__1.i = x[1].i / xabs; + csign.r = z__1.r, csign.i = z__1.i; + } else { + csign.r = 1., csign.i = 0.; + } + i__1 = nxfrm << 1; + x[i__1].r = csign.r, x[i__1].i = csign.i; + +/* Scale the matrix A by D. */ + + if (itype == 1 || itype == 3 || itype == 4) { + i__1 = *m; + for (irow = 1; irow <= i__1; ++irow) { + d_cnjg(&z__1, &x[nxfrm + irow]); + zscal_(n, &z__1, &a[irow + a_dim1], lda); +/* L40: */ + } + } + + if (itype == 2 || itype == 3) { + i__1 = *n; + for (jcol = 1; jcol <= i__1; ++jcol) { + zscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1); +/* L50: */ + } + } + + if (itype == 4) { + i__1 = *n; + for (jcol = 1; jcol <= i__1; ++jcol) { + d_cnjg(&z__1, &x[nxfrm + jcol]); + zscal_(m, &z__1, &a[jcol * a_dim1 + 1], &c__1); +/* L60: */ + } + } + return 0; + +/* End of ZLAROR */ + +} /* zlaror_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlarot.c b/lapack-netlib/TESTING/MATGEN/zlarot.c new file mode 100644 index 000000000..8ee1ff194 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlarot.c @@ -0,0 +1,771 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLAROT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, */ +/* XRIGHT ) */ + +/* LOGICAL LLEFT, LRIGHT, LROWS */ +/* INTEGER LDA, NL */ +/* COMPLEX*16 C, S, XLEFT, XRIGHT */ +/* COMPLEX*16 A( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAROT applies a (Givens) rotation to two adjacent rows or */ +/* > columns, where one element of the first and/or last column/row */ +/* > for use on matrices stored in some format other than GE, so */ +/* > that elements of the matrix may be used or modified for which */ +/* > no array element is provided. */ +/* > */ +/* > One example is a symmetric matrix in SB format (bandwidth=4), for */ +/* > which UPLO='L': Two adjacent rows will have the format: */ +/* > */ +/* > row j: C> C> C> C> C> . . . . */ +/* > row j+1: C> C> C> C> C> . . . . */ +/* > */ +/* > '*' indicates elements for which storage is provided, */ +/* > '.' indicates elements for which no storage is provided, but */ +/* > are not necessarily zero; their values are determined by */ +/* > symmetry. ' ' indicates elements which are necessarily zero, */ +/* > and have no storage provided. */ +/* > */ +/* > Those columns which have two '*'s can be handled by DROT. */ +/* > Those columns which have no '*'s can be ignored, since as long */ +/* > as the Givens rotations are carefully applied to preserve */ +/* > symmetry, their values are determined. */ +/* > Those columns which have one '*' have to be handled separately, */ +/* > by using separate variables "p" and "q": */ +/* > */ +/* > row j: C> C> C> C> C> p . . . */ +/* > row j+1: q C> C> C> C> C> . . . . */ +/* > */ +/* > The element p would have to be set correctly, then that column */ +/* > is rotated, setting p to its new value. The next call to */ +/* > ZLAROT would rotate columns j and j+1, using p, and restore */ +/* > symmetry. The element q would start out being zero, and be */ +/* > made non-zero by the rotation. Later, rotations would presumably */ +/* > be chosen to zero q out. */ +/* > */ +/* > Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */ +/* > ------- ------- --------- */ +/* > */ +/* > General dense matrix: */ +/* > */ +/* > CALL ZLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */ +/* > A(i,1),LDA, DUMMY, DUMMY) */ +/* > */ +/* > General banded matrix in GB format: */ +/* > */ +/* > j = MAX(1, i-KL ) */ +/* > NL = MIN( N, i+KU+1 ) + 1-j */ +/* > CALL ZLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */ +/* > A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > [ note that i+1-j is just MIN(i,KL+1) ] */ +/* > */ +/* > Symmetric banded matrix in SY format, bandwidth K, */ +/* > lower triangle only: */ +/* > */ +/* > j = MAX(1, i-K ) */ +/* > NL = MIN( K+1, i ) + 1 */ +/* > CALL ZLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */ +/* > A(i,j), LDA, XLEFT, XRIGHT ) */ +/* > */ +/* > Same, but upper triangle only: */ +/* > */ +/* > NL = MIN( K+1, N-i ) + 1 */ +/* > CALL ZLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */ +/* > A(i,i), LDA, XLEFT, XRIGHT ) */ +/* > */ +/* > Symmetric banded matrix in SB format, bandwidth K, */ +/* > lower triangle only: */ +/* > */ +/* > [ same as for SY, except:] */ +/* > . . . . */ +/* > A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > [ note that i+1-j is just MIN(i,K+1) ] */ +/* > */ +/* > Same, but upper triangle only: */ +/* > . . . */ +/* > A(K+1,i), LDA-1, XLEFT, XRIGHT ) */ +/* > */ +/* > Rotating columns is just the transpose of rotating rows, except */ +/* > for GB and SB: (rotating columns i and i+1) */ +/* > */ +/* > GB: */ +/* > j = MAX(1, i-KU ) */ +/* > NL = MIN( N, i+KL+1 ) + 1-j */ +/* > CALL ZLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */ +/* > A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ +/* > */ +/* > [note that KU+j+1-i is just MAX(1,KU+2-i)] */ +/* > */ +/* > SB: (upper triangle) */ +/* > */ +/* > . . . . . . */ +/* > A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */ +/* > */ +/* > SB: (lower triangle) */ +/* > */ +/* > . . . . . . */ +/* > A(1,i),LDA-1, XTOP, XBOTTM ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > LROWS - LOGICAL */ +/* > If .TRUE., then ZLAROT will rotate two rows. If .FALSE., */ +/* > then it will rotate two columns. */ +/* > Not modified. */ +/* > */ +/* > LLEFT - LOGICAL */ +/* > If .TRUE., then XLEFT will be used instead of the */ +/* > corresponding element of A for the first element in the */ +/* > second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */ +/* > If .FALSE., then the corresponding element of A will be */ +/* > used. */ +/* > Not modified. */ +/* > */ +/* > LRIGHT - LOGICAL */ +/* > If .TRUE., then XRIGHT will be used instead of the */ +/* > corresponding element of A for the last element in the */ +/* > first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */ +/* > .FALSE., then the corresponding element of A will be used. */ +/* > Not modified. */ +/* > */ +/* > NL - INTEGER */ +/* > The length of the rows (if LROWS=.TRUE.) or columns (if */ +/* > LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are */ +/* > used, the columns/rows they are in should be included in */ +/* > NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */ +/* > least 2. The number of rows/columns to be rotated */ +/* > exclusive of those involving XLEFT and/or XRIGHT may */ +/* > not be negative, i.e., NL minus how many of LLEFT and */ +/* > LRIGHT are .TRUE. must be at least zero; if not, XERBLA */ +/* > will be called. */ +/* > Not modified. */ +/* > */ +/* > C, S - COMPLEX*16 */ +/* > Specify the Givens rotation to be applied. If LROWS is */ +/* > true, then the matrix ( c s ) */ +/* > ( _ _ ) */ +/* > (-s c ) is applied from the left; */ +/* > if false, then the transpose (not conjugated) thereof is */ +/* > applied from the right. Note that in contrast to the */ +/* > output of ZROTG or to most versions of ZROT, both C and S */ +/* > are complex. For a Givens rotation, |C|**2 + |S|**2 should */ +/* > be 1, but this is not checked. */ +/* > Not modified. */ +/* > */ +/* > A - COMPLEX*16 array. */ +/* > The array containing the rows/columns to be rotated. The */ +/* > first element of A should be the upper left element to */ +/* > be rotated. */ +/* > Read and modified. */ +/* > */ +/* > LDA - INTEGER */ +/* > The "effective" leading dimension of A. If A contains */ +/* > a matrix stored in GE, HE, or SY format, then this is just */ +/* > the leading dimension of A as dimensioned in the calling */ +/* > routine. If A contains a matrix stored in band (GB, HB, or */ +/* > SB) format, then this should be *one less* than the leading */ +/* > dimension used in the calling routine. Thus, if A were */ +/* > dimensioned A(LDA,*) in ZLAROT, then A(1,j) would be the */ +/* > j-th element in the first of the two rows to be rotated, */ +/* > and A(2,j) would be the j-th in the second, regardless of */ +/* > how the array may be stored in the calling routine. [A */ +/* > cannot, however, actually be dimensioned thus, since for */ +/* > band format, the row number may exceed LDA, which is not */ +/* > legal FORTRAN.] */ +/* > If LROWS=.TRUE., then LDA must be at least 1, otherwise */ +/* > it must be at least NL minus the number of .TRUE. values */ +/* > in XLEFT and XRIGHT. */ +/* > Not modified. */ +/* > */ +/* > XLEFT - COMPLEX*16 */ +/* > If LLEFT is .TRUE., then XLEFT will be used and modified */ +/* > instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */ +/* > (if LROWS=.FALSE.). */ +/* > Read and modified. */ +/* > */ +/* > XRIGHT - COMPLEX*16 */ +/* > If LRIGHT is .TRUE., then XRIGHT will be used and modified */ +/* > instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */ +/* > (if LROWS=.FALSE.). */ +/* > Read and modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlarot_(logical *lrows, logical *lleft, logical *lright, + integer *nl, doublecomplex *c__, doublecomplex *s, doublecomplex *a, + integer *lda, doublecomplex *xleft, doublecomplex *xright) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; + + /* Local variables */ + integer iinc, j, inext; + doublecomplex tempx; + integer ix, iy, nt; + doublecomplex xt[2], yt[2]; + extern /* Subroutine */ int xerbla_(char *, integer *); + integer iyt; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Set up indices, arrays for ends */ + + /* Parameter adjustments */ + --a; + + /* Function Body */ + if (*lrows) { + iinc = *lda; + inext = 1; + } else { + iinc = 1; + inext = *lda; + } + + if (*lleft) { + nt = 1; + ix = iinc + 1; + iy = *lda + 2; + xt[0].r = a[1].r, xt[0].i = a[1].i; + yt[0].r = xleft->r, yt[0].i = xleft->i; + } else { + nt = 0; + ix = 1; + iy = inext + 1; + } + + if (*lright) { + iyt = inext + 1 + (*nl - 1) * iinc; + ++nt; + i__1 = nt - 1; + xt[i__1].r = xright->r, xt[i__1].i = xright->i; + i__1 = nt - 1; + i__2 = iyt; + yt[i__1].r = a[i__2].r, yt[i__1].i = a[i__2].i; + } + +/* Check for errors */ + + if (*nl < nt) { + xerbla_("ZLAROT", &c__4); + return 0; + } + if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) { + xerbla_("ZLAROT", &c__8); + return 0; + } + +/* Rotate */ + +/* ZROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S */ + + i__1 = *nl - nt - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = ix + j * iinc; + z__2.r = c__->r * a[i__2].r - c__->i * a[i__2].i, z__2.i = c__->r * a[ + i__2].i + c__->i * a[i__2].r; + i__3 = iy + j * iinc; + z__3.r = s->r * a[i__3].r - s->i * a[i__3].i, z__3.i = s->r * a[i__3] + .i + s->i * a[i__3].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + tempx.r = z__1.r, tempx.i = z__1.i; + i__2 = iy + j * iinc; + d_cnjg(&z__4, s); + z__3.r = -z__4.r, z__3.i = -z__4.i; + i__3 = ix + j * iinc; + z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i, z__2.i = z__3.r * a[ + i__3].i + z__3.i * a[i__3].r; + d_cnjg(&z__6, c__); + i__4 = iy + j * iinc; + z__5.r = z__6.r * a[i__4].r - z__6.i * a[i__4].i, z__5.i = z__6.r * a[ + i__4].i + z__6.i * a[i__4].r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = ix + j * iinc; + a[i__2].r = tempx.r, a[i__2].i = tempx.i; +/* L10: */ + } + +/* ZROT( NT, XT,1, YT,1, C, S ) with complex C, S */ + + i__1 = nt; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + z__2.r = c__->r * xt[i__2].r - c__->i * xt[i__2].i, z__2.i = c__->r * + xt[i__2].i + c__->i * xt[i__2].r; + i__3 = j - 1; + z__3.r = s->r * yt[i__3].r - s->i * yt[i__3].i, z__3.i = s->r * yt[ + i__3].i + s->i * yt[i__3].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + tempx.r = z__1.r, tempx.i = z__1.i; + i__2 = j - 1; + d_cnjg(&z__4, s); + z__3.r = -z__4.r, z__3.i = -z__4.i; + i__3 = j - 1; + z__2.r = z__3.r * xt[i__3].r - z__3.i * xt[i__3].i, z__2.i = z__3.r * + xt[i__3].i + z__3.i * xt[i__3].r; + d_cnjg(&z__6, c__); + i__4 = j - 1; + z__5.r = z__6.r * yt[i__4].r - z__6.i * yt[i__4].i, z__5.i = z__6.r * + yt[i__4].i + z__6.i * yt[i__4].r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + yt[i__2].r = z__1.r, yt[i__2].i = z__1.i; + i__2 = j - 1; + xt[i__2].r = tempx.r, xt[i__2].i = tempx.i; +/* L20: */ + } + +/* Stuff values back into XLEFT, XRIGHT, etc. */ + + if (*lleft) { + a[1].r = xt[0].r, a[1].i = xt[0].i; + xleft->r = yt[0].r, xleft->i = yt[0].i; + } + + if (*lright) { + i__1 = nt - 1; + xright->r = xt[i__1].r, xright->i = xt[i__1].i; + i__1 = iyt; + i__2 = nt - 1; + a[i__1].r = yt[i__2].r, a[i__1].i = yt[i__2].i; + } + + return 0; + +/* End of ZLAROT */ + +} /* zlarot_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlatm1.c b/lapack-netlib/TESTING/MATGEN/zlatm1.c new file mode 100644 index 000000000..abb6f2313 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlatm1.c @@ -0,0 +1,731 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLATM1 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) */ + +/* INTEGER IDIST, INFO, IRSIGN, MODE, N */ +/* DOUBLE PRECISION COND */ +/* INTEGER ISEED( 4 ) */ +/* COMPLEX*16 D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATM1 computes the entries of D(1..N) as specified by */ +/* > MODE, COND and IRSIGN. IDIST and ISEED determine the generation */ +/* > of random numbers. ZLATM1 is called by ZLATMR to generate */ +/* > random test matrices for LAPACK programs. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry describes how D is to be computed: */ +/* > MODE = 0 means do not change D. */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is DOUBLE PRECISION */ +/* > On entry, used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IRSIGN */ +/* > \verbatim */ +/* > IRSIGN is INTEGER */ +/* > On entry, if MODE neither -6, 0 nor 6, determines sign of */ +/* > entries of D */ +/* > 0 => leave entries of D unchanged */ +/* > 1 => multiply each entry of D by random complex number */ +/* > uniformly distributed with absolute value 1 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => real and imaginary parts each UNIFORM( 0, 1 ) */ +/* > 2 => real and imaginary parts each UNIFORM( -1, 1 ) */ +/* > 3 => real and imaginary parts each NORMAL( 0, 1 ) */ +/* > 4 => complex number uniform in DISK( 0, 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. The random number generator uses a */ +/* > linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to ZLATM1 */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is COMPLEX*16 array, dimension ( N ) */ +/* > Array to be computed according to MODE, COND and IRSIGN. */ +/* > May be changed on exit if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of entries of D. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > 0 => normal termination */ +/* > -1 => if MODE not in range -6 to 6 */ +/* > -2 => if MODE neither -6, 0 nor 6, and */ +/* > IRSIGN neither 0 nor 1 */ +/* > -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */ +/* > -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 4 */ +/* > -7 => if N negative */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlatm1_(integer *mode, doublereal *cond, integer *irsign, + integer *idist, integer *iseed, doublecomplex *d__, integer *n, + integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Local variables */ + doublereal temp; + integer i__; + doublereal alpha; + doublecomplex ctemp; + extern doublereal dlaran_(integer *); + extern /* Subroutine */ int xerbla_(char *, integer *); + //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, + extern doublecomplex zlarnd_(integer *, + integer *); + extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *, + doublecomplex *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and Test the input parameters. Initialize flags & seed. */ + + /* Parameter adjustments */ + --d__; + --iseed; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Set INFO if an error */ + + if (*mode < -6 || *mode > 6) { + *info = -1; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && * + irsign != 1)) { + *info = -2; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) { + *info = -3; + } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 4)) { + *info = -4; + } else if (*n < 0) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLATM1", &i__1); + return 0; + } + +/* Compute D according to COND and MODE */ + + if (*mode != 0) { + switch (abs(*mode)) { + case 1: goto L10; + case 2: goto L30; + case 3: goto L50; + case 4: goto L70; + case 5: goto L90; + case 6: goto L110; + } + +/* One large D value: */ + +L10: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d__1 = 1. / *cond; + d__[i__2].r = d__1, d__[i__2].i = 0.; +/* L20: */ + } + d__[1].r = 1., d__[1].i = 0.; + goto L120; + +/* One small D value: */ + +L30: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d__[i__2].r = 1., d__[i__2].i = 0.; +/* L40: */ + } + i__1 = *n; + d__1 = 1. / *cond; + d__[i__1].r = d__1, d__[i__1].i = 0.; + goto L120; + +/* Exponentially distributed D values: */ + +L50: + d__[1].r = 1., d__[1].i = 0.; + if (*n > 1) { + d__1 = -1. / (doublereal) (*n - 1); + alpha = pow_dd(cond, &d__1); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__ - 1; + d__1 = pow_di(&alpha, &i__3); + d__[i__2].r = d__1, d__[i__2].i = 0.; +/* L60: */ + } + } + goto L120; + +/* Arithmetically distributed D values: */ + +L70: + d__[1].r = 1., d__[1].i = 0.; + if (*n > 1) { + temp = 1. / *cond; + alpha = (1. - temp) / (doublereal) (*n - 1); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + i__2 = i__; + d__1 = (doublereal) (*n - i__) * alpha + temp; + d__[i__2].r = d__1, d__[i__2].i = 0.; +/* L80: */ + } + } + goto L120; + +/* Randomly distributed D values on ( 1/COND , 1): */ + +L90: + alpha = log(1. / *cond); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d__1 = exp(alpha * dlaran_(&iseed[1])); + d__[i__2].r = d__1, d__[i__2].i = 0.; +/* L100: */ + } + goto L120; + +/* Randomly distributed D values from IDIST */ + +L110: + zlarnv_(idist, &iseed[1], n, &d__[1]); + +L120: + +/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */ +/* random signs to D */ + + if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + //zlarnd_(&z__1, &c__3, &iseed[1]); + z__1=zlarnd_(&c__3, &iseed[1]); + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = i__; + i__3 = i__; + d__1 = z_abs(&ctemp); + z__2.r = ctemp.r / d__1, z__2.i = ctemp.i / d__1; + z__1.r = d__[i__3].r * z__2.r - d__[i__3].i * z__2.i, z__1.i = + d__[i__3].r * z__2.i + d__[i__3].i * z__2.r; + d__[i__2].r = z__1.r, d__[i__2].i = z__1.i; +/* L130: */ + } + } + +/* Reverse if MODE < 0 */ + + if (*mode < 0) { + i__1 = *n / 2; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + ctemp.r = d__[i__2].r, ctemp.i = d__[i__2].i; + i__2 = i__; + i__3 = *n + 1 - i__; + d__[i__2].r = d__[i__3].r, d__[i__2].i = d__[i__3].i; + i__2 = *n + 1 - i__; + d__[i__2].r = ctemp.r, d__[i__2].i = ctemp.i; +/* L140: */ + } + } + + } + + return 0; + +/* End of ZLATM1 */ + +} /* zlatm1_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlatm2.c b/lapack-netlib/TESTING/MATGEN/zlatm2.c new file mode 100644 index 000000000..f0f591b55 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlatm2.c @@ -0,0 +1,741 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLATM2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* COMPLEX*16 FUNCTION ZLATM2( M, N, I, J, KL, KU, IDIST, */ +/* ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) */ + + +/* INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N */ +/* DOUBLE PRECISION SPARSE */ + + +/* INTEGER ISEED( 4 ), IWORK( * ) */ +/* COMPLEX*16 D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATM2 returns the (I,J) entry of a random matrix of dimension */ +/* > (M, N) described by the other parameters. It is called by the */ +/* > ZLATMR routine in order to build random test matrices. No error */ +/* > checking on parameters is done, because this routine is called in */ +/* > a tight loop by ZLATMR which has already checked the parameters. */ +/* > */ +/* > Use of ZLATM2 differs from CLATM3 in the order in which the random */ +/* > number generator is called to fill in random matrix entries. */ +/* > With ZLATM2, the generator is called to fill in the pivoted matrix */ +/* > columnwise. With ZLATM3, the generator is called to fill in the */ +/* > matrix columnwise, after which it is pivoted. Thus, ZLATM3 can */ +/* > be used to construct random matrices which differ only in their */ +/* > order of rows and/or columns. ZLATM2 is used to construct band */ +/* > matrices while avoiding calling the random number generator for */ +/* > entries outside the band (and therefore generating random numbers */ +/* > */ +/* > The matrix whose (I,J) entry is returned is constructed as */ +/* > follows (this routine only computes one entry): */ +/* > */ +/* > If I is outside (1..M) or J is outside (1..N), return zero */ +/* > (this is convenient for generating matrices in band format). */ +/* > */ +/* > Generate a matrix A with random entries of distribution IDIST. */ +/* > */ +/* > Set the diagonal to D. */ +/* > */ +/* > Grade the matrix, if desired, from the left (by DL) and/or */ +/* > from the right (by DR or DL) as specified by IGRADE. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > IPVTNG and IWORK. */ +/* > */ +/* > Band the matrix to have lower bandwidth KL and upper */ +/* > bandwidth KU. */ +/* > */ +/* > Set random entries to zero as specified by SPARSE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > Row of entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J */ +/* > \verbatim */ +/* > J is INTEGER */ +/* > Column of entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > Lower bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > Upper bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => real and imaginary parts each UNIFORM( 0, 1 ) */ +/* > 2 => real and imaginary parts each UNIFORM( -1, 1 ) */ +/* > 3 => real and imaginary parts each NORMAL( 0, 1 ) */ +/* > 4 => complex number uniform in DISK( 0 , 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array of dimension ( 4 ) */ +/* > Seed for random number generator. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is COMPLEX*16 array of dimension ( MIN( I , J ) ) */ +/* > Diagonal entries of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGRADE */ +/* > \verbatim */ +/* > IGRADE is INTEGER */ +/* > Specifies grading of matrix as follows: */ +/* > 0 => no grading */ +/* > 1 => matrix premultiplied by diag( DL ) */ +/* > 2 => matrix postmultiplied by diag( DR ) */ +/* > 3 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > 4 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > 5 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( CONJG(DL) ) */ +/* > 6 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is COMPLEX*16 array ( I or J, as appropriate ) */ +/* > Left scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DR */ +/* > \verbatim */ +/* > DR is COMPLEX*16 array ( I or J, as appropriate ) */ +/* > Right scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPVTNG */ +/* > \verbatim */ +/* > IPVTNG is INTEGER */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 0 => none. */ +/* > 1 => row pivoting. */ +/* > 2 => column pivoting. */ +/* > 3 => full pivoting, i.e., on both sides. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array ( I or J, as appropriate ) */ +/* > This array specifies the permutation used. The */ +/* > row (or column) in position K was originally in */ +/* > position IWORK( K ). */ +/* > This differs from IWORK for ZLATM3. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is DOUBLE PRECISION between 0. and 1. */ +/* > On entry specifies the sparsity of the matrix */ +/* > if sparse matrix is to be generated. */ +/* > SPARSE should lie between 0 and 1. */ +/* > A uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Double Complex */ VOID zlatm2_(doublecomplex * ret_val, integer *m, + integer *n, integer *i__, integer *j, integer *kl, integer *ku, + integer *idist, integer *iseed, doublecomplex *d__, integer *igrade, + doublecomplex *dl, doublecomplex *dr, integer *ipvtng, integer *iwork, + doublereal *sparse) +{ + /* System generated locals */ + integer i__1, i__2; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer isub, jsub; + doublecomplex ctemp; + extern doublereal dlaran_(integer *); + //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, + extern doublecomplex zlarnd_(integer *, + integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + + + + +/* ===================================================================== */ + + + + + + + + + +/* ----------------------------------------------------------------------- */ + + + +/* Check for I and J in range */ + + /* Parameter adjustments */ + --iwork; + --dr; + --dl; + --d__; + --iseed; + + /* Function Body */ + if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) { + ret_val->r = 0., ret_val->i = 0.; + return ; + } + +/* Check for banding */ + + if (*j > *i__ + *ku || *j < *i__ - *kl) { + ret_val->r = 0., ret_val->i = 0.; + return ; + } + +/* Check for sparsity */ + + if (*sparse > 0.) { + if (dlaran_(&iseed[1]) < *sparse) { + ret_val->r = 0., ret_val->i = 0.; + return ; + } + } + +/* Compute subscripts depending on IPVTNG */ + + if (*ipvtng == 0) { + isub = *i__; + jsub = *j; + } else if (*ipvtng == 1) { + isub = iwork[*i__]; + jsub = *j; + } else if (*ipvtng == 2) { + isub = *i__; + jsub = iwork[*j]; + } else if (*ipvtng == 3) { + isub = iwork[*i__]; + jsub = iwork[*j]; + } + +/* Compute entry and grade it according to IGRADE */ + + if (isub == jsub) { + i__1 = isub; + ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i; + } else { + //zlarnd_(&z__1, idist, &iseed[1]); + z__1=zlarnd_(idist, &iseed[1]); + ctemp.r = z__1.r, ctemp.i = z__1.i; + } + if (*igrade == 1) { + i__1 = isub; + z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + } else if (*igrade == 2) { + i__1 = jsub; + z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i = + ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + } else if (*igrade == 3) { + i__1 = isub; + z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + i__2 = jsub; + z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r * + dr[i__2].i + z__2.i * dr[i__2].r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + } else if (*igrade == 4 && isub != jsub) { + i__1 = isub; + z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + z_div(&z__1, &z__2, &dl[jsub]); + ctemp.r = z__1.r, ctemp.i = z__1.i; + } else if (*igrade == 5) { + i__1 = isub; + z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + d_cnjg(&z__3, &dl[jsub]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + + z__2.i * z__3.r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + } else if (*igrade == 6) { + i__1 = isub; + z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + i__2 = jsub; + z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r * + dl[i__2].i + z__2.i * dl[i__2].r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + } + ret_val->r = ctemp.r, ret_val->i = ctemp.i; + return ; + +/* End of ZLATM2 */ + +} /* zlatm2_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlatm3.c b/lapack-netlib/TESTING/MATGEN/zlatm3.c new file mode 100644 index 000000000..7b81ae2bd --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlatm3.c @@ -0,0 +1,759 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLATM3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* COMPLEX*16 FUNCTION ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, */ +/* IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, */ +/* SPARSE ) */ + + +/* INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, */ +/* $ KU, M, N */ +/* DOUBLE PRECISION SPARSE */ + + +/* INTEGER ISEED( 4 ), IWORK( * ) */ +/* COMPLEX*16 D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATM3 returns the (ISUB,JSUB) entry of a random matrix of */ +/* > dimension (M, N) described by the other parameters. (ISUB,JSUB) */ +/* > is the final position of the (I,J) entry after pivoting */ +/* > according to IPVTNG and IWORK. ZLATM3 is called by the */ +/* > ZLATMR routine in order to build random test matrices. No error */ +/* > checking on parameters is done, because this routine is called in */ +/* > a tight loop by ZLATMR which has already checked the parameters. */ +/* > */ +/* > Use of ZLATM3 differs from CLATM2 in the order in which the random */ +/* > number generator is called to fill in random matrix entries. */ +/* > With ZLATM2, the generator is called to fill in the pivoted matrix */ +/* > columnwise. With ZLATM3, the generator is called to fill in the */ +/* > matrix columnwise, after which it is pivoted. Thus, ZLATM3 can */ +/* > be used to construct random matrices which differ only in their */ +/* > order of rows and/or columns. ZLATM2 is used to construct band */ +/* > matrices while avoiding calling the random number generator for */ +/* > entries outside the band (and therefore generating random numbers */ +/* > in different orders for different pivot orders). */ +/* > */ +/* > The matrix whose (ISUB,JSUB) entry is returned is constructed as */ +/* > follows (this routine only computes one entry): */ +/* > */ +/* > If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */ +/* > (this is convenient for generating matrices in band format). */ +/* > */ +/* > Generate a matrix A with random entries of distribution IDIST. */ +/* > */ +/* > Set the diagonal to D. */ +/* > */ +/* > Grade the matrix, if desired, from the left (by DL) and/or */ +/* > from the right (by DR or DL) as specified by IGRADE. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > IPVTNG and IWORK. */ +/* > */ +/* > Band the matrix to have lower bandwidth KL and upper */ +/* > bandwidth KU. */ +/* > */ +/* > Set random entries to zero as specified by SPARSE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > Row of unpivoted entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J */ +/* > \verbatim */ +/* > J is INTEGER */ +/* > Column of unpivoted entry to be returned. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISUB */ +/* > \verbatim */ +/* > ISUB is INTEGER */ +/* > Row of pivoted entry to be returned. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JSUB */ +/* > \verbatim */ +/* > JSUB is INTEGER */ +/* > Column of pivoted entry to be returned. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > Lower bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > Upper bandwidth. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > On entry, IDIST specifies the type of distribution to be */ +/* > used to generate a random matrix . */ +/* > 1 => real and imaginary parts each UNIFORM( 0, 1 ) */ +/* > 2 => real and imaginary parts each UNIFORM( -1, 1 ) */ +/* > 3 => real and imaginary parts each NORMAL( 0, 1 ) */ +/* > 4 => complex number uniform in DISK( 0 , 1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array of dimension ( 4 ) */ +/* > Seed for random number generator. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is COMPLEX*16 array of dimension ( MIN( I , J ) ) */ +/* > Diagonal entries of matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGRADE */ +/* > \verbatim */ +/* > IGRADE is INTEGER */ +/* > Specifies grading of matrix as follows: */ +/* > 0 => no grading */ +/* > 1 => matrix premultiplied by diag( DL ) */ +/* > 2 => matrix postmultiplied by diag( DR ) */ +/* > 3 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > 4 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > 5 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( CONJG(DL) ) */ +/* > 6 => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is COMPLEX*16 array ( I or J, as appropriate ) */ +/* > Left scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DR */ +/* > \verbatim */ +/* > DR is COMPLEX*16 array ( I or J, as appropriate ) */ +/* > Right scale factors for grading matrix. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPVTNG */ +/* > \verbatim */ +/* > IPVTNG is INTEGER */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 0 => none. */ +/* > 1 => row pivoting. */ +/* > 2 => column pivoting. */ +/* > 3 => full pivoting, i.e., on both sides. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array ( I or J, as appropriate ) */ +/* > This array specifies the permutation used. The */ +/* > row (or column) originally in position K is in */ +/* > position IWORK( K ) after pivoting. */ +/* > This differs from IWORK for ZLATM2. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is DOUBLE PRECISION between 0. and 1. */ +/* > On entry specifies the sparsity of the matrix */ +/* > if sparse matrix is to be generated. */ +/* > SPARSE should lie between 0 and 1. */ +/* > A uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Double Complex */ VOID zlatm3_(doublecomplex * ret_val, integer *m, + integer *n, integer *i__, integer *j, integer *isub, integer *jsub, + integer *kl, integer *ku, integer *idist, integer *iseed, + doublecomplex *d__, integer *igrade, doublecomplex *dl, doublecomplex + *dr, integer *ipvtng, integer *iwork, doublereal *sparse) +{ + /* System generated locals */ + integer i__1, i__2; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + doublecomplex ctemp; + extern doublereal dlaran_(integer *); + //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, + extern doublecomplex zlarnd_(integer *, + integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + + + + +/* ===================================================================== */ + + + + + + + + + +/* ----------------------------------------------------------------------- */ + + + +/* Check for I and J in range */ + + /* Parameter adjustments */ + --iwork; + --dr; + --dl; + --d__; + --iseed; + + /* Function Body */ + if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) { + *isub = *i__; + *jsub = *j; + ret_val->r = 0., ret_val->i = 0.; + return ; + } + +/* Compute subscripts depending on IPVTNG */ + + if (*ipvtng == 0) { + *isub = *i__; + *jsub = *j; + } else if (*ipvtng == 1) { + *isub = iwork[*i__]; + *jsub = *j; + } else if (*ipvtng == 2) { + *isub = *i__; + *jsub = iwork[*j]; + } else if (*ipvtng == 3) { + *isub = iwork[*i__]; + *jsub = iwork[*j]; + } + +/* Check for banding */ + + if (*jsub > *isub + *ku || *jsub < *isub - *kl) { + ret_val->r = 0., ret_val->i = 0.; + return ; + } + +/* Check for sparsity */ + + if (*sparse > 0.) { + if (dlaran_(&iseed[1]) < *sparse) { + ret_val->r = 0., ret_val->i = 0.; + return ; + } + } + +/* Compute entry and grade it according to IGRADE */ + + if (*i__ == *j) { + i__1 = *i__; + ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i; + } else { + //zlarnd_(&z__1, idist, &iseed[1]); + z__1=zlarnd_(idist, &iseed[1]); + ctemp.r = z__1.r, ctemp.i = z__1.i; + } + if (*igrade == 1) { + i__1 = *i__; + z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + } else if (*igrade == 2) { + i__1 = *j; + z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i = + ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + } else if (*igrade == 3) { + i__1 = *i__; + z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + i__2 = *j; + z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r * + dr[i__2].i + z__2.i * dr[i__2].r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + } else if (*igrade == 4 && *i__ != *j) { + i__1 = *i__; + z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + z_div(&z__1, &z__2, &dl[*j]); + ctemp.r = z__1.r, ctemp.i = z__1.i; + } else if (*igrade == 5) { + i__1 = *i__; + z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + d_cnjg(&z__3, &dl[*j]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i + + z__2.i * z__3.r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + } else if (*igrade == 6) { + i__1 = *i__; + z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = + ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r; + i__2 = *j; + z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r * + dl[i__2].i + z__2.i * dl[i__2].r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + } + ret_val->r = ctemp.r, ret_val->i = ctemp.i; + return ; + +/* End of ZLATM3 */ + +} /* zlatm3_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlatm5.c b/lapack-netlib/TESTING/MATGEN/zlatm5.c new file mode 100644 index 000000000..23a463960 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlatm5.c @@ -0,0 +1,1161 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define z_sin(R, Z) {pCd(R) = csinl(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLATM5 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, */ +/* E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, */ +/* QBLCKB ) */ + +/* INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, */ +/* $ PRTYPE, QBLCKA, QBLCKB */ +/* DOUBLE PRECISION ALPHA */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), */ +/* $ D( LDD, * ), E( LDE, * ), F( LDF, * ), */ +/* $ L( LDL, * ), R( LDR, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATM5 generates matrices involved in the Generalized Sylvester */ +/* > equation: */ +/* > */ +/* > A * R - L * B = C */ +/* > D * R - L * E = F */ +/* > */ +/* > They also satisfy (the diagonalization condition) */ +/* > */ +/* > [ I -L ] ( [ A -C ], [ D -F ] ) [ I R ] = ( [ A ], [ D ] ) */ +/* > [ I ] ( [ B ] [ E ] ) [ I ] ( [ B ] [ E ] ) */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PRTYPE */ +/* > \verbatim */ +/* > PRTYPE is INTEGER */ +/* > "Points" to a certain type of the matrices to generate */ +/* > (see further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Specifies the order of A and D and the number of rows in */ +/* > C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Specifies the order of B and E and the number of columns in */ +/* > C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA, M). */ +/* > On exit A M-by-M is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB, N). */ +/* > On exit B N-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC, N). */ +/* > On exit C M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of C. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is COMPLEX*16 array, dimension (LDD, M). */ +/* > On exit D M-by-M is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDD */ +/* > \verbatim */ +/* > LDD is INTEGER */ +/* > The leading dimension of D. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is COMPLEX*16 array, dimension (LDE, N). */ +/* > On exit E N-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDE */ +/* > \verbatim */ +/* > LDE is INTEGER */ +/* > The leading dimension of E. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] F */ +/* > \verbatim */ +/* > F is COMPLEX*16 array, dimension (LDF, N). */ +/* > On exit F M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of F. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is COMPLEX*16 array, dimension (LDR, N). */ +/* > On exit R M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDR */ +/* > \verbatim */ +/* > LDR is INTEGER */ +/* > The leading dimension of R. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] L */ +/* > \verbatim */ +/* > L is COMPLEX*16 array, dimension (LDL, N). */ +/* > On exit L M-by-N is initialized according to PRTYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDL */ +/* > \verbatim */ +/* > LDL is INTEGER */ +/* > The leading dimension of L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION */ +/* > Parameter used in generating PRTYPE = 1 and 5 matrices. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QBLCKA */ +/* > \verbatim */ +/* > QBLCKA is INTEGER */ +/* > When PRTYPE = 3, specifies the distance between 2-by-2 */ +/* > blocks on the diagonal in A. Otherwise, QBLCKA is not */ +/* > referenced. QBLCKA > 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QBLCKB */ +/* > \verbatim */ +/* > QBLCKB is INTEGER */ +/* > When PRTYPE = 3, specifies the distance between 2-by-2 */ +/* > blocks on the diagonal in B. Otherwise, QBLCKB is not */ +/* > referenced. QBLCKB > 1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16_matgen */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */ +/* > */ +/* > A : if (i == j) then A(i, j) = 1.0 */ +/* > if (j == i + 1) then A(i, j) = -1.0 */ +/* > else A(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > B : if (i == j) then B(i, j) = 1.0 - ALPHA */ +/* > if (j == i + 1) then B(i, j) = 1.0 */ +/* > else B(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > D : if (i == j) then D(i, j) = 1.0 */ +/* > else D(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > E : if (i == j) then E(i, j) = 1.0 */ +/* > else E(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > L = R are chosen from [-10...10], */ +/* > which specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */ +/* > */ +/* > A : if (i <= j) then A(i, j) = [-1...1] */ +/* > else A(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > if (PRTYPE = 3) then */ +/* > A(k + 1, k + 1) = A(k, k) */ +/* > A(k + 1, k) = [-1...1] */ +/* > sign(A(k, k + 1) = -(sin(A(k + 1, k)) */ +/* > k = 1, M - 1, QBLCKA */ +/* > */ +/* > B : if (i <= j) then B(i, j) = [-1...1] */ +/* > else B(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > if (PRTYPE = 3) then */ +/* > B(k + 1, k + 1) = B(k, k) */ +/* > B(k + 1, k) = [-1...1] */ +/* > sign(B(k, k + 1) = -(sign(B(k + 1, k)) */ +/* > k = 1, N - 1, QBLCKB */ +/* > */ +/* > D : if (i <= j) then D(i, j) = [-1...1]. */ +/* > else D(i, j) = 0.0, i, j = 1...M */ +/* > */ +/* > */ +/* > E : if (i <= j) then D(i, j) = [-1...1] */ +/* > else E(i, j) = 0.0, i, j = 1...N */ +/* > */ +/* > L, R are chosen from [-10...10], */ +/* > which specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 4 Full */ +/* > A(i, j) = [-10...10] */ +/* > D(i, j) = [-1...1] i,j = 1...M */ +/* > B(i, j) = [-10...10] */ +/* > E(i, j) = [-1...1] i,j = 1...N */ +/* > R(i, j) = [-10...10] */ +/* > L(i, j) = [-1...1] i = 1..M ,j = 1...N */ +/* > */ +/* > L, R specifies the right hand sides (C, F). */ +/* > */ +/* > PRTYPE = 5 special case common and/or close eigs. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlatm5_(integer *prtype, integer *m, integer *n, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + doublecomplex *c__, integer *ldc, doublecomplex *d__, integer *ldd, + doublecomplex *e, integer *lde, doublecomplex *f, integer *ldf, + doublecomplex *r__, integer *ldr, doublecomplex *l, integer *ldl, + doublereal *alpha, integer *qblcka, integer *qblckb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset, + r_dim1, r_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Local variables */ + integer i__, j, k; + doublecomplex imeps, reeps; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + r_dim1 = *ldr; + r_offset = 1 + r_dim1 * 1; + r__ -= r_offset; + l_dim1 = *ldl; + l_offset = 1 + l_dim1 * 1; + l -= l_offset; + + /* Function Body */ + if (*prtype == 1) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + if (i__ == j) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 1., a[i__3].i = 0.; + i__3 = i__ + j * d_dim1; + d__[i__3].r = 1., d__[i__3].i = 0.; + } else if (i__ == j - 1) { + i__3 = i__ + j * a_dim1; + z__1.r = -1., z__1.i = 0.; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + j * d_dim1; + d__[i__3].r = 0., d__[i__3].i = 0.; + } else { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + i__3 = i__ + j * d_dim1; + d__[i__3].r = 0., d__[i__3].i = 0.; + } +/* L10: */ + } +/* L20: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (i__ == j) { + i__3 = i__ + j * b_dim1; + z__1.r = 1. - *alpha, z__1.i = 0.; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + i__3 = i__ + j * e_dim1; + e[i__3].r = 1., e[i__3].i = 0.; + } else if (i__ == j - 1) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 1., b[i__3].i = 0.; + i__3 = i__ + j * e_dim1; + e[i__3].r = 0., e[i__3].i = 0.; + } else { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; + i__3 = i__ + j * e_dim1; + e[i__3].r = 0., e[i__3].i = 0.; + } +/* L30: */ + } +/* L40: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * r_dim1; + i__4 = i__ / j; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 20.; + r__[i__3].r = z__1.r, r__[i__3].i = z__1.i; + i__3 = i__ + j * l_dim1; + i__4 = i__ + j * r_dim1; + l[i__3].r = r__[i__4].r, l[i__3].i = r__[i__4].i; +/* L50: */ + } +/* L60: */ + } + + } else if (*prtype == 2 || *prtype == 3) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + if (i__ <= j) { + i__3 = i__ + j * a_dim1; + z__4.r = (doublereal) i__, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 2.; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + j * d_dim1; + i__4 = i__ * j; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 2.; + d__[i__3].r = z__1.r, d__[i__3].i = z__1.i; + } else { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + i__3 = i__ + j * d_dim1; + d__[i__3].r = 0., d__[i__3].i = 0.; + } +/* L70: */ + } +/* L80: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (i__ <= j) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 2.; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + i__3 = i__ + j * e_dim1; + z__4.r = (doublereal) j, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 2.; + e[i__3].r = z__1.r, e[i__3].i = z__1.i; + } else { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; + i__3 = i__ + j * e_dim1; + e[i__3].r = 0., e[i__3].i = 0.; + } +/* L90: */ + } +/* L100: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * r_dim1; + i__4 = i__ * j; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 20.; + r__[i__3].r = z__1.r, r__[i__3].i = z__1.i; + i__3 = i__ + j * l_dim1; + i__4 = i__ + j; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 20.; + l[i__3].r = z__1.r, l[i__3].i = z__1.i; +/* L110: */ + } +/* L120: */ + } + + if (*prtype == 3) { + if (*qblcka <= 1) { + *qblcka = 2; + } + i__1 = *m - 1; + i__2 = *qblcka; + for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { + i__3 = k + 1 + (k + 1) * a_dim1; + i__4 = k + k * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + i__3 = k + 1 + k * a_dim1; + z_sin(&z__2, &a[k + (k + 1) * a_dim1]); + z__1.r = -z__2.r, z__1.i = -z__2.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L130: */ + } + + if (*qblckb <= 1) { + *qblckb = 2; + } + i__2 = *n - 1; + i__1 = *qblckb; + for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { + i__3 = k + 1 + (k + 1) * b_dim1; + i__4 = k + k * b_dim1; + b[i__3].r = b[i__4].r, b[i__3].i = b[i__4].i; + i__3 = k + 1 + k * b_dim1; + z_sin(&z__2, &b[k + (k + 1) * b_dim1]); + z__1.r = -z__2.r, z__1.i = -z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L140: */ + } + } + + } else if (*prtype == 4) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + i__4 = i__ * j; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 20.; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + j * d_dim1; + i__4 = i__ + j; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 2.; + d__[i__3].r = z__1.r, d__[i__3].i = z__1.i; +/* L150: */ + } +/* L160: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 20.; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + i__3 = i__ + j * e_dim1; + i__4 = i__ * j; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 2.; + e[i__3].r = z__1.r, e[i__3].i = z__1.i; +/* L170: */ + } +/* L180: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * r_dim1; + i__4 = j / i__; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 20. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 20.; + r__[i__3].r = z__1.r, r__[i__3].i = z__1.i; + i__3 = i__ + j * l_dim1; + i__4 = i__ * j; + z__4.r = (doublereal) i__4, z__4.i = 0.; + z_sin(&z__3, &z__4); + z__2.r = .5 - z__3.r, z__2.i = 0. - z__3.i; + z__1.r = z__2.r * 2. - z__2.i * 0., z__1.i = z__2.r * 0. + + z__2.i * 2.; + l[i__3].r = z__1.r, l[i__3].i = z__1.i; +/* L190: */ + } +/* L200: */ + } + + } else if (*prtype >= 5) { + z__3.r = 1., z__3.i = 0.; + z__2.r = z__3.r * 20. - z__3.i * 0., z__2.i = z__3.r * 0. + z__3.i * + 20.; + z__1.r = z__2.r / *alpha, z__1.i = z__2.i / *alpha; + reeps.r = z__1.r, reeps.i = z__1.i; + z__2.r = -1.5, z__2.i = 0.; + z__1.r = z__2.r / *alpha, z__1.i = z__2.i / *alpha; + imeps.r = z__1.r, imeps.i = z__1.i; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * r_dim1; + i__4 = i__ * j; + z__5.r = (doublereal) i__4, z__5.i = 0.; + z_sin(&z__4, &z__5); + z__3.r = .5 - z__4.r, z__3.i = 0. - z__4.i; + z__2.r = *alpha * z__3.r, z__2.i = *alpha * z__3.i; + z_div(&z__1, &z__2, &c_b5); + r__[i__3].r = z__1.r, r__[i__3].i = z__1.i; + i__3 = i__ + j * l_dim1; + i__4 = i__ + j; + z__5.r = (doublereal) i__4, z__5.i = 0.; + z_sin(&z__4, &z__5); + z__3.r = .5 - z__4.r, z__3.i = 0. - z__4.i; + z__2.r = *alpha * z__3.r, z__2.i = *alpha * z__3.i; + z_div(&z__1, &z__2, &c_b5); + l[i__3].r = z__1.r, l[i__3].i = z__1.i; +/* L210: */ + } +/* L220: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * d_dim1; + d__[i__2].r = 1., d__[i__2].i = 0.; +/* L230: */ + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ <= 4) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + if (i__ > 2) { + i__2 = i__ + i__ * a_dim1; + z__1.r = reeps.r + 1., z__1.i = reeps.i + 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + if (i__ % 2 != 0 && i__ < *m) { + i__2 = i__ + (i__ + 1) * a_dim1; + a[i__2].r = imeps.r, a[i__2].i = imeps.i; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * a_dim1; + z__1.r = -imeps.r, z__1.i = -imeps.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } else if (i__ <= 8) { + if (i__ <= 6) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = reeps.r, a[i__2].i = reeps.i; + } else { + i__2 = i__ + i__ * a_dim1; + z__1.r = -reeps.r, z__1.i = -reeps.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + if (i__ % 2 != 0 && i__ < *m) { + i__2 = i__ + (i__ + 1) * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * a_dim1; + z__1.r = -1., z__1.i = 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } else { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + if (i__ % 2 != 0 && i__ < *m) { + i__2 = i__ + (i__ + 1) * a_dim1; + d__1 = 2.; + z__1.r = d__1 * imeps.r, z__1.i = d__1 * imeps.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * a_dim1; + z__2.r = -imeps.r, z__2.i = -imeps.i; + d__1 = 2.; + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + } +/* L240: */ + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * e_dim1; + e[i__2].r = 1., e[i__2].i = 0.; + if (i__ <= 4) { + i__2 = i__ + i__ * b_dim1; + z__1.r = -1., z__1.i = 0.; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + if (i__ > 2) { + i__2 = i__ + i__ * b_dim1; + z__1.r = 1. - reeps.r, z__1.i = 0. - reeps.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + if (i__ % 2 != 0 && i__ < *n) { + i__2 = i__ + (i__ + 1) * b_dim1; + b[i__2].r = imeps.r, b[i__2].i = imeps.i; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * b_dim1; + z__1.r = -imeps.r, z__1.i = -imeps.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + } else if (i__ <= 8) { + if (i__ <= 6) { + i__2 = i__ + i__ * b_dim1; + b[i__2].r = reeps.r, b[i__2].i = reeps.i; + } else { + i__2 = i__ + i__ * b_dim1; + z__1.r = -reeps.r, z__1.i = -reeps.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + if (i__ % 2 != 0 && i__ < *n) { + i__2 = i__ + (i__ + 1) * b_dim1; + z__1.r = imeps.r + 1., z__1.i = imeps.i + 0.; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * b_dim1; + z__2.r = -1., z__2.i = 0.; + z__1.r = z__2.r - imeps.r, z__1.i = z__2.i - imeps.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + } else { + i__2 = i__ + i__ * b_dim1; + z__1.r = 1. - reeps.r, z__1.i = 0. - reeps.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + if (i__ % 2 != 0 && i__ < *n) { + i__2 = i__ + (i__ + 1) * b_dim1; + d__1 = 2.; + z__1.r = d__1 * imeps.r, z__1.i = d__1 * imeps.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } else if (i__ > 1) { + i__2 = i__ + (i__ - 1) * b_dim1; + z__2.r = -imeps.r, z__2.i = -imeps.i; + d__1 = 2.; + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + } +/* L250: */ + } + } + +/* Compute rhs (C, F) */ + + zgemm_("N", "N", m, n, m, &c_b1, &a[a_offset], lda, &r__[r_offset], ldr, & + c_b3, &c__[c_offset], ldc); + z__1.r = -1., z__1.i = 0.; + zgemm_("N", "N", m, n, n, &z__1, &l[l_offset], ldl, &b[b_offset], ldb, & + c_b1, &c__[c_offset], ldc); + zgemm_("N", "N", m, n, m, &c_b1, &d__[d_offset], ldd, &r__[r_offset], ldr, + &c_b3, &f[f_offset], ldf); + z__1.r = -1., z__1.i = 0.; + zgemm_("N", "N", m, n, n, &z__1, &l[l_offset], ldl, &e[e_offset], lde, & + c_b1, &f[f_offset], ldf); + +/* End of ZLATM5 */ + + return 0; +} /* zlatm5_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlatm6.c b/lapack-netlib/TESTING/MATGEN/zlatm6.c new file mode 100644 index 000000000..c47786c05 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlatm6.c @@ -0,0 +1,817 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLATM6 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, */ +/* BETA, WX, WY, S, DIF ) */ + +/* INTEGER LDA, LDX, LDY, N, TYPE */ +/* COMPLEX*16 ALPHA, BETA, WX, WY */ +/* DOUBLE PRECISION DIF( * ), S( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDA, * ), X( LDX, * ), */ +/* $ Y( LDY, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATM6 generates test matrices for the generalized eigenvalue */ +/* > problem, their corresponding right and left eigenvector matrices, */ +/* > and also reciprocal condition numbers for all eigenvalues and */ +/* > the reciprocal condition numbers of eigenvectors corresponding to */ +/* > the 1th and 5th eigenvalues. */ +/* > */ +/* > Test Matrices */ +/* > ============= */ +/* > */ +/* > Two kinds of test matrix pairs */ +/* > (A, B) = inverse(YH) * (Da, Db) * inverse(X) */ +/* > are used in the tests: */ +/* > */ +/* > Type 1: */ +/* > Da = 1+a 0 0 0 0 Db = 1 0 0 0 0 */ +/* > 0 2+a 0 0 0 0 1 0 0 0 */ +/* > 0 0 3+a 0 0 0 0 1 0 0 */ +/* > 0 0 0 4+a 0 0 0 0 1 0 */ +/* > 0 0 0 0 5+a , 0 0 0 0 1 */ +/* > and Type 2: */ +/* > Da = 1+i 0 0 0 0 Db = 1 0 0 0 0 */ +/* > 0 1-i 0 0 0 0 1 0 0 0 */ +/* > 0 0 1 0 0 0 0 1 0 0 */ +/* > 0 0 0 (1+a)+(1+b)i 0 0 0 0 1 0 */ +/* > 0 0 0 0 (1+a)-(1+b)i, 0 0 0 0 1 . */ +/* > */ +/* > In both cases the same inverse(YH) and inverse(X) are used to compute */ +/* > (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */ +/* > */ +/* > YH: = 1 0 -y y -y X = 1 0 -x -x x */ +/* > 0 1 -y y -y 0 1 x -x -x */ +/* > 0 0 1 0 0 0 0 1 0 0 */ +/* > 0 0 0 1 0 0 0 0 1 0 */ +/* > 0 0 0 0 1, 0 0 0 0 1 , where */ +/* > */ +/* > a, b, x and y will have all values independently of each other. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TYPE */ +/* > \verbatim */ +/* > TYPE is INTEGER */ +/* > Specifies the problem type (see further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Size of the matrices A and B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA, N). */ +/* > On exit A N-by-N is initialized according to TYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of A and of B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDA, N). */ +/* > On exit B N-by-N is initialized according to TYPE. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX, N). */ +/* > On exit X is the N-by-N matrix of right eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of X. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (LDY, N). */ +/* > On exit Y is the N-by-N matrix of left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX*16 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is COMPLEX*16 */ +/* > \verbatim */ +/* > Weighting constants for matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WX */ +/* > \verbatim */ +/* > WX is COMPLEX*16 */ +/* > Constant for right eigenvector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WY */ +/* > \verbatim */ +/* > WY is COMPLEX*16 */ +/* > Constant for left eigenvector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > S(i) is the reciprocal condition number for eigenvalue i. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is DOUBLE PRECISION array, dimension (N) */ +/* > DIF(i) is the reciprocal condition number for eigenvector i. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlatm6_(integer *type__, integer *n, doublecomplex *a, + integer *lda, doublecomplex *b, doublecomplex *x, integer *ldx, + doublecomplex *y, integer *ldy, doublecomplex *alpha, doublecomplex * + beta, doublecomplex *wx, doublecomplex *wy, doublereal *s, doublereal + *dif) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1, + y_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + integer info; + doublecomplex work[26]; + integer i__, j; + doublecomplex z__[64] /* was [8][8] */; + doublereal rwork[50]; + extern /* Subroutine */ int zlakf2_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, doublecomplex *, + doublecomplex *, integer *), zgesvd_(char *, char *, integer *, + integer *, doublecomplex *, integer *, doublereal *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Generate test problem ... */ +/* (Da, Db) ... */ + + /* Parameter adjustments */ + b_dim1 = *lda; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --s; + --dif; + + /* Function Body */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + + if (i__ == j) { + i__3 = i__ + i__ * a_dim1; + z__2.r = (doublereal) i__, z__2.i = 0.; + z__1.r = z__2.r + alpha->r, z__1.i = z__2.i + alpha->i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + i__ * b_dim1; + b[i__3].r = 1., b[i__3].i = 0.; + } else { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; + } + +/* L10: */ + } +/* L20: */ + } + if (*type__ == 2) { + i__1 = a_dim1 + 1; + a[i__1].r = 1., a[i__1].i = 1.; + i__1 = (a_dim1 << 1) + 2; + d_cnjg(&z__1, &a[a_dim1 + 1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = a_dim1 * 3 + 3; + a[i__1].r = 1., a[i__1].i = 0.; + i__1 = (a_dim1 << 2) + 4; + z__2.r = alpha->r + 1., z__2.i = alpha->i + 0.; + d__1 = z__2.r; + z__3.r = beta->r + 1., z__3.i = beta->i + 0.; + d__2 = z__3.r; + z__1.r = d__1, z__1.i = d__2; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = a_dim1 * 5 + 5; + d_cnjg(&z__1, &a[(a_dim1 << 2) + 4]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + +/* Form X and Y */ + + zlacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy); + i__1 = y_dim1 + 3; + d_cnjg(&z__2, wy); + z__1.r = -z__2.r, z__1.i = -z__2.i; + y[i__1].r = z__1.r, y[i__1].i = z__1.i; + i__1 = y_dim1 + 4; + d_cnjg(&z__1, wy); + y[i__1].r = z__1.r, y[i__1].i = z__1.i; + i__1 = y_dim1 + 5; + d_cnjg(&z__2, wy); + z__1.r = -z__2.r, z__1.i = -z__2.i; + y[i__1].r = z__1.r, y[i__1].i = z__1.i; + i__1 = (y_dim1 << 1) + 3; + d_cnjg(&z__2, wy); + z__1.r = -z__2.r, z__1.i = -z__2.i; + y[i__1].r = z__1.r, y[i__1].i = z__1.i; + i__1 = (y_dim1 << 1) + 4; + d_cnjg(&z__1, wy); + y[i__1].r = z__1.r, y[i__1].i = z__1.i; + i__1 = (y_dim1 << 1) + 5; + d_cnjg(&z__2, wy); + z__1.r = -z__2.r, z__1.i = -z__2.i; + y[i__1].r = z__1.r, y[i__1].i = z__1.i; + + zlacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx); + i__1 = x_dim1 * 3 + 1; + z__1.r = -wx->r, z__1.i = -wx->i; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + i__1 = (x_dim1 << 2) + 1; + z__1.r = -wx->r, z__1.i = -wx->i; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + i__1 = x_dim1 * 5 + 1; + x[i__1].r = wx->r, x[i__1].i = wx->i; + i__1 = x_dim1 * 3 + 2; + x[i__1].r = wx->r, x[i__1].i = wx->i; + i__1 = (x_dim1 << 2) + 2; + z__1.r = -wx->r, z__1.i = -wx->i; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + i__1 = x_dim1 * 5 + 2; + z__1.r = -wx->r, z__1.i = -wx->i; + x[i__1].r = z__1.r, x[i__1].i = z__1.i; + +/* Form (A, B) */ + + i__1 = b_dim1 * 3 + 1; + z__1.r = wx->r + wy->r, z__1.i = wx->i + wy->i; + b[i__1].r = z__1.r, b[i__1].i = z__1.i; + i__1 = b_dim1 * 3 + 2; + z__2.r = -wx->r, z__2.i = -wx->i; + z__1.r = z__2.r + wy->r, z__1.i = z__2.i + wy->i; + b[i__1].r = z__1.r, b[i__1].i = z__1.i; + i__1 = (b_dim1 << 2) + 1; + z__1.r = wx->r - wy->r, z__1.i = wx->i - wy->i; + b[i__1].r = z__1.r, b[i__1].i = z__1.i; + i__1 = (b_dim1 << 2) + 2; + z__1.r = wx->r - wy->r, z__1.i = wx->i - wy->i; + b[i__1].r = z__1.r, b[i__1].i = z__1.i; + i__1 = b_dim1 * 5 + 1; + z__2.r = -wx->r, z__2.i = -wx->i; + z__1.r = z__2.r + wy->r, z__1.i = z__2.i + wy->i; + b[i__1].r = z__1.r, b[i__1].i = z__1.i; + i__1 = b_dim1 * 5 + 2; + z__1.r = wx->r + wy->r, z__1.i = wx->i + wy->i; + b[i__1].r = z__1.r, b[i__1].i = z__1.i; + i__1 = a_dim1 * 3 + 1; + i__2 = a_dim1 + 1; + z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2] + .i + wx->i * a[i__2].r; + i__3 = a_dim1 * 3 + 3; + z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = a_dim1 * 3 + 2; + z__3.r = -wx->r, z__3.i = -wx->i; + i__2 = (a_dim1 << 1) + 2; + z__2.r = z__3.r * a[i__2].r - z__3.i * a[i__2].i, z__2.i = z__3.r * a[ + i__2].i + z__3.i * a[i__2].r; + i__3 = a_dim1 * 3 + 3; + z__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__4.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = (a_dim1 << 2) + 1; + i__2 = a_dim1 + 1; + z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2] + .i + wx->i * a[i__2].r; + i__3 = (a_dim1 << 2) + 4; + z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = (a_dim1 << 2) + 2; + i__2 = (a_dim1 << 1) + 2; + z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2] + .i + wx->i * a[i__2].r; + i__3 = (a_dim1 << 2) + 4; + z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = a_dim1 * 5 + 1; + z__3.r = -wx->r, z__3.i = -wx->i; + i__2 = a_dim1 + 1; + z__2.r = z__3.r * a[i__2].r - z__3.i * a[i__2].i, z__2.i = z__3.r * a[ + i__2].i + z__3.i * a[i__2].r; + i__3 = a_dim1 * 5 + 5; + z__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__4.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = a_dim1 * 5 + 2; + i__2 = (a_dim1 << 1) + 2; + z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2] + .i + wx->i * a[i__2].r; + i__3 = a_dim1 * 5 + 5; + z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3] + .i + wy->i * a[i__3].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + +/* Compute condition numbers */ + + s[1] = 1. / sqrt((z_abs(wy) * 3. * z_abs(wy) + 1.) / (z_abs(&a[a_dim1 + 1] + ) * z_abs(&a[a_dim1 + 1]) + 1.)); + s[2] = 1. / sqrt((z_abs(wy) * 3. * z_abs(wy) + 1.) / (z_abs(&a[(a_dim1 << + 1) + 2]) * z_abs(&a[(a_dim1 << 1) + 2]) + 1.)); + s[3] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[a_dim1 * 3 + + 3]) * z_abs(&a[a_dim1 * 3 + 3]) + 1.)); + s[4] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[(a_dim1 << + 2) + 4]) * z_abs(&a[(a_dim1 << 2) + 4]) + 1.)); + s[5] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[a_dim1 * 5 + + 5]) * z_abs(&a[a_dim1 * 5 + 5]) + 1.)); + + zlakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[ + b_offset], &b[(b_dim1 << 1) + 2], z__, &c__8); + zgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1], + &c__1, &work[2], &c__24, &rwork[8], &info); + dif[1] = rwork[7]; + + zlakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[b_offset], + &b[b_dim1 * 5 + 5], z__, &c__8); + zgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1], + &c__1, &work[2], &c__24, &rwork[8], &info); + dif[5] = rwork[7]; + + return 0; + +/* End of ZLATM6 */ + +} /* zlatm6_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlatme.c b/lapack-netlib/TESTING/MATGEN/zlatme.c new file mode 100644 index 000000000..49442ca8d --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlatme.c @@ -0,0 +1,1097 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLATME */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLATME( N, DIST, ISEED, D, MODE, COND, DMAX, */ +/* RSIGN, */ +/* UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, */ +/* A, */ +/* LDA, WORK, INFO ) */ + +/* CHARACTER DIST, RSIGN, SIM, UPPER */ +/* INTEGER INFO, KL, KU, LDA, MODE, MODES, N */ +/* DOUBLE PRECISION ANORM, COND, CONDS */ +/* COMPLEX*16 DMAX */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION DS( * ) */ +/* COMPLEX*16 A( LDA, * ), D( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATME generates random non-symmetric square matrices with */ +/* > specified eigenvalues for testing LAPACK programs. */ +/* > */ +/* > ZLATME operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > 1. Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and RSIGN */ +/* > as described below. */ +/* > */ +/* > 2. If UPPER='T', the upper triangle of A is set to random values */ +/* > out of distribution DIST. */ +/* > */ +/* > 3. If SIM='T', A is multiplied on the left by a random matrix */ +/* > X, whose singular values are specified by DS, MODES, and */ +/* > CONDS, and on the right by X inverse. */ +/* > */ +/* > 4. If KL < N-1, the lower bandwidth is reduced to KL using */ +/* > Householder transformations. If KU < N-1, the upper */ +/* > bandwidth is reduced to KU. */ +/* > */ +/* > 5. If ANORM is not negative, the matrix is scaled to have */ +/* > maximum-element-norm ANORM. */ +/* > */ +/* > (Note: since the matrix cannot be reduced beyond Hessenberg form, */ +/* > no packing options are available.) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns (or rows) of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values, and on the */ +/* > upper triangle (see UPPER). */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > 'D' => uniform on the complex disc |z| < 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to ZLATME */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is COMPLEX*16 array, dimension ( N ) */ +/* > This array is used to specify the eigenvalues of A. If */ +/* > MODE=0, then D is assumed to contain the eigenvalues */ +/* > otherwise they will be computed according to MODE, COND, */ +/* > DMAX, and RSIGN and placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is between 1 and 4, D has entries ranging */ +/* > from 1 to 1/COND, if between -1 and -4, D has entries */ +/* > ranging from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is DOUBLE PRECISION */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is COMPLEX*16 */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))). Note that DMAX need not be */ +/* > positive or real: if DMAX is negative or complex (or zero), */ +/* > D will be scaled by a negative or complex number (or zero). */ +/* > If RSIGN='F' then the largest (absolute) eigenvalue will be */ +/* > equal to DMAX. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RSIGN */ +/* > \verbatim */ +/* > RSIGN is CHARACTER*1 */ +/* > If MODE is not 0, 6, or -6, and RSIGN='T', then the */ +/* > elements of D, as computed according to MODE and COND, will */ +/* > be multiplied by a random complex number from the unit */ +/* > circle |z| = 1. If RSIGN='F', they will not be. RSIGN may */ +/* > only have the values 'T' or 'F'. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPPER */ +/* > \verbatim */ +/* > UPPER is CHARACTER*1 */ +/* > If UPPER='T', then the elements of A above the diagonal */ +/* > will be set to random numbers out of DIST. If UPPER='F', */ +/* > they will not. UPPER may only have the values 'T' or 'F'. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIM */ +/* > \verbatim */ +/* > SIM is CHARACTER*1 */ +/* > If SIM='T', then A will be operated on by a "similarity */ +/* > transform", i.e., multiplied on the left by a matrix X and */ +/* > on the right by X inverse. X = U S V, where U and V are */ +/* > random unitary matrices and S is a (diagonal) matrix of */ +/* > singular values specified by DS, MODES, and CONDS. If */ +/* > SIM='F', then A will not be transformed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DS */ +/* > \verbatim */ +/* > DS is DOUBLE PRECISION array, dimension ( N ) */ +/* > This array is used to specify the singular values of X, */ +/* > in the same way that D specifies the eigenvalues of A. */ +/* > If MODE=0, the DS contains the singular values, which */ +/* > may not be zero. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODES */ +/* > \verbatim */ +/* > MODES is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDS */ +/* > \verbatim */ +/* > CONDS is DOUBLE PRECISION */ +/* > Similar to MODE and COND, but for specifying the diagonal */ +/* > of S. MODES=-6 and +6 are not allowed (since they would */ +/* > result in randomly ill-conditioned eigenvalues.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. KL=1 */ +/* > specifies upper Hessenberg form. If KL is at least N-1, */ +/* > then A will have full lower bandwidth. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. KU=1 */ +/* > specifies lower Hessenberg form. If KU is at least N-1, */ +/* > then A will have full upper bandwidth; if KU and KL */ +/* > are both at least N-1, then A will be dense. Only one of */ +/* > KU and KL may be less than N-1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is DOUBLE PRECISION */ +/* > If ANORM is not negative, then A will be scaled by a non- */ +/* > negative real number to make the maximum-element-norm of A */ +/* > to be ANORM. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. LDA must be at least M. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension ( 3*N ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => N negative */ +/* > -2 => DIST illegal string */ +/* > -5 => MODE not in range -6 to 6 */ +/* > -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -9 => RSIGN is not 'T' or 'F' */ +/* > -10 => UPPER is not 'T' or 'F' */ +/* > -11 => SIM is not 'T' or 'F' */ +/* > -12 => MODES=0 and DS has a zero singular value. */ +/* > -13 => MODES is not in the range -5 to 5. */ +/* > -14 => MODES is nonzero and CONDS is less than 1. */ +/* > -15 => KL is less than 1. */ +/* > -16 => KU is less than 1, or KL and KU are both less than */ +/* > N-1. */ +/* > -19 => LDA is less than M. */ +/* > 1 => Error return from ZLATM1 (computing D) */ +/* > 2 => Cannot scale to DMAX (f2cmax. eigenvalue is 0) */ +/* > 3 => Error return from DLATM1 (computing DS) */ +/* > 4 => Error return from ZLARGE */ +/* > 5 => Zero singular value from DLATM1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlatme_(integer *n, char *dist, integer *iseed, + doublecomplex *d__, integer *mode, doublereal *cond, doublecomplex * + dmax__, char *rsign, char *upper, char *sim, doublereal *ds, integer * + modes, doublereal *conds, integer *kl, integer *ku, doublereal *anorm, + doublecomplex *a, integer *lda, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + logical bads; + integer isim; + doublereal temp; + integer i__, j; + doublecomplex alpha; + extern logical lsame_(char *, char *); + integer iinfo; + doublereal tempa[1]; + integer icols; + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer idist; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer irows; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), dlatm1_(integer *, doublereal *, + integer *, integer *, integer *, doublereal *, integer *, integer + *), zlatm1_(integer *, doublereal *, integer *, integer *, + integer *, doublecomplex *, integer *, integer *); + integer ic, jc, ir; + doublereal ralpha; + extern /* Subroutine */ int xerbla_(char *, integer *); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *), zlarge_(integer *, doublecomplex *, + integer *, integer *, doublecomplex *, integer *), zlarfg_( + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *); + //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, + extern doublecomplex zlarnd_(integer *, + integer *); + integer irsign; + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + integer iupper; + extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *, + doublecomplex *); + doublecomplex xnorms; + integer jcr; + doublecomplex tau; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + --ds; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else if (lsame_(dist, "D")) { + idist = 4; + } else { + idist = -1; + } + +/* Decode RSIGN */ + + if (lsame_(rsign, "T")) { + irsign = 1; + } else if (lsame_(rsign, "F")) { + irsign = 0; + } else { + irsign = -1; + } + +/* Decode UPPER */ + + if (lsame_(upper, "T")) { + iupper = 1; + } else if (lsame_(upper, "F")) { + iupper = 0; + } else { + iupper = -1; + } + +/* Decode SIM */ + + if (lsame_(sim, "T")) { + isim = 1; + } else if (lsame_(sim, "F")) { + isim = 0; + } else { + isim = -1; + } + +/* Check DS, if MODES=0 and ISIM=1 */ + + bads = FALSE_; + if (*modes == 0 && isim == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (ds[j] == 0.) { + bads = TRUE_; + } +/* L10: */ + } + } + +/* Set INFO if an error */ + + if (*n < 0) { + *info = -1; + } else if (idist == -1) { + *info = -2; + } else if (abs(*mode) > 6) { + *info = -5; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) { + *info = -6; + } else if (irsign == -1) { + *info = -9; + } else if (iupper == -1) { + *info = -10; + } else if (isim == -1) { + *info = -11; + } else if (bads) { + *info = -12; + } else if (isim == 1 && abs(*modes) > 5) { + *info = -13; + } else if (isim == 1 && *modes != 0 && *conds < 1.) { + *info = -14; + } else if (*kl < 1) { + *info = -15; + } else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) { + *info = -16; + } else if (*lda < f2cmax(1,*n)) { + *info = -19; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLATME", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L20: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up diagonal of A */ + +/* Compute D according to COND and MODE */ + + zlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = z_abs(&d__[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = temp, d__2 = z_abs(&d__[i__]); + temp = f2cmax(d__1,d__2); +/* L30: */ + } + + if (temp > 0.) { + z__1.r = dmax__->r / temp, z__1.i = dmax__->i / temp; + alpha.r = z__1.r, alpha.i = z__1.i; + } else { + *info = 2; + return 0; + } + + zscal_(n, &alpha, &d__[1], &c__1); + + } + + zlaset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda); + i__1 = *lda + 1; + zcopy_(n, &d__[1], &c__1, &a[a_offset], &i__1); + +/* 3) If UPPER='T', set upper triangle of A to random numbers. */ + + if (iupper != 0) { + i__1 = *n; + for (jc = 2; jc <= i__1; ++jc) { + i__2 = jc - 1; + zlarnv_(&idist, &iseed[1], &i__2, &a[jc * a_dim1 + 1]); +/* L40: */ + } + } + +/* 4) If SIM='T', apply similarity transformation. */ + +/* -1 */ +/* Transform is X A X , where X = U S V, thus */ + +/* it is U S V A V' (1/S) U' */ + + if (isim != 0) { + +/* Compute S (singular values of the eigenvector matrix) */ +/* according to CONDS and MODES */ + + dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo); + if (iinfo != 0) { + *info = 3; + return 0; + } + +/* Multiply by V and V' */ + + zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo); + if (iinfo != 0) { + *info = 4; + return 0; + } + +/* Multiply by S and (1/S) */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + zdscal_(n, &ds[j], &a[j + a_dim1], lda); + if (ds[j] != 0.) { + d__1 = 1. / ds[j]; + zdscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1); + } else { + *info = 5; + return 0; + } +/* L50: */ + } + +/* Multiply by U and U' */ + + zlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo); + if (iinfo != 0) { + *info = 4; + return 0; + } + } + +/* 5) Reduce the bandwidth. */ + + if (*kl < *n - 1) { + +/* Reduce bandwidth -- kill column */ + + i__1 = *n - 1; + for (jcr = *kl + 1; jcr <= i__1; ++jcr) { + ic = jcr - *kl; + irows = *n + 1 - jcr; + icols = *n + *kl - jcr; + + zcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1); + xnorms.r = work[1].r, xnorms.i = work[1].i; + zlarfg_(&irows, &xnorms, &work[2], &c__1, &tau); + d_cnjg(&z__1, &tau); + tau.r = z__1.r, tau.i = z__1.i; + work[1].r = 1., work[1].i = 0.; + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + alpha.r = z__1.r, alpha.i = z__1.i; + + zgemv_("C", &irows, &icols, &c_b2, &a[jcr + (ic + 1) * a_dim1], + lda, &work[1], &c__1, &c_b1, &work[irows + 1], &c__1); + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&irows, &icols, &z__1, &work[1], &c__1, &work[irows + 1], & + c__1, &a[jcr + (ic + 1) * a_dim1], lda); + + zgemv_("N", n, &irows, &c_b2, &a[jcr * a_dim1 + 1], lda, &work[1], + &c__1, &c_b1, &work[irows + 1], &c__1); + d_cnjg(&z__2, &tau); + z__1.r = -z__2.r, z__1.i = -z__2.i; + zgerc_(n, &irows, &z__1, &work[irows + 1], &c__1, &work[1], &c__1, + &a[jcr * a_dim1 + 1], lda); + + i__2 = jcr + ic * a_dim1; + a[i__2].r = xnorms.r, a[i__2].i = xnorms.i; + i__2 = irows - 1; + zlaset_("Full", &i__2, &c__1, &c_b1, &c_b1, &a[jcr + 1 + ic * + a_dim1], lda); + + i__2 = icols + 1; + zscal_(&i__2, &alpha, &a[jcr + ic * a_dim1], lda); + d_cnjg(&z__1, &alpha); + zscal_(n, &z__1, &a[jcr * a_dim1 + 1], &c__1); +/* L60: */ + } + } else if (*ku < *n - 1) { + +/* Reduce upper bandwidth -- kill a row at a time. */ + + i__1 = *n - 1; + for (jcr = *ku + 1; jcr <= i__1; ++jcr) { + ir = jcr - *ku; + irows = *n + *ku - jcr; + icols = *n + 1 - jcr; + + zcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1); + xnorms.r = work[1].r, xnorms.i = work[1].i; + zlarfg_(&icols, &xnorms, &work[2], &c__1, &tau); + d_cnjg(&z__1, &tau); + tau.r = z__1.r, tau.i = z__1.i; + work[1].r = 1., work[1].i = 0.; + i__2 = icols - 1; + zlacgv_(&i__2, &work[2], &c__1); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1 = zlarnd_(&c__5, &iseed[1]); + alpha.r = z__1.r, alpha.i = z__1.i; + + zgemv_("N", &irows, &icols, &c_b2, &a[ir + 1 + jcr * a_dim1], lda, + &work[1], &c__1, &c_b1, &work[icols + 1], &c__1); + z__1.r = -tau.r, z__1.i = -tau.i; + zgerc_(&irows, &icols, &z__1, &work[icols + 1], &c__1, &work[1], & + c__1, &a[ir + 1 + jcr * a_dim1], lda); + + zgemv_("C", &icols, n, &c_b2, &a[jcr + a_dim1], lda, &work[1], & + c__1, &c_b1, &work[icols + 1], &c__1); + d_cnjg(&z__2, &tau); + z__1.r = -z__2.r, z__1.i = -z__2.i; + zgerc_(&icols, n, &z__1, &work[1], &c__1, &work[icols + 1], &c__1, + &a[jcr + a_dim1], lda); + + i__2 = ir + jcr * a_dim1; + a[i__2].r = xnorms.r, a[i__2].i = xnorms.i; + i__2 = icols - 1; + zlaset_("Full", &c__1, &i__2, &c_b1, &c_b1, &a[ir + (jcr + 1) * + a_dim1], lda); + + i__2 = irows + 1; + zscal_(&i__2, &alpha, &a[ir + jcr * a_dim1], &c__1); + d_cnjg(&z__1, &alpha); + zscal_(n, &z__1, &a[jcr + a_dim1], lda); +/* L70: */ + } + } + +/* Scale the matrix to have norm ANORM */ + + if (*anorm >= 0.) { + temp = zlange_("M", n, n, &a[a_offset], lda, tempa); + if (temp > 0.) { + ralpha = *anorm / temp; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + zdscal_(n, &ralpha, &a[j * a_dim1 + 1], &c__1); +/* L80: */ + } + } + } + + return 0; + +/* End of ZLATME */ + +} /* zlatme_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlatmr.c b/lapack-netlib/TESTING/MATGEN/zlatmr.c new file mode 100644 index 000000000..4866c53cd --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlatmr.c @@ -0,0 +1,1984 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLATMR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, */ +/* CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, */ +/* PACK, A, LDA, IWORK, INFO ) */ + +/* CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N */ +/* DOUBLE PRECISION ANORM, COND, CONDL, CONDR, SPARSE */ +/* COMPLEX*16 DMAX */ +/* INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), D( * ), DL( * ), DR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATMR generates random matrices of various types for testing */ +/* > LAPACK programs. */ +/* > */ +/* > ZLATMR operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Generate a matrix A with random entries of distribution DIST */ +/* > which is symmetric if SYM='S', Hermitian if SYM='H', and */ +/* > nonsymmetric if SYM='N'. */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX and RSIGN */ +/* > as described below. */ +/* > */ +/* > Grade the matrix, if desired, from the left and/or right */ +/* > as specified by GRADE. The inputs DL, MODEL, CONDL, DR, */ +/* > MODER and CONDR also determine the grading as described */ +/* > below. */ +/* > */ +/* > Permute, if desired, the rows and/or columns as specified by */ +/* > PIVTNG and IPIVOT. */ +/* > */ +/* > Set random entries to zero, if desired, to get a random sparse */ +/* > matrix as specified by SPARSE. */ +/* > */ +/* > Make A a band matrix, if desired, by zeroing out the matrix */ +/* > outside a band of lower bandwidth KL and upper bandwidth KU. */ +/* > */ +/* > Scale A, if desired, to have maximum entry ANORM. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if symmetric or Hermitian) */ +/* > zero out lower half (if symmetric or Hermitian) */ +/* > store the upper half columnwise (if symmetric or Hermitian */ +/* > or square upper triangular) */ +/* > store the lower half columnwise (if symmetric or Hermitian */ +/* > or square lower triangular) */ +/* > same as upper half rowwise if symmetric */ +/* > same as conjugate upper half rowwise if Hermitian */ +/* > store the lower triangle in banded format */ +/* > (if symmetric or Hermitian) */ +/* > store the upper triangle in banded format */ +/* > (if symmetric or Hermitian) */ +/* > store the entire matrix in banded format */ +/* > */ +/* > Note: If two calls to ZLATMR differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > */ +/* > If two calls to ZLATMR both have full bandwidth (KL = M-1 */ +/* > and KU = N-1), and differ only in the PIVTNG and PACK */ +/* > parameters, then the matrices generated will differ only */ +/* > in the order of the rows and/or columns, and otherwise */ +/* > contain the same data. This consistency cannot be and */ +/* > is not maintained with less than full bandwidth. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > Number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Number of columns of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate a random matrix . */ +/* > 'U' => real and imaginary parts are independent */ +/* > UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => real and imaginary parts are independent */ +/* > UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => real and imaginary parts are independent */ +/* > NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > 'D' => uniform on interior of unit disk ( 'D' for disk ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to ZLATMR */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='S', generated matrix is symmetric. */ +/* > If SYM='H', generated matrix is Hermitian. */ +/* > If SYM='N', generated matrix is nonsymmetric. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > On entry this array specifies the diagonal entries */ +/* > of the diagonal of A. D may either be specified */ +/* > on entry, or set according to MODE and COND as described */ +/* > below. If the matrix is Hermitian, the real part of D */ +/* > will be taken. May be changed on exit if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry describes how D is to be used: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is DOUBLE PRECISION */ +/* > On entry, used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is COMPLEX*16 */ +/* > If MODE neither -6, 0 nor 6, the diagonal is scaled by */ +/* > DMAX / f2cmax(abs(D(i))), so that maximum absolute entry */ +/* > of diagonal is abs(DMAX). If DMAX is complex (or zero), */ +/* > diagonal will be scaled by a complex number (or zero). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RSIGN */ +/* > \verbatim */ +/* > RSIGN is CHARACTER*1 */ +/* > If MODE neither -6, 0 nor 6, specifies sign of diagonal */ +/* > as follows: */ +/* > 'T' => diagonal entries are multiplied by a random complex */ +/* > number uniformly distributed with absolute value 1 */ +/* > 'F' => diagonal unchanged */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GRADE */ +/* > \verbatim */ +/* > GRADE is CHARACTER*1 */ +/* > Specifies grading of matrix as follows: */ +/* > 'N' => no grading */ +/* > 'L' => matrix premultiplied by diag( DL ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'R' => matrix postmultiplied by diag( DR ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'B' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DR ) */ +/* > (only if matrix nonsymmetric) */ +/* > 'H' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( CONJG(DL) ) */ +/* > (only if matrix Hermitian or nonsymmetric) */ +/* > 'S' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by diag( DL ) */ +/* > (only if matrix symmetric or nonsymmetric) */ +/* > 'E' => matrix premultiplied by diag( DL ) and */ +/* > postmultiplied by inv( diag( DL ) ) */ +/* > ( 'S' for similarity ) */ +/* > (only if matrix nonsymmetric) */ +/* > Note: if GRADE='S', then M must equal N. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DL */ +/* > \verbatim */ +/* > DL is COMPLEX*16 array, dimension (M) */ +/* > If MODEL=0, then on entry this array specifies the diagonal */ +/* > entries of a diagonal matrix used as described under GRADE */ +/* > above. If MODEL is not zero, then DL will be set according */ +/* > to MODEL and CONDL, analogous to the way D is set according */ +/* > to MODE and COND (except there is no DMAX parameter for DL). */ +/* > If GRADE='E', then DL cannot have zero entries. */ +/* > Not referenced if GRADE = 'N' or 'R'. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODEL */ +/* > \verbatim */ +/* > MODEL is INTEGER */ +/* > This specifies how the diagonal array DL is to be computed, */ +/* > just as MODE specifies how D is to be computed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDL */ +/* > \verbatim */ +/* > CONDL is DOUBLE PRECISION */ +/* > When MODEL is not zero, this specifies the condition number */ +/* > of the computed DL. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DR */ +/* > \verbatim */ +/* > DR is COMPLEX*16 array, dimension (N) */ +/* > If MODER=0, then on entry this array specifies the diagonal */ +/* > entries of a diagonal matrix used as described under GRADE */ +/* > above. If MODER is not zero, then DR will be set according */ +/* > to MODER and CONDR, analogous to the way D is set according */ +/* > to MODE and COND (except there is no DMAX parameter for DR). */ +/* > Not referenced if GRADE = 'N', 'L', 'H' or 'S'. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODER */ +/* > \verbatim */ +/* > MODER is INTEGER */ +/* > This specifies how the diagonal array DR is to be computed, */ +/* > just as MODE specifies how D is to be computed. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CONDR */ +/* > \verbatim */ +/* > CONDR is DOUBLE PRECISION */ +/* > When MODER is not zero, this specifies the condition number */ +/* > of the computed DR. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVTNG */ +/* > \verbatim */ +/* > PIVTNG is CHARACTER*1 */ +/* > On entry specifies pivoting permutations as follows: */ +/* > 'N' or ' ' => none. */ +/* > 'L' => left or row pivoting (matrix must be nonsymmetric). */ +/* > 'R' => right or column pivoting (matrix must be */ +/* > nonsymmetric). */ +/* > 'B' or 'F' => both or full pivoting, i.e., on both sides. */ +/* > In this case, M must equal N */ +/* > */ +/* > If two calls to ZLATMR both have full bandwidth (KL = M-1 */ +/* > and KU = N-1), and differ only in the PIVTNG and PACK */ +/* > parameters, then the matrices generated will differ only */ +/* > in the order of the rows and/or columns, and otherwise */ +/* > contain the same data. This consistency cannot be */ +/* > maintained with less than full bandwidth. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIVOT */ +/* > \verbatim */ +/* > IPIVOT is INTEGER array, dimension (N or M) */ +/* > This array specifies the permutation used. After the */ +/* > basic matrix is generated, the rows, columns, or both */ +/* > are permuted. If, say, row pivoting is selected, ZLATMR */ +/* > starts with the *last* row and interchanges the M-th and */ +/* > IPIVOT(M)-th rows, then moves to the next-to-last row, */ +/* > interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, */ +/* > and so on. In terms of "2-cycles", the permutation is */ +/* > (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) */ +/* > where the rightmost cycle is applied first. This is the */ +/* > *inverse* of the effect of pivoting in LINPACK. The idea */ +/* > is that factoring (with pivoting) an identity matrix */ +/* > which has been inverse-pivoted in this way should */ +/* > result in a pivot vector identical to IPIVOT. */ +/* > Not referenced if PIVTNG = 'N'. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > On entry specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL at least M-1 implies the matrix is not */ +/* > banded. Must equal KU if matrix is symmetric or Hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > On entry specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU at least N-1 implies the matrix is not */ +/* > banded. Must equal KL if matrix is symmetric or Hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPARSE */ +/* > \verbatim */ +/* > SPARSE is DOUBLE PRECISION */ +/* > On entry specifies the sparsity of the matrix if a sparse */ +/* > matrix is to be generated. SPARSE should lie between */ +/* > 0 and 1. To generate a sparse matrix, for each matrix entry */ +/* > a uniform ( 0, 1 ) random number x is generated and */ +/* > compared to SPARSE; if x is larger the matrix entry */ +/* > is unchanged and if x is smaller the entry is set */ +/* > to zero. Thus on the average a fraction SPARSE of the */ +/* > entries will be set to zero. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is DOUBLE PRECISION */ +/* > On entry specifies maximum entry of output matrix */ +/* > (output matrix will by multiplied by a constant so that */ +/* > its largest absolute entry equal ANORM) */ +/* > if ANORM is nonnegative. If ANORM is negative no scaling */ +/* > is done. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > On entry specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries */ +/* > (if symmetric or Hermitian) */ +/* > 'L' => zero out all superdiagonal entries */ +/* > (if symmetric or Hermitian) */ +/* > 'C' => store the upper triangle columnwise */ +/* > (only if matrix symmetric or Hermitian or */ +/* > square upper triangular) */ +/* > 'R' => store the lower triangle columnwise */ +/* > (only if matrix symmetric or Hermitian or */ +/* > square lower triangular) */ +/* > (same as upper half rowwise if symmetric) */ +/* > (same as conjugate upper half rowwise if Hermitian) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if matrix symmetric or Hermitian) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if matrix symmetric or Hermitian) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, HB or TB - use 'B' or 'Q' */ +/* > PP, HP or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to ZLATMR differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On exit A is the desired test matrix. Only those */ +/* > entries of A which are significant on output */ +/* > will be referenced (even if A is in packed or band */ +/* > storage format). The 'unoccupied corners' of A in */ +/* > band format will be zeroed out. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > on entry LDA specifies the first dimension of A as */ +/* > declared in the calling program. */ +/* > If PACK='N', 'U' or 'L', LDA must be at least f2cmax ( 1, M ). */ +/* > If PACK='C' or 'R', LDA must be at least 1. */ +/* > If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) */ +/* > If PACK='Z', LDA must be at least KUU+KLL+1, where */ +/* > KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, M-1 ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N or M) */ +/* > Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error parameter on exit: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S' or 'H' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string */ +/* > -11 => GRADE illegal string, or GRADE='E' and */ +/* > M not equal to N, or GRADE='L', 'R', 'B', 'S' or 'E' */ +/* > and SYM = 'H', or GRADE='L', 'R', 'B', 'H' or 'E' */ +/* > and SYM = 'S' */ +/* > -12 => GRADE = 'E' and DL contains zero */ +/* > -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', */ +/* > 'S' or 'E' */ +/* > -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', */ +/* > and MODEL neither -6, 0 nor 6 */ +/* > -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' */ +/* > -17 => CONDR less than 1.0, GRADE='R' or 'B', and */ +/* > MODER neither -6, 0 nor 6 */ +/* > -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and */ +/* > M not equal to N, or PIVTNG='L' or 'R' and SYM='S' */ +/* > or 'H' */ +/* > -19 => IPIVOT contains out of range number and */ +/* > PIVTNG not equal to 'N' */ +/* > -20 => KL negative */ +/* > -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL */ +/* > -22 => SPARSE not in range 0. to 1. */ +/* > -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' */ +/* > and SYM='N', or PACK='C' and SYM='N' and either KL */ +/* > not equal to 0 or N not equal to M, or PACK='R' and */ +/* > SYM='N', and either KU not equal to 0 or N not equal */ +/* > to M */ +/* > -26 => LDA too small */ +/* > 1 => Error return from ZLATM1 (computing D) */ +/* > 2 => Cannot scale diagonal to DMAX (f2cmax. entry is 0) */ +/* > 3 => Error return from ZLATM1 (computing DL) */ +/* > 4 => Error return from ZLATM1 (computing DR) */ +/* > 5 => ANORM is positive, but matrix constructed prior to */ +/* > attempting to scale it to have norm ANORM, is zero */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlatmr_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, doublecomplex *d__, integer *mode, doublereal *cond, + doublecomplex *dmax__, char *rsign, char *grade, doublecomplex *dl, + integer *model, doublereal *condl, doublecomplex *dr, integer *moder, + doublereal *condr, char *pivtng, integer *ipivot, integer *kl, + integer *ku, doublereal *sparse, doublereal *anorm, char *pack, + doublecomplex *a, integer *lda, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + integer isub, jsub; + doublereal temp; + integer isym, i__, j, k, ipack; + extern logical lsame_(char *, char *); + doublereal tempa[1]; + doublecomplex ctemp; + integer iisub, idist, jjsub, mnmin; + logical dzero; + integer mnsub; + doublereal onorm; + integer mxsub, npvts; + extern /* Subroutine */ int zlatm1_(integer *, doublereal *, integer *, + integer *, integer *, doublecomplex *, integer *, integer *); + extern /* Double Complex */ VOID zlatm2_(doublecomplex *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, integer *, doublereal *), zlatm3_( + doublecomplex *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *, doublereal *); + doublecomplex calpha; + integer igrade; + logical fulbnd; + extern doublereal zlangb_(char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublereal *); + extern /* Subroutine */ int xerbla_(char *, integer *); + logical badpvt; + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + extern doublereal zlansb_(char *, char *, integer *, integer *, + doublecomplex *, integer *, doublereal *); + integer irsign, ipvtng; + extern doublereal zlansp_(char *, char *, integer *, doublecomplex *, + doublereal *), zlansy_(char *, char *, integer *, + doublecomplex *, integer *, doublereal *); + integer kll, kuu; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + --dl; + --dr; + --ipivot; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --iwork; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else if (lsame_(dist, "D")) { + idist = 4; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "H")) { + isym = 0; + } else if (lsame_(sym, "N")) { + isym = 1; + } else if (lsame_(sym, "S")) { + isym = 2; + } else { + isym = -1; + } + +/* Decode RSIGN */ + + if (lsame_(rsign, "F")) { + irsign = 0; + } else if (lsame_(rsign, "T")) { + irsign = 1; + } else { + irsign = -1; + } + +/* Decode PIVTNG */ + + if (lsame_(pivtng, "N")) { + ipvtng = 0; + } else if (lsame_(pivtng, " ")) { + ipvtng = 0; + } else if (lsame_(pivtng, "L")) { + ipvtng = 1; + npvts = *m; + } else if (lsame_(pivtng, "R")) { + ipvtng = 2; + npvts = *n; + } else if (lsame_(pivtng, "B")) { + ipvtng = 3; + npvts = f2cmin(*n,*m); + } else if (lsame_(pivtng, "F")) { + ipvtng = 3; + npvts = f2cmin(*n,*m); + } else { + ipvtng = -1; + } + +/* Decode GRADE */ + + if (lsame_(grade, "N")) { + igrade = 0; + } else if (lsame_(grade, "L")) { + igrade = 1; + } else if (lsame_(grade, "R")) { + igrade = 2; + } else if (lsame_(grade, "B")) { + igrade = 3; + } else if (lsame_(grade, "E")) { + igrade = 4; + } else if (lsame_(grade, "H")) { + igrade = 5; + } else if (lsame_(grade, "S")) { + igrade = 6; + } else { + igrade = -1; + } + +/* Decode PACK */ + + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + } else if (lsame_(pack, "C")) { + ipack = 3; + } else if (lsame_(pack, "R")) { + ipack = 4; + } else if (lsame_(pack, "B")) { + ipack = 5; + } else if (lsame_(pack, "Q")) { + ipack = 6; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + kll = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + kuu = f2cmin(i__1,i__2); + +/* If inv(DL) is used, check to see if DL has a zero entry. */ + + dzero = FALSE_; + if (igrade == 4 && *model == 0) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + if (dl[i__2].r == 0. && dl[i__2].i == 0.) { + dzero = TRUE_; + } +/* L10: */ + } + } + +/* Check values in IPIVOT */ + + badpvt = FALSE_; + if (ipvtng > 0) { + i__1 = npvts; + for (j = 1; j <= i__1; ++j) { + if (ipivot[j] <= 0 || ipivot[j] > npvts) { + badpvt = TRUE_; + } +/* L20: */ + } + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && (isym == 0 || isym == 2)) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (*mode < -6 || *mode > 6) { + *info = -7; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) { + *info = -8; + } else if (*mode != -6 && *mode != 0 && *mode != 6 && irsign == -1) { + *info = -10; + } else if (igrade == -1 || igrade == 4 && *m != *n || (igrade == 1 || + igrade == 2 || igrade == 3 || igrade == 4 || igrade == 6) && isym + == 0 || (igrade == 1 || igrade == 2 || igrade == 3 || igrade == 4 + || igrade == 5) && isym == 2) { + *info = -11; + } else if (igrade == 4 && dzero) { + *info = -12; + } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 || + igrade == 6) && (*model < -6 || *model > 6)) { + *info = -13; + } else if ((igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 || + igrade == 6) && (*model != -6 && *model != 0 && *model != 6) && * + condl < 1.) { + *info = -14; + } else if ((igrade == 2 || igrade == 3) && (*moder < -6 || *moder > 6)) { + *info = -16; + } else if ((igrade == 2 || igrade == 3) && (*moder != -6 && *moder != 0 && + *moder != 6) && *condr < 1.) { + *info = -17; + } else if (ipvtng == -1 || ipvtng == 3 && *m != *n || (ipvtng == 1 || + ipvtng == 2) && (isym == 0 || isym == 2)) { + *info = -18; + } else if (ipvtng != 0 && badpvt) { + *info = -19; + } else if (*kl < 0) { + *info = -20; + } else if (*ku < 0 || (isym == 0 || isym == 2) && *kl != *ku) { + *info = -21; + } else if (*sparse < 0. || *sparse > 1.) { + *info = -22; + } else if (ipack == -1 || (ipack == 1 || ipack == 2 || ipack == 5 || + ipack == 6) && isym == 1 || ipack == 3 && isym == 1 && (*kl != 0 + || *m != *n) || ipack == 4 && isym == 1 && (*ku != 0 || *m != *n)) + { + *info = -24; + } else if ((ipack == 0 || ipack == 1 || ipack == 2) && *lda < f2cmax(1,*m) || + (ipack == 3 || ipack == 4) && *lda < 1 || (ipack == 5 || ipack == + 6) && *lda < kuu + 1 || ipack == 7 && *lda < kll + kuu + 1) { + *info = -26; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLATMR", &i__1); + return 0; + } + +/* Decide if we can pivot consistently */ + + fulbnd = FALSE_; + if (kuu == *n - 1 && kll == *m - 1) { + fulbnd = TRUE_; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L30: */ + } + + iseed[4] = (iseed[4] / 2 << 1) + 1; + +/* 2) Set up D, DL, and DR, if indicated. */ + +/* Compute D according to COND and MODE */ + + zlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, info); + if (*info != 0) { + *info = 1; + return 0; + } + if (*mode != 0 && *mode != -6 && *mode != 6) { + +/* Scale by DMAX */ + + temp = z_abs(&d__[1]); + i__1 = mnmin; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = temp, d__2 = z_abs(&d__[i__]); + temp = f2cmax(d__1,d__2); +/* L40: */ + } + if (temp == 0. && (dmax__->r != 0. || dmax__->i != 0.)) { + *info = 2; + return 0; + } + if (temp != 0.) { + z__1.r = dmax__->r / temp, z__1.i = dmax__->i / temp; + calpha.r = z__1.r, calpha.i = z__1.i; + } else { + calpha.r = 1., calpha.i = 0.; + } + i__1 = mnmin; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = calpha.r * d__[i__3].r - calpha.i * d__[i__3].i, z__1.i = + calpha.r * d__[i__3].i + calpha.i * d__[i__3].r; + d__[i__2].r = z__1.r, d__[i__2].i = z__1.i; +/* L50: */ + } + + } + +/* If matrix Hermitian, make D real */ + + if (isym == 0) { + i__1 = mnmin; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + d__1 = d__[i__3].r; + d__[i__2].r = d__1, d__[i__2].i = 0.; +/* L60: */ + } + } + +/* Compute DL if grading set */ + + if (igrade == 1 || igrade == 3 || igrade == 4 || igrade == 5 || igrade == + 6) { + zlatm1_(model, condl, &c__0, &idist, &iseed[1], &dl[1], m, info); + if (*info != 0) { + *info = 3; + return 0; + } + } + +/* Compute DR if grading set */ + + if (igrade == 2 || igrade == 3) { + zlatm1_(moder, condr, &c__0, &idist, &iseed[1], &dr[1], n, info); + if (*info != 0) { + *info = 4; + return 0; + } + } + +/* 3) Generate IWORK if pivoting */ + + if (ipvtng > 0) { + i__1 = npvts; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = i__; +/* L70: */ + } + if (fulbnd) { + i__1 = npvts; + for (i__ = 1; i__ <= i__1; ++i__) { + k = ipivot[i__]; + j = iwork[i__]; + iwork[i__] = iwork[k]; + iwork[k] = j; +/* L80: */ + } + } else { + for (i__ = npvts; i__ >= 1; --i__) { + k = ipivot[i__]; + j = iwork[i__]; + iwork[i__] = iwork[k]; + iwork[k] = j; +/* L90: */ + } + } + } + +/* 4) Generate matrices for each kind of PACKing */ +/* Always sweep matrix columnwise (if symmetric, upper */ +/* half only) so that matrix generated does not depend */ +/* on PACK */ + + if (fulbnd) { + +/* Use ZLATM3 so matrices generated with differing PIVOTing only */ +/* differ only in the order of their rows and/or columns. */ + + if (ipack == 0) { + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__3 = isub + jsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + i__3 = jsub + isub * a_dim1; + d_cnjg(&z__1, &ctemp); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L100: */ + } +/* L110: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__3 = isub + jsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; +/* L120: */ + } +/* L130: */ + } + } else if (isym == 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__3 = isub + jsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + i__3 = jsub + isub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; +/* L140: */ + } +/* L150: */ + } + } + + } else if (ipack == 1) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mxsub == isub && isym == 0) { + i__3 = mnsub + mxsub * a_dim1; + d_cnjg(&z__1, &ctemp); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = mnsub + mxsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } + if (mnsub != mxsub) { + i__3 = mxsub + mnsub * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } +/* L160: */ + } +/* L170: */ + } + + } else if (ipack == 2) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mxsub == jsub && isym == 0) { + i__3 = mxsub + mnsub * a_dim1; + d_cnjg(&z__1, &ctemp); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = mxsub + mnsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } + if (mnsub != mxsub) { + i__3 = mnsub + mxsub * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } +/* L180: */ + } +/* L190: */ + } + + } else if (ipack == 3) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + +/* Compute K = location of (ISUB,JSUB) entry in packed */ +/* array */ + + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + k = mxsub * (mxsub - 1) / 2 + mnsub; + +/* Convert K to (IISUB,JJSUB) location */ + + jjsub = (k - 1) / *lda + 1; + iisub = k - *lda * (jjsub - 1); + + if (mxsub == isub && isym == 0) { + i__3 = iisub + jjsub * a_dim1; + d_cnjg(&z__1, &ctemp); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = iisub + jjsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } +/* L200: */ + } +/* L210: */ + } + + } else if (ipack == 4) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + +/* Compute K = location of (I,J) entry in packed array */ + + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mnsub == 1) { + k = mxsub; + } else { + k = *n * (*n + 1) / 2 - (*n - mnsub + 1) * (*n - + mnsub + 2) / 2 + mxsub - mnsub + 1; + } + +/* Convert K to (IISUB,JJSUB) location */ + + jjsub = (k - 1) / *lda + 1; + iisub = k - *lda * (jjsub - 1); + + if (mxsub == jsub && isym == 0) { + i__3 = iisub + jjsub * a_dim1; + d_cnjg(&z__1, &ctemp); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = iisub + jjsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } +/* L220: */ + } +/* L230: */ + } + + } else if (ipack == 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + if (i__ < 1) { + i__3 = j - i__ + 1 + (i__ + *n) * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } else { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mxsub == jsub && isym == 0) { + i__3 = mxsub - mnsub + 1 + mnsub * a_dim1; + d_cnjg(&z__1, &ctemp); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = mxsub - mnsub + 1 + mnsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } + } +/* L240: */ + } +/* L250: */ + } + + } else if (ipack == 6) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (mxsub == isub && isym == 0) { + i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1; + d_cnjg(&z__1, &ctemp); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } +/* L260: */ + } +/* L270: */ + } + + } else if (ipack == 7) { + + if (isym != 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + mnsub = f2cmin(isub,jsub); + mxsub = f2cmax(isub,jsub); + if (i__ < 1) { + i__3 = j - i__ + 1 + kuu + (i__ + *n) * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + if (mxsub == isub && isym == 0) { + i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1; + d_cnjg(&z__1, &ctemp); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = mnsub - mxsub + kuu + 1 + mxsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } + if (i__ >= 1 && mnsub != mxsub) { + if (mnsub == isub && isym == 0) { + i__3 = mxsub - mnsub + 1 + kuu + mnsub * + a_dim1; + d_cnjg(&z__1, &ctemp); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = mxsub - mnsub + 1 + kuu + mnsub * + a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } + } +/* L280: */ + } +/* L290: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + kll; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + zlatm3_(&z__1, m, n, &i__, &j, &isub, &jsub, kl, ku, & + idist, &iseed[1], &d__[1], &igrade, &dl[1], & + dr[1], &ipvtng, &iwork[1], sparse); + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__3 = isub - jsub + kuu + 1 + jsub * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; +/* L300: */ + } +/* L310: */ + } + } + + } + + } else { + +/* Use ZLATM2 */ + + if (ipack == 0) { + if (isym == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = j + i__ * a_dim1; + d_cnjg(&z__1, &a[i__ + j * a_dim1]); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L320: */ + } +/* L330: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L340: */ + } +/* L350: */ + } + } else if (isym == 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = j + i__ * a_dim1; + i__4 = i__ + j * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; +/* L360: */ + } +/* L370: */ + } + } + + } else if (ipack == 1) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1], + &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[ + 1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + if (i__ != j) { + i__3 = j + i__ * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } +/* L380: */ + } +/* L390: */ + } + + } else if (ipack == 2) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + if (isym == 0) { + i__3 = j + i__ * a_dim1; + zlatm2_(&z__2, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + d_cnjg(&z__1, &z__2); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = j + i__ * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + if (i__ != j) { + i__3 = i__ + j * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } +/* L400: */ + } +/* L410: */ + } + + } else if (ipack == 3) { + + isub = 0; + jsub = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++isub; + if (isub > *lda) { + isub = 1; + ++jsub; + } + i__3 = isub + jsub * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1], + &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[ + 1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L420: */ + } +/* L430: */ + } + + } else if (ipack == 4) { + + if (isym == 0 || isym == 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + +/* Compute K = location of (I,J) entry in packed array */ + + if (i__ == 1) { + k = j; + } else { + k = *n * (*n + 1) / 2 - (*n - i__ + 1) * (*n - + i__ + 2) / 2 + j - i__ + 1; + } + +/* Convert K to (ISUB,JSUB) location */ + + jsub = (k - 1) / *lda + 1; + isub = k - *lda * (jsub - 1); + + i__3 = isub + jsub * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + if (isym == 0) { + i__3 = isub + jsub * a_dim1; + d_cnjg(&z__1, &a[isub + jsub * a_dim1]); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } +/* L440: */ + } +/* L450: */ + } + } else { + isub = 0; + jsub = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++isub; + if (isub > *lda) { + isub = 1; + ++jsub; + } + i__3 = isub + jsub * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L460: */ + } +/* L470: */ + } + } + + } else if (ipack == 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + if (i__ < 1) { + i__3 = j - i__ + 1 + (i__ + *n) * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } else { + if (isym == 0) { + i__3 = j - i__ + 1 + i__ * a_dim1; + zlatm2_(&z__2, m, n, &i__, &j, kl, ku, &idist, & + iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + d_cnjg(&z__1, &z__2); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = j - i__ + 1 + i__ * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, & + iseed[1], &d__[1], &igrade, &dl[1], &dr[1] + , &ipvtng, &iwork[1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } +/* L480: */ + } +/* L490: */ + } + + } else if (ipack == 6) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + i__3 = i__ - j + kuu + 1 + j * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[1], + &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, &iwork[ + 1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L500: */ + } +/* L510: */ + } + + } else if (ipack == 7) { + + if (isym != 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + i__3 = i__ - j + kuu + 1 + j * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + if (i__ < 1) { + i__3 = j - i__ + 1 + kuu + (i__ + *n) * a_dim1; + a[i__3].r = 0., a[i__3].i = 0.; + } + if (i__ >= 1 && i__ != j) { + if (isym == 0) { + i__3 = j - i__ + 1 + kuu + i__ * a_dim1; + d_cnjg(&z__1, &a[i__ - j + kuu + 1 + j * + a_dim1]); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } else { + i__3 = j - i__ + 1 + kuu + i__ * a_dim1; + i__4 = i__ - j + kuu + 1 + j * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + } + } +/* L520: */ + } +/* L530: */ + } + } else if (isym == 1) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + kll; + for (i__ = j - kuu; i__ <= i__2; ++i__) { + i__3 = i__ - j + kuu + 1 + j * a_dim1; + zlatm2_(&z__1, m, n, &i__, &j, kl, ku, &idist, &iseed[ + 1], &d__[1], &igrade, &dl[1], &dr[1], &ipvtng, + &iwork[1], sparse); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L540: */ + } +/* L550: */ + } + } + + } + + } + +/* 5) Scaling the norm */ + + if (ipack == 0) { + onorm = zlange_("M", m, n, &a[a_offset], lda, tempa); + } else if (ipack == 1) { + onorm = zlansy_("M", "U", n, &a[a_offset], lda, tempa); + } else if (ipack == 2) { + onorm = zlansy_("M", "L", n, &a[a_offset], lda, tempa); + } else if (ipack == 3) { + onorm = zlansp_("M", "U", n, &a[a_offset], tempa); + } else if (ipack == 4) { + onorm = zlansp_("M", "L", n, &a[a_offset], tempa); + } else if (ipack == 5) { + onorm = zlansb_("M", "L", n, &kll, &a[a_offset], lda, tempa); + } else if (ipack == 6) { + onorm = zlansb_("M", "U", n, &kuu, &a[a_offset], lda, tempa); + } else if (ipack == 7) { + onorm = zlangb_("M", n, &kll, &kuu, &a[a_offset], lda, tempa); + } + + if (*anorm >= 0.) { + + if (*anorm > 0. && onorm == 0.) { + +/* Desired scaling impossible */ + + *info = 5; + return 0; + + } else if (*anorm > 1. && onorm < 1. || *anorm < 1. && onorm > 1.) { + +/* Scale carefully to avoid over / underflow */ + + if (ipack <= 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + d__1 = 1. / onorm; + zdscal_(m, &d__1, &a[j * a_dim1 + 1], &c__1); + zdscal_(m, anorm, &a[j * a_dim1 + 1], &c__1); +/* L560: */ + } + + } else if (ipack == 3 || ipack == 4) { + + i__1 = *n * (*n + 1) / 2; + d__1 = 1. / onorm; + zdscal_(&i__1, &d__1, &a[a_offset], &c__1); + i__1 = *n * (*n + 1) / 2; + zdscal_(&i__1, anorm, &a[a_offset], &c__1); + + } else if (ipack >= 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = kll + kuu + 1; + d__1 = 1. / onorm; + zdscal_(&i__2, &d__1, &a[j * a_dim1 + 1], &c__1); + i__2 = kll + kuu + 1; + zdscal_(&i__2, anorm, &a[j * a_dim1 + 1], &c__1); +/* L570: */ + } + + } + + } else { + +/* Scale straightforwardly */ + + if (ipack <= 2) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + d__1 = *anorm / onorm; + zdscal_(m, &d__1, &a[j * a_dim1 + 1], &c__1); +/* L580: */ + } + + } else if (ipack == 3 || ipack == 4) { + + i__1 = *n * (*n + 1) / 2; + d__1 = *anorm / onorm; + zdscal_(&i__1, &d__1, &a[a_offset], &c__1); + + } else if (ipack >= 5) { + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = kll + kuu + 1; + d__1 = *anorm / onorm; + zdscal_(&i__2, &d__1, &a[j * a_dim1 + 1], &c__1); +/* L590: */ + } + } + + } + + } + +/* End of ZLATMR */ + + return 0; +} /* zlatmr_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlatms.c b/lapack-netlib/TESTING/MATGEN/zlatms.c new file mode 100644 index 000000000..a8899b3cc --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlatms.c @@ -0,0 +1,2096 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLATMS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* KL, KU, PACK, A, LDA, WORK, INFO ) */ + +/* CHARACTER DIST, PACK, SYM */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, N */ +/* DOUBLE PRECISION COND, DMAX */ +/* INTEGER ISEED( 4 ) */ +/* DOUBLE PRECISION D( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATMS generates random matrices with specified singular values */ +/* > (or hermitian with specified eigenvalues) */ +/* > for testing LAPACK programs. */ +/* > */ +/* > ZLATMS operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and SYM */ +/* > as described below. */ +/* > */ +/* > Generate a matrix with the appropriate band structure, by one */ +/* > of two methods: */ +/* > */ +/* > Method A: */ +/* > Generate a dense M x N matrix by multiplying D on the left */ +/* > and the right by random unitary matrices, then: */ +/* > */ +/* > Reduce the bandwidth according to KL and KU, using */ +/* > Householder transformations. */ +/* > */ +/* > Method B: */ +/* > Convert the bandwidth-0 (i.e., diagonal) matrix to a */ +/* > bandwidth-1 matrix using Givens rotations, "chasing" */ +/* > out-of-band elements back, much as in QR; then convert */ +/* > the bandwidth-1 to a bandwidth-2 matrix, etc. Note */ +/* > that for reasonably small bandwidths (relative to M and */ +/* > N) this requires less storage, as a dense matrix is not */ +/* > generated. Also, for hermitian or symmetric matrices, */ +/* > only one triangle is generated. */ +/* > */ +/* > Method A is chosen if the bandwidth is a large fraction of the */ +/* > order of the matrix, and LDA is at least M (so a dense */ +/* > matrix can be stored.) Method B is chosen if the bandwidth */ +/* > is small (< 1/2 N for hermitian or symmetric, < .3 N+M for */ +/* > non-symmetric), or LDA is less than M and not less than the */ +/* > bandwidth. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if hermitian) */ +/* > zero out lower half (if hermitian) */ +/* > store the upper half columnwise (if hermitian or upper */ +/* > triangular) */ +/* > store the lower half columnwise (if hermitian or lower */ +/* > triangular) */ +/* > store the lower triangle in banded format (if hermitian or */ +/* > lower triangular) */ +/* > store the upper triangle in banded format (if hermitian or */ +/* > upper triangular) */ +/* > store the entire matrix in banded format */ +/* > If Method B is chosen, and band format is specified, then the */ +/* > matrix will be generated in the band format, so no repacking */ +/* > will be necessary. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of A. N must equal M if the matrix */ +/* > is symmetric or hermitian (i.e., if SYM is not 'N') */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values. */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to ZLATMS */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='H', the generated matrix is hermitian, with */ +/* > eigenvalues specified by D, COND, MODE, and DMAX; they */ +/* > may be positive, negative, or zero. */ +/* > If SYM='P', the generated matrix is hermitian, with */ +/* > eigenvalues (= singular values) specified by D, COND, */ +/* > MODE, and DMAX; they will not be negative. */ +/* > If SYM='N', the generated matrix is nonsymmetric, with */ +/* > singular values specified by D, COND, MODE, and DMAX; */ +/* > they will not be negative. */ +/* > If SYM='S', the generated matrix is (complex) symmetric, */ +/* > with singular values specified by D, COND, MODE, and */ +/* > DMAX; they will not be negative. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension ( MIN( M, N ) ) */ +/* > This array is used to specify the singular values or */ +/* > eigenvalues of A (see SYM, above.) If MODE=0, then D is */ +/* > assumed to contain the singular/eigenvalues, otherwise */ +/* > they will be computed according to MODE, COND, and DMAX, */ +/* > and placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the singular/eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */ +/* > MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > If SYM='H', and MODE is neither 0, 6, nor -6, then */ +/* > the elements of D will also be multiplied by a random */ +/* > sign (i.e., +1 or -1.) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is DOUBLE PRECISION */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is DOUBLE PRECISION */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))); thus, the maximum absolute eigen- or */ +/* > singular value (which is to say the norm) will be abs(DMAX). */ +/* > Note that DMAX need not be positive: if DMAX is negative */ +/* > (or zero), D will be scaled by a negative number (or zero). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL being at least M-1 means that the matrix */ +/* > has full lower bandwidth. KL must equal KU if the matrix */ +/* > is symmetric or hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU being at least N-1 means that the matrix */ +/* > has full upper bandwidth. KL must equal KU if the matrix */ +/* > is symmetric or hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > This specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries (if symmetric */ +/* > or hermitian) */ +/* > 'L' => zero out all superdiagonal entries (if symmetric */ +/* > or hermitian) */ +/* > 'C' => store the upper triangle columnwise (only if the */ +/* > matrix is symmetric, hermitian, or upper triangular) */ +/* > 'R' => store the lower triangle columnwise (only if the */ +/* > matrix is symmetric, hermitian, or lower triangular) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if the matrix is symmetric, hermitian, or */ +/* > lower triangular) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if the matrix is symmetric, hermitian, or */ +/* > upper triangular) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, SB, HB, or TB - use 'B' or 'Q' */ +/* > PP, SP, HB, or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to ZLATMS differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. A is first generated */ +/* > in full (unpacked) form, and then packed, if so specified */ +/* > by PACK. Thus, the first M elements of the first N */ +/* > columns will always be modified. If PACK specifies a */ +/* > packed or banded storage scheme, all LDA elements of the */ +/* > first N columns will be modified; the elements of the */ +/* > array which do not correspond to elements of the generated */ +/* > matrix are set to zero. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */ +/* > LDA must be at least M. If PACK='B' or 'Q', then LDA must */ +/* > be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */ +/* > If PACK='Z', LDA must be large enough to hold the packed */ +/* > array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension ( 3*MAX( N, M ) ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => KL negative */ +/* > -11 => KU negative, or SYM is not 'N' and KU is not equal to */ +/* > KL */ +/* > -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */ +/* > or PACK='C' or 'Q' and SYM='N' and KL is not zero; */ +/* > or PACK='R' or 'B' and SYM='N' and KU is not zero; */ +/* > or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */ +/* > N. */ +/* > -14 => LDA is less than M, or PACK='Z' and LDA is less than */ +/* > MIN(KU,N-1) + MIN(KL,M-1) + 1. */ +/* > 1 => Error return from DLATM1 */ +/* > 2 => Cannot scale to DMAX (f2cmax. sing. value is 0) */ +/* > 3 => Error return from ZLAGGE, CLAGHE or CLAGSY */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlatms_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond, + doublereal *dmax__, integer *kl, integer *ku, char *pack, + doublecomplex *a, integer *lda, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1, d__2, d__3; + doublecomplex z__1, z__2, z__3; + logical L__1; + + /* Local variables */ + integer ilda, icol; + doublereal temp; + integer irow, isym; + logical zsym; + doublecomplex c__; + integer i__, j, k; + doublecomplex s; + doublereal alpha, angle; + integer ipack; + doublereal realc; + integer ioffg; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + integer iinfo; + doublecomplex ctemp; + integer idist, mnmin, iskew; + doublecomplex extra, dummy; + extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *, + integer *, integer *, doublereal *, integer *, integer *); + integer ic, jc, nc, il; + doublecomplex ct; + integer iendch, ir, jr, ipackg, mr, minlda; + extern doublereal dlarnd_(integer *, integer *); + doublecomplex st; + extern /* Subroutine */ int zlagge_(integer *, integer *, integer *, + integer *, doublereal *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *), zlaghe_(integer *, integer *, + doublereal *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *), xerbla_(char *, integer *); + logical iltemp, givens; + integer ioffst, irsign; + //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, + extern doublecomplex zlarnd_(integer *, + integer *); + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlartg_(doublecomplex *, doublecomplex *, doublereal *, + doublecomplex *, doublecomplex *); + logical ilextr; + extern /* Subroutine */ int zlagsy_(integer *, integer *, doublereal *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *) + ; + logical topdwn; + integer ir1, ir2, isympk; + extern /* Subroutine */ int zlarot_(logical *, logical *, logical *, + integer *, doublecomplex *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *); + integer jch, llb, jkl, jku, uub; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "N")) { + isym = 1; + irsign = 0; + zsym = FALSE_; + } else if (lsame_(sym, "P")) { + isym = 2; + irsign = 0; + zsym = FALSE_; + } else if (lsame_(sym, "S")) { + isym = 2; + irsign = 0; + zsym = TRUE_; + } else if (lsame_(sym, "H")) { + isym = 2; + irsign = 1; + zsym = FALSE_; + } else { + isym = -1; + } + +/* Decode PACK */ + + isympk = 0; + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + isympk = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + isympk = 1; + } else if (lsame_(pack, "C")) { + ipack = 3; + isympk = 2; + } else if (lsame_(pack, "R")) { + ipack = 4; + isympk = 3; + } else if (lsame_(pack, "B")) { + ipack = 5; + isympk = 3; + } else if (lsame_(pack, "Q")) { + ipack = 6; + isympk = 2; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + llb = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + uub = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *m, i__2 = *n + llb; + mr = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *n, i__2 = *m + uub; + nc = f2cmin(i__1,i__2); + + if (ipack == 5 || ipack == 6) { + minlda = uub + 1; + } else if (ipack == 7) { + minlda = llb + uub + 1; + } else { + minlda = *m; + } + +/* Use Givens rotation method if bandwidth small enough, */ +/* or if LDA is too small to store the matrix unpacked. */ + + givens = FALSE_; + if (isym == 1) { +/* Computing MAX */ + i__1 = 1, i__2 = mr + nc; + if ((doublereal) (llb + uub) < (doublereal) f2cmax(i__1,i__2) * .3) { + givens = TRUE_; + } + } else { + if (llb << 1 < *m) { + givens = TRUE_; + } + } + if (*lda < *m && *lda >= minlda) { + givens = TRUE_; + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && isym != 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (abs(*mode) > 6) { + *info = -7; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) { + *info = -8; + } else if (*kl < 0) { + *info = -10; + } else if (*ku < 0 || isym != 1 && *kl != *ku) { + *info = -11; + } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym + == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk + != 0 && *m != *n) { + *info = -12; + } else if (*lda < f2cmax(1,minlda)) { + *info = -14; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLATMS", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L10: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up D if indicated. */ + +/* Compute D according to COND and MODE */ + + dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, &iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + +/* Choose Top-Down if D is (apparently) increasing, */ +/* Bottom-Up if D is (apparently) decreasing. */ + + if (abs(d__[1]) <= (d__1 = d__[mnmin], abs(d__1))) { + topdwn = TRUE_; + } else { + topdwn = FALSE_; + } + + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = mnmin; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L20: */ + } + + if (temp > 0.) { + alpha = *dmax__ / temp; + } else { + *info = 2; + return 0; + } + + dscal_(&mnmin, &alpha, &d__[1], &c__1); + + } + + zlaset_("Full", lda, n, &c_b1, &c_b1, &a[a_offset], lda); + +/* 3) Generate Banded Matrix using Givens rotations. */ +/* Also the special case of UUB=LLB=0 */ + +/* Compute Addressing constants to cover all */ +/* storage formats. Whether GE, HE, SY, GB, HB, or SB, */ +/* upper or lower triangle or both, */ +/* the (i,j)-th element is in */ +/* A( i - ISKEW*j + IOFFST, j ) */ + + if (ipack > 4) { + ilda = *lda - 1; + iskew = 1; + if (ipack > 5) { + ioffst = uub + 1; + } else { + ioffst = 1; + } + } else { + ilda = *lda; + iskew = 0; + ioffst = 0; + } + +/* IPACKG is the format that the matrix is generated in. If this is */ +/* different from IPACK, then the matrix must be repacked at the */ +/* end. It also signals how to compute the norm, for scaling. */ + + ipackg = 0; + +/* Diagonal Matrix -- We are done, unless it */ +/* is to be stored HP/SP/PP/TP (PACK='R' or 'C') */ + + if (llb == 0 && uub == 0) { + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__2 = (1 - iskew) * j + ioffst + j * a_dim1; + i__3 = j; + z__1.r = d__[i__3], z__1.i = 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L30: */ + } + + if (ipack <= 2 || ipack >= 5) { + ipackg = ipack; + } + + } else if (givens) { + +/* Check whether to use Givens rotations, */ +/* Householder transformations, or nothing. */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + if (ipack > 4) { + ipackg = ipack; + } else { + ipackg = 0; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__2 = (1 - iskew) * j + ioffst + j * a_dim1; + i__3 = j; + z__1.r = d__[i__3], z__1.i = 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L40: */ + } + + if (topdwn) { + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* Last row actually rotated is M */ +/* Last column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__3 = *m + jku; + i__2 = f2cmin(i__3,*n) + jkl - 1; + for (jr = 1; jr <= i__2; ++jr) { + extra.r = 0., extra.i = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; +/* Computing MAX */ + i__3 = 1, i__4 = jr - jkl; + icol = f2cmax(i__3,i__4); + if (jr < *m) { +/* Computing MIN */ + i__3 = *n, i__4 = jr + jku; + il = f2cmin(i__3,i__4) + 1 - icol; + L__1 = jr > jkl; + zlarot_(&c_true, &L__1, &c_false, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ir = jr; + ic = icol; + i__3 = -jkl - jku; + for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ir < *m) { + zlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &realc, + &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__2.r = realc * dummy.r, z__2.i = realc * + dummy.i; + d_cnjg(&z__1, &z__2); + c__.r = z__1.r, c__.i = z__1.i; + z__3.r = -s.r, z__3.i = -s.i; + z__2.r = z__3.r * dummy.r - z__3.i * dummy.i, + z__2.i = z__3.r * dummy.i + z__3.i * + dummy.r; + d_cnjg(&z__1, &z__2); + s.r = z__1.r, s.i = z__1.i; + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + ctemp.r = 0., ctemp.i = 0.; + iltemp = jch > jku; + zlarot_(&c_false, &iltemp, &c_true, &il, &c__, &s, + &a[irow - iskew * ic + ioffst + ic * + a_dim1], &ilda, &ctemp, &extra); + if (iltemp) { + zlartg_(&a[irow + 1 - iskew * (ic + 1) + + ioffst + (ic + 1) * a_dim1], &ctemp, & + realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__2.r = realc * dummy.r, z__2.i = realc * + dummy.i; + d_cnjg(&z__1, &z__2); + c__.r = z__1.r, c__.i = z__1.i; + z__3.r = -s.r, z__3.i = -s.i; + z__2.r = z__3.r * dummy.r - z__3.i * dummy.i, + z__2.i = z__3.r * dummy.i + z__3.i * + dummy.r; + d_cnjg(&z__1, &z__2); + s.r = z__1.r, s.i = z__1.i; + +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + extra.r = 0., extra.i = 0.; + L__1 = jch > jku + jkl; + zlarot_(&c_true, &L__1, &c_true, &il, &c__, & + s, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, &ctemp) + ; + ic = icol; + ir = irow; + } +/* L50: */ + } +/* L60: */ + } +/* L70: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* Computing MIN */ + i__3 = *n + jkl; + i__2 = f2cmin(i__3,*m) + jku - 1; + for (jc = 1; jc <= i__2; ++jc) { + extra.r = 0., extra.i = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; +/* Computing MAX */ + i__3 = 1, i__4 = jc - jku; + irow = f2cmax(i__3,i__4); + if (jc < *n) { +/* Computing MIN */ + i__3 = *m, i__4 = jc + jkl; + il = f2cmin(i__3,i__4) + 1 - irow; + L__1 = jc > jku; + zlarot_(&c_false, &L__1, &c_false, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ic = jc; + ir = irow; + i__3 = -jkl - jku; + for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ic < *n) { + zlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &realc, + &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__2.r = realc * dummy.r, z__2.i = realc * + dummy.i; + d_cnjg(&z__1, &z__2); + c__.r = z__1.r, c__.i = z__1.i; + z__3.r = -s.r, z__3.i = -s.i; + z__2.r = z__3.r * dummy.r - z__3.i * dummy.i, + z__2.i = z__3.r * dummy.i + z__3.i * + dummy.r; + d_cnjg(&z__1, &z__2); + s.r = z__1.r, s.i = z__1.i; + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + ctemp.r = 0., ctemp.i = 0.; + iltemp = jch > jkl; + zlarot_(&c_true, &iltemp, &c_true, &il, &c__, &s, + &a[ir - iskew * icol + ioffst + icol * + a_dim1], &ilda, &ctemp, &extra); + if (iltemp) { + zlartg_(&a[ir + 1 - iskew * (icol + 1) + + ioffst + (icol + 1) * a_dim1], &ctemp, + &realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__2.r = realc * dummy.r, z__2.i = realc * + dummy.i; + d_cnjg(&z__1, &z__2); + c__.r = z__1.r, c__.i = z__1.i; + z__3.r = -s.r, z__3.i = -s.i; + z__2.r = z__3.r * dummy.r - z__3.i * dummy.i, + z__2.i = z__3.r * dummy.i + z__3.i * + dummy.r; + d_cnjg(&z__1, &z__2); + s.r = z__1.r, s.i = z__1.i; +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + extra.r = 0., extra.i = 0.; + L__1 = jch > jkl + jku; + zlarot_(&c_false, &L__1, &c_true, &il, &c__, & + s, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, &ctemp) + ; + ic = icol; + ir = irow; + } +/* L80: */ + } +/* L90: */ + } +/* L100: */ + } + + } else { + +/* Bottom-Up -- Start at the bottom right. */ + + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* First row actually rotated is M */ +/* First column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n + jkl; + iendch = f2cmin(i__2,i__3) - 1; +/* Computing MIN */ + i__2 = *m + jku; + i__3 = 1 - jkl; + for (jc = f2cmin(i__2,*n) - 1; jc >= i__3; --jc) { + extra.r = 0., extra.i = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; +/* Computing MAX */ + i__2 = 1, i__4 = jc - jku + 1; + irow = f2cmax(i__2,i__4); + if (jc > 0) { +/* Computing MIN */ + i__2 = *m, i__4 = jc + jkl + 1; + il = f2cmin(i__2,i__4) + 1 - irow; + L__1 = jc + jkl < *m; + zlarot_(&c_false, &c_false, &L__1, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ic = jc; + i__2 = iendch; + i__4 = jkl + jku; + for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <= + i__2; jch += i__4) { + ilextr = ic > 0; + if (ilextr) { + zlartg_(&a[jch - iskew * ic + ioffst + ic * + a_dim1], &extra, &realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__1.r = realc * dummy.r, z__1.i = realc * + dummy.i; + c__.r = z__1.r, c__.i = z__1.i; + z__1.r = s.r * dummy.r - s.i * dummy.i, + z__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = z__1.r, s.i = z__1.i; + } + ic = f2cmax(1,ic); +/* Computing MIN */ + i__5 = *n - 1, i__6 = jch + jku; + icol = f2cmin(i__5,i__6); + iltemp = jch + jku < *n; + ctemp.r = 0., ctemp.i = 0.; + i__5 = icol + 2 - ic; + zlarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, & + s, &a[jch - iskew * ic + ioffst + ic * + a_dim1], &ilda, &extra, &ctemp); + if (iltemp) { + zlartg_(&a[jch - iskew * icol + ioffst + icol + * a_dim1], &ctemp, &realc, &s, &dummy) + ; + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__1.r = realc * dummy.r, z__1.i = realc * + dummy.i; + c__.r = z__1.r, c__.i = z__1.i; + z__1.r = s.r * dummy.r - s.i * dummy.i, + z__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = z__1.r, s.i = z__1.i; +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra.r = 0., extra.i = 0.; + L__1 = jch + jkl + jku <= iendch; + zlarot_(&c_false, &c_true, &L__1, &il, &c__, & + s, &a[jch - iskew * icol + ioffst + + icol * a_dim1], &ilda, &ctemp, &extra) + ; + ic = icol; + } +/* L110: */ + } +/* L120: */ + } +/* L130: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* First row actually rotated is MIN( N+JKL, M ) */ +/* First column actually rotated is N */ + +/* Computing MIN */ + i__3 = *n, i__4 = *m + jku; + iendch = f2cmin(i__3,i__4) - 1; +/* Computing MIN */ + i__3 = *n + jkl; + i__4 = 1 - jku; + for (jr = f2cmin(i__3,*m) - 1; jr >= i__4; --jr) { + extra.r = 0., extra.i = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; +/* Computing MAX */ + i__3 = 1, i__2 = jr - jkl + 1; + icol = f2cmax(i__3,i__2); + if (jr > 0) { +/* Computing MIN */ + i__3 = *n, i__2 = jr + jku + 1; + il = f2cmin(i__3,i__2) + 1 - icol; + L__1 = jr + jku < *n; + zlarot_(&c_true, &c_false, &L__1, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ir = jr; + i__3 = iendch; + i__2 = jkl + jku; + for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <= + i__3; jch += i__2) { + ilextr = ir > 0; + if (ilextr) { + zlartg_(&a[ir - iskew * jch + ioffst + jch * + a_dim1], &extra, &realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__1.r = realc * dummy.r, z__1.i = realc * + dummy.i; + c__.r = z__1.r, c__.i = z__1.i; + z__1.r = s.r * dummy.r - s.i * dummy.i, + z__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = z__1.r, s.i = z__1.i; + } + ir = f2cmax(1,ir); +/* Computing MIN */ + i__5 = *m - 1, i__6 = jch + jkl; + irow = f2cmin(i__5,i__6); + iltemp = jch + jkl < *m; + ctemp.r = 0., ctemp.i = 0.; + i__5 = irow + 2 - ir; + zlarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, & + s, &a[ir - iskew * jch + ioffst + jch * + a_dim1], &ilda, &extra, &ctemp); + if (iltemp) { + zlartg_(&a[irow - iskew * jch + ioffst + jch * + a_dim1], &ctemp, &realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__1.r = realc * dummy.r, z__1.i = realc * + dummy.i; + c__.r = z__1.r, c__.i = z__1.i; + z__1.r = s.r * dummy.r - s.i * dummy.i, + z__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = z__1.r, s.i = z__1.i; +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra.r = 0., extra.i = 0.; + L__1 = jch + jkl + jku <= iendch; + zlarot_(&c_true, &c_true, &L__1, &il, &c__, & + s, &a[irow - iskew * jch + ioffst + + jch * a_dim1], &ilda, &ctemp, &extra); + ir = irow; + } +/* L140: */ + } +/* L150: */ + } +/* L160: */ + } + + } + + } else { + +/* Symmetric -- A = U D U' */ +/* Hermitian -- A = U D U* */ + + ipackg = ipack; + ioffg = ioffst; + + if (topdwn) { + +/* Top-Down -- Generate Upper triangle only */ + + if (ipack >= 5) { + ipackg = 6; + ioffg = uub + 1; + } else { + ipackg = 1; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__4 = (1 - iskew) * j + ioffg + j * a_dim1; + i__2 = j; + z__1.r = d__[i__2], z__1.i = 0.; + a[i__4].r = z__1.r, a[i__4].i = z__1.i; +/* L170: */ + } + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + i__4 = *n - 1; + for (jc = 1; jc <= i__4; ++jc) { +/* Computing MAX */ + i__2 = 1, i__3 = jc - k; + irow = f2cmax(i__2,i__3); +/* Computing MIN */ + i__2 = jc + 1, i__3 = k + 2; + il = f2cmin(i__2,i__3); + extra.r = 0., extra.i = 0.; + i__2 = jc - iskew * (jc + 1) + ioffg + (jc + 1) * + a_dim1; + ctemp.r = a[i__2].r, ctemp.i = a[i__2].i; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; + if (zsym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + d_cnjg(&z__1, &ctemp); + ctemp.r = z__1.r, ctemp.i = z__1.i; + d_cnjg(&z__1, &c__); + ct.r = z__1.r, ct.i = z__1.i; + d_cnjg(&z__1, &s); + st.r = z__1.r, st.i = z__1.i; + } + L__1 = jc > k; + zlarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[ + irow - iskew * jc + ioffg + jc * a_dim1], & + ilda, &extra, &ctemp); +/* Computing MIN */ + i__3 = k, i__5 = *n - jc; + i__2 = f2cmin(i__3,i__5) + 1; + zlarot_(&c_true, &c_true, &c_false, &i__2, &ct, &st, & + a[(1 - iskew) * jc + ioffg + jc * a_dim1], & + ilda, &ctemp, &dummy); + +/* Chase EXTRA back up the matrix */ + + icol = jc; + i__2 = -k; + for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1; + jch += i__2) { + zlartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg + + (icol + 1) * a_dim1], &extra, &realc, &s, + &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__2.r = realc * dummy.r, z__2.i = realc * + dummy.i; + d_cnjg(&z__1, &z__2); + c__.r = z__1.r, c__.i = z__1.i; + z__3.r = -s.r, z__3.i = -s.i; + z__2.r = z__3.r * dummy.r - z__3.i * dummy.i, + z__2.i = z__3.r * dummy.i + z__3.i * + dummy.r; + d_cnjg(&z__1, &z__2); + s.r = z__1.r, s.i = z__1.i; + i__3 = jch - iskew * (jch + 1) + ioffg + (jch + 1) + * a_dim1; + ctemp.r = a[i__3].r, ctemp.i = a[i__3].i; + if (zsym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + d_cnjg(&z__1, &ctemp); + ctemp.r = z__1.r, ctemp.i = z__1.i; + d_cnjg(&z__1, &c__); + ct.r = z__1.r, ct.i = z__1.i; + d_cnjg(&z__1, &s); + st.r = z__1.r, st.i = z__1.i; + } + i__3 = k + 2; + zlarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &ctemp, &extra); +/* Computing MAX */ + i__3 = 1, i__5 = jch - k; + irow = f2cmax(i__3,i__5); +/* Computing MIN */ + i__3 = jch + 1, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra.r = 0., extra.i = 0.; + L__1 = jch > k; + zlarot_(&c_false, &L__1, &c_true, &il, &ct, &st, & + a[irow - iskew * jch + ioffg + jch * + a_dim1], &ilda, &extra, &ctemp); + icol = jch; +/* L180: */ + } +/* L190: */ + } +/* L200: */ + } + +/* If we need lower triangle, copy from upper. Note that */ +/* the order of copying is chosen to work for 'q' -> 'b' */ + + if (ipack != ipackg && ipack != 3) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst - iskew * jc; + if (zsym) { +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + i__2 = jr + irow + jc * a_dim1; + i__3 = jc - iskew * jr + ioffg + jr * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; +/* L210: */ + } + } else { +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + i__2 = jr + irow + jc * a_dim1; + d_cnjg(&z__1, &a[jc - iskew * jr + ioffg + jr + * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L220: */ + } + } +/* L230: */ + } + if (ipack == 5) { + i__1 = *n; + for (jc = *n - uub + 1; jc <= i__1; ++jc) { + i__4 = uub + 1; + for (jr = *n + 2 - jc; jr <= i__4; ++jr) { + i__2 = jr + jc * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; +/* L240: */ + } +/* L250: */ + } + } + if (ipackg == 6) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } else { + +/* Bottom-Up -- Generate Lower triangle only */ + + if (ipack >= 5) { + ipackg = 5; + if (ipack == 6) { + ioffg = 1; + } + } else { + ipackg = 2; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__4 = (1 - iskew) * j + ioffg + j * a_dim1; + i__2 = j; + z__1.r = d__[i__2], z__1.i = 0.; + a[i__4].r = z__1.r, a[i__4].i = z__1.i; +/* L260: */ + } + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + for (jc = *n - 1; jc >= 1; --jc) { +/* Computing MIN */ + i__4 = *n + 1 - jc, i__2 = k + 2; + il = f2cmin(i__4,i__2); + extra.r = 0., extra.i = 0.; + i__4 = (1 - iskew) * jc + 1 + ioffg + jc * a_dim1; + ctemp.r = a[i__4].r, ctemp.i = a[i__4].i; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; + if (zsym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + d_cnjg(&z__1, &ctemp); + ctemp.r = z__1.r, ctemp.i = z__1.i; + d_cnjg(&z__1, &c__); + ct.r = z__1.r, ct.i = z__1.i; + d_cnjg(&z__1, &s); + st.r = z__1.r, st.i = z__1.i; + } + L__1 = *n - jc > k; + zlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[( + 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda, + &ctemp, &extra); +/* Computing MAX */ + i__4 = 1, i__2 = jc - k + 1; + icol = f2cmax(i__4,i__2); + i__4 = jc + 2 - icol; + zlarot_(&c_true, &c_false, &c_true, &i__4, &ct, &st, & + a[jc - iskew * icol + ioffg + icol * a_dim1], + &ilda, &dummy, &ctemp); + +/* Chase EXTRA back down the matrix */ + + icol = jc; + i__4 = *n - 1; + i__2 = k; + for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <= + i__4; jch += i__2) { + zlartg_(&a[jch - iskew * icol + ioffg + icol * + a_dim1], &extra, &realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__1.r = realc * dummy.r, z__1.i = realc * + dummy.i; + c__.r = z__1.r, c__.i = z__1.i; + z__1.r = s.r * dummy.r - s.i * dummy.i, z__1.i = + s.r * dummy.i + s.i * dummy.r; + s.r = z__1.r, s.i = z__1.i; + i__3 = (1 - iskew) * jch + 1 + ioffg + jch * + a_dim1; + ctemp.r = a[i__3].r, ctemp.i = a[i__3].i; + if (zsym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + d_cnjg(&z__1, &ctemp); + ctemp.r = z__1.r, ctemp.i = z__1.i; + d_cnjg(&z__1, &c__); + ct.r = z__1.r, ct.i = z__1.i; + d_cnjg(&z__1, &s); + st.r = z__1.r, st.i = z__1.i; + } + i__3 = k + 2; + zlarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[jch - iskew * icol + ioffg + icol * + a_dim1], &ilda, &extra, &ctemp); +/* Computing MIN */ + i__3 = *n + 1 - jch, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra.r = 0., extra.i = 0.; + L__1 = *n - jch > k; + zlarot_(&c_false, &c_true, &L__1, &il, &ct, &st, & + a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &ctemp, &extra); + icol = jch; +/* L270: */ + } +/* L280: */ + } +/* L290: */ + } + +/* If we need upper triangle, copy from lower. Note that */ +/* the order of copying is chosen to work for 'b' -> 'q' */ + + if (ipack != ipackg && ipack != 4) { + for (jc = *n; jc >= 1; --jc) { + irow = ioffst - iskew * jc; + if (zsym) { +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + i__2 = jr + irow + jc * a_dim1; + i__4 = jc - iskew * jr + ioffg + jr * a_dim1; + a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i; +/* L300: */ + } + } else { +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + i__2 = jr + irow + jc * a_dim1; + d_cnjg(&z__1, &a[jc - iskew * jr + ioffg + jr + * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L310: */ + } + } +/* L320: */ + } + if (ipack == 6) { + i__1 = uub; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; +/* L330: */ + } +/* L340: */ + } + } + if (ipackg == 5) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } + +/* Ensure that the diagonal is real if Hermitian */ + + if (! zsym) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst + (1 - iskew) * jc; + i__2 = irow + jc * a_dim1; + i__4 = irow + jc * a_dim1; + d__1 = a[i__4].r; + z__1.r = d__1, z__1.i = 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L350: */ + } + } + + } + + } else { + +/* 4) Generate Banded Matrix by first */ +/* Rotating by random Unitary matrices, */ +/* then reducing the bandwidth using Householder */ +/* transformations. */ + +/* Note: we should get here only if LDA .ge. N */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + zlagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[ + 1], &work[1], &iinfo); + } else { + +/* Symmetric -- A = U D U' or */ +/* Hermitian -- A = U D U* */ + + if (zsym) { + zlagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[ + 1], &iinfo); + } else { + zlaghe_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[ + 1], &iinfo); + } + } + + if (iinfo != 0) { + *info = 3; + return 0; + } + } + +/* 5) Pack the matrix */ + + if (ipack != ipackg) { + if (ipack == 1) { + +/* 'U' -- Upper triangular, not packed */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__4 = i__ + j * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; +/* L360: */ + } +/* L370: */ + } + + } else if (ipack == 2) { + +/* 'L' -- Lower triangular, not packed */ + + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__4 = i__ + j * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; +/* L380: */ + } +/* L390: */ + } + + } else if (ipack == 3) { + +/* 'C' -- Upper triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + i__4 = irow + icol * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L400: */ + } +/* L410: */ + } + + } else if (ipack == 4) { + +/* 'R' -- Lower triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + i__4 = irow + icol * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L420: */ + } +/* L430: */ + } + + } else if (ipack >= 5) { + +/* 'B' -- The lower triangle is packed as a band matrix. */ +/* 'Q' -- The upper triangle is packed as a band matrix. */ +/* 'Z' -- The whole matrix is packed as a band matrix. */ + + if (ipack == 5) { + uub = 0; + } + if (ipack == 6) { + llb = 0; + } + + i__1 = uub; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = j + llb; + for (i__ = f2cmin(i__2,*m); i__ >= 1; --i__) { + i__2 = i__ - j + uub + 1 + j * a_dim1; + i__4 = i__ + j * a_dim1; + a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i; +/* L440: */ + } +/* L450: */ + } + + i__1 = *n; + for (j = uub + 2; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = j + llb; + i__2 = f2cmin(i__4,*m); + for (i__ = j - uub; i__ <= i__2; ++i__) { + i__4 = i__ - j + uub + 1 + j * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L460: */ + } +/* L470: */ + } + } + +/* If packed, zero out extraneous elements. */ + +/* Symmetric/Triangular Packed -- */ +/* zero out everything after A(IROW,ICOL) */ + + if (ipack == 3 || ipack == 4) { + i__1 = *m; + for (jc = icol; jc <= i__1; ++jc) { + i__2 = *lda; + for (jr = irow + 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; +/* L480: */ + } + irow = 0; +/* L490: */ + } + + } else if (ipack >= 5) { + +/* Packed Band -- */ +/* 1st row is now in A( UUB+2-j, j), zero above it */ +/* m-th row is now in A( M+UUB-j,j), zero below it */ +/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */ +/* zero below it, too. */ + + ir1 = uub + llb + 2; + ir2 = uub + *m + 2; + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; +/* L500: */ + } +/* Computing MAX */ +/* Computing MIN */ + i__3 = ir1, i__5 = ir2 - jc; + i__2 = 1, i__4 = f2cmin(i__3,i__5); + i__6 = *lda; + for (jr = f2cmax(i__2,i__4); jr <= i__6; ++jr) { + i__2 = jr + jc * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; +/* L510: */ + } +/* L520: */ + } + } + } + + return 0; + +/* End of ZLATMS */ + +} /* zlatms_ */ + diff --git a/lapack-netlib/TESTING/MATGEN/zlatmt.c b/lapack-netlib/TESTING/MATGEN/zlatmt.c new file mode 100644 index 000000000..e246e1794 --- /dev/null +++ b/lapack-netlib/TESTING/MATGEN/zlatmt.c @@ -0,0 +1,2104 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#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++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#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]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLATMT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLATMT( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, */ +/* RANK, KL, KU, PACK, A, LDA, WORK, INFO ) */ + +/* DOUBLE PRECISION COND, DMAX */ +/* INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK */ +/* CHARACTER DIST, PACK, SYM */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ +/* DOUBLE PRECISION D( * ) */ +/* INTEGER ISEED( 4 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATMT generates random matrices with specified singular values */ +/* > (or hermitian with specified eigenvalues) */ +/* > for testing LAPACK programs. */ +/* > */ +/* > ZLATMT operates by applying the following sequence of */ +/* > operations: */ +/* > */ +/* > Set the diagonal to D, where D may be input or */ +/* > computed according to MODE, COND, DMAX, and SYM */ +/* > as described below. */ +/* > */ +/* > Generate a matrix with the appropriate band structure, by one */ +/* > of two methods: */ +/* > */ +/* > Method A: */ +/* > Generate a dense M x N matrix by multiplying D on the left */ +/* > and the right by random unitary matrices, then: */ +/* > */ +/* > Reduce the bandwidth according to KL and KU, using */ +/* > Householder transformations. */ +/* > */ +/* > Method B: */ +/* > Convert the bandwidth-0 (i.e., diagonal) matrix to a */ +/* > bandwidth-1 matrix using Givens rotations, "chasing" */ +/* > out-of-band elements back, much as in QR; then convert */ +/* > the bandwidth-1 to a bandwidth-2 matrix, etc. Note */ +/* > that for reasonably small bandwidths (relative to M and */ +/* > N) this requires less storage, as a dense matrix is not */ +/* > generated. Also, for hermitian or symmetric matrices, */ +/* > only one triangle is generated. */ +/* > */ +/* > Method A is chosen if the bandwidth is a large fraction of the */ +/* > order of the matrix, and LDA is at least M (so a dense */ +/* > matrix can be stored.) Method B is chosen if the bandwidth */ +/* > is small (< 1/2 N for hermitian or symmetric, < .3 N+M for */ +/* > non-symmetric), or LDA is less than M and not less than the */ +/* > bandwidth. */ +/* > */ +/* > Pack the matrix if desired. Options specified by PACK are: */ +/* > no packing */ +/* > zero out upper half (if hermitian) */ +/* > zero out lower half (if hermitian) */ +/* > store the upper half columnwise (if hermitian or upper */ +/* > triangular) */ +/* > store the lower half columnwise (if hermitian or lower */ +/* > triangular) */ +/* > store the lower triangle in banded format (if hermitian or */ +/* > lower triangular) */ +/* > store the upper triangle in banded format (if hermitian or */ +/* > upper triangular) */ +/* > store the entire matrix in banded format */ +/* > If Method B is chosen, and band format is specified, then the */ +/* > matrix will be generated in the band format, so no repacking */ +/* > will be necessary. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of A. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of A. N must equal M if the matrix */ +/* > is symmetric or hermitian (i.e., if SYM is not 'N') */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIST */ +/* > \verbatim */ +/* > DIST is CHARACTER*1 */ +/* > On entry, DIST specifies the type of distribution to be used */ +/* > to generate the random eigen-/singular values. */ +/* > 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */ +/* > 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */ +/* > 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension ( 4 ) */ +/* > On entry ISEED specifies the seed of the random number */ +/* > generator. They should lie between 0 and 4095 inclusive, */ +/* > and ISEED(4) should be odd. The random number generator */ +/* > uses a linear congruential sequence limited to small */ +/* > integers, and so should produce machine independent */ +/* > random numbers. The values of ISEED are changed on */ +/* > exit, and can be used in the next call to ZLATMT */ +/* > to continue the same random number sequence. */ +/* > Changed on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SYM */ +/* > \verbatim */ +/* > SYM is CHARACTER*1 */ +/* > If SYM='H', the generated matrix is hermitian, with */ +/* > eigenvalues specified by D, COND, MODE, and DMAX; they */ +/* > may be positive, negative, or zero. */ +/* > If SYM='P', the generated matrix is hermitian, with */ +/* > eigenvalues (= singular values) specified by D, COND, */ +/* > MODE, and DMAX; they will not be negative. */ +/* > If SYM='N', the generated matrix is nonsymmetric, with */ +/* > singular values specified by D, COND, MODE, and DMAX; */ +/* > they will not be negative. */ +/* > If SYM='S', the generated matrix is (complex) symmetric, */ +/* > with singular values specified by D, COND, MODE, and */ +/* > DMAX; they will not be negative. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension ( MIN( M, N ) ) */ +/* > This array is used to specify the singular values or */ +/* > eigenvalues of A (see SYM, above.) If MODE=0, then D is */ +/* > assumed to contain the singular/eigenvalues, otherwise */ +/* > they will be computed according to MODE, COND, and DMAX, */ +/* > and placed in D. */ +/* > Modified if MODE is nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MODE */ +/* > \verbatim */ +/* > MODE is INTEGER */ +/* > On entry this describes how the singular/eigenvalues are to */ +/* > be specified: */ +/* > MODE = 0 means use D as input */ +/* > MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */ +/* > MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */ +/* > MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) */ +/* > MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */ +/* > MODE = 5 sets D to random numbers in the range */ +/* > ( 1/COND , 1 ) such that their logarithms */ +/* > are uniformly distributed. */ +/* > MODE = 6 set D to random numbers from same distribution */ +/* > as the rest of the matrix. */ +/* > MODE < 0 has the same meaning as ABS(MODE), except that */ +/* > the order of the elements of D is reversed. */ +/* > Thus if MODE is positive, D has entries ranging from */ +/* > 1 to 1/COND, if negative, from 1/COND to 1, */ +/* > If SYM='H', and MODE is neither 0, 6, nor -6, then */ +/* > the elements of D will also be multiplied by a random */ +/* > sign (i.e., +1 or -1.) */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COND */ +/* > \verbatim */ +/* > COND is DOUBLE PRECISION */ +/* > On entry, this is used as described under MODE above. */ +/* > If used, it must be >= 1. Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMAX */ +/* > \verbatim */ +/* > DMAX is DOUBLE PRECISION */ +/* > If MODE is neither -6, 0 nor 6, the contents of D, as */ +/* > computed according to MODE and COND, will be scaled by */ +/* > DMAX / f2cmax(abs(D(i))); thus, the maximum absolute eigen- or */ +/* > singular value (which is to say the norm) will be abs(DMAX). */ +/* > Note that DMAX need not be positive: if DMAX is negative */ +/* > (or zero), D will be scaled by a negative number (or zero). */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The rank of matrix to be generated for modes 1,2,3 only. */ +/* > D( RANK+1:N ) = 0. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > This specifies the lower bandwidth of the matrix. For */ +/* > example, KL=0 implies upper triangular, KL=1 implies upper */ +/* > Hessenberg, and KL being at least M-1 means that the matrix */ +/* > has full lower bandwidth. KL must equal KU if the matrix */ +/* > is symmetric or hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > This specifies the upper bandwidth of the matrix. For */ +/* > example, KU=0 implies lower triangular, KU=1 implies lower */ +/* > Hessenberg, and KU being at least N-1 means that the matrix */ +/* > has full upper bandwidth. KL must equal KU if the matrix */ +/* > is symmetric or hermitian. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PACK */ +/* > \verbatim */ +/* > PACK is CHARACTER*1 */ +/* > This specifies packing of matrix as follows: */ +/* > 'N' => no packing */ +/* > 'U' => zero out all subdiagonal entries (if symmetric */ +/* > or hermitian) */ +/* > 'L' => zero out all superdiagonal entries (if symmetric */ +/* > or hermitian) */ +/* > 'C' => store the upper triangle columnwise (only if the */ +/* > matrix is symmetric, hermitian, or upper triangular) */ +/* > 'R' => store the lower triangle columnwise (only if the */ +/* > matrix is symmetric, hermitian, or lower triangular) */ +/* > 'B' => store the lower triangle in band storage scheme */ +/* > (only if the matrix is symmetric, hermitian, or */ +/* > lower triangular) */ +/* > 'Q' => store the upper triangle in band storage scheme */ +/* > (only if the matrix is symmetric, hermitian, or */ +/* > upper triangular) */ +/* > 'Z' => store the entire matrix in band storage scheme */ +/* > (pivoting can be provided for by using this */ +/* > option to store A in the trailing rows of */ +/* > the allocated storage) */ +/* > */ +/* > Using these options, the various LAPACK packed and banded */ +/* > storage schemes can be obtained: */ +/* > GB - use 'Z' */ +/* > PB, SB, HB, or TB - use 'B' or 'Q' */ +/* > PP, SP, HB, or TP - use 'C' or 'R' */ +/* > */ +/* > If two calls to ZLATMT differ only in the PACK parameter, */ +/* > they will generate mathematically equivalent matrices. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension ( LDA, N ) */ +/* > On exit A is the desired test matrix. A is first generated */ +/* > in full (unpacked) form, and then packed, if so specified */ +/* > by PACK. Thus, the first M elements of the first N */ +/* > columns will always be modified. If PACK specifies a */ +/* > packed or banded storage scheme, all LDA elements of the */ +/* > first N columns will be modified; the elements of the */ +/* > array which do not correspond to elements of the generated */ +/* > matrix are set to zero. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > LDA specifies the first dimension of A as declared in the */ +/* > calling program. If PACK='N', 'U', 'L', 'C', or 'R', then */ +/* > LDA must be at least M. If PACK='B' or 'Q', then LDA must */ +/* > be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). */ +/* > If PACK='Z', LDA must be large enough to hold the packed */ +/* > array: MIN( KU, N-1) + MIN( KL, M-1) + 1. */ +/* > Not modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension ( 3*MAX( N, M ) ) */ +/* > Workspace. */ +/* > Modified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error code. On exit, INFO will be set to one of the */ +/* > following values: */ +/* > 0 => normal return */ +/* > -1 => M negative or unequal to N and SYM='S', 'H', or 'P' */ +/* > -2 => N negative */ +/* > -3 => DIST illegal string */ +/* > -5 => SYM illegal string */ +/* > -7 => MODE not in range -6 to 6 */ +/* > -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 */ +/* > -10 => KL negative */ +/* > -11 => KU negative, or SYM is not 'N' and KU is not equal to */ +/* > KL */ +/* > -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; */ +/* > or PACK='C' or 'Q' and SYM='N' and KL is not zero; */ +/* > or PACK='R' or 'B' and SYM='N' and KU is not zero; */ +/* > or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not */ +/* > N. */ +/* > -14 => LDA is less than M, or PACK='Z' and LDA is less than */ +/* > MIN(KU,N-1) + MIN(KL,M-1) + 1. */ +/* > 1 => Error return from DLATM7 */ +/* > 2 => Cannot scale to DMAX (f2cmax. sing. value is 0) */ +/* > 3 => Error return from ZLAGGE, ZLAGHE or ZLAGSY */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16_matgen */ + +/* ===================================================================== */ +/* Subroutine */ int zlatmt_(integer *m, integer *n, char *dist, integer * + iseed, char *sym, doublereal *d__, integer *mode, doublereal *cond, + doublereal *dmax__, integer *rank, integer *kl, integer *ku, char * + pack, doublecomplex *a, integer *lda, doublecomplex *work, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1, d__2, d__3; + doublecomplex z__1, z__2, z__3; + logical L__1; + + /* Local variables */ + integer ilda, icol; + doublereal temp; + logical csym; + integer irow, isym; + doublecomplex c__; + integer i__, j, k; + doublecomplex s; + doublereal alpha, angle, realc; + integer ipack, ioffg; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + integer iinfo, idist, mnmin; + doublecomplex extra; + integer iskew; + doublecomplex dummy, ztemp; + extern /* Subroutine */ int dlatm7_(integer *, doublereal *, integer *, + integer *, integer *, doublereal *, integer *, integer *, integer + *); + integer ic, jc, nc, il; + doublecomplex ct; + integer iendch, ir, jr, ipackg, mr, minlda; + extern doublereal dlarnd_(integer *, integer *); + doublecomplex st; + extern /* Subroutine */ int zlagge_(integer *, integer *, integer *, + integer *, doublereal *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *), zlaghe_(integer *, integer *, + doublereal *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *), xerbla_(char *, integer *); + integer ioffst, irsign; + logical givens, iltemp; + //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, + extern doublecomplex zlarnd_(integer *, + integer *); + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlartg_(doublecomplex *, doublecomplex *, doublereal *, + doublecomplex *, doublecomplex *); + logical ilextr; + extern /* Subroutine */ int zlagsy_(integer *, integer *, doublereal *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *) + ; + integer ir1, ir2, isympk; + logical topdwn; + extern /* Subroutine */ int zlarot_(logical *, logical *, logical *, + integer *, doublecomplex *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *); + integer jch, llb, jkl, jku, uub; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* 1) Decode and Test the input parameters. */ +/* Initialize flags & seed. */ + + /* Parameter adjustments */ + --iseed; + --d__; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Decode DIST */ + + if (lsame_(dist, "U")) { + idist = 1; + } else if (lsame_(dist, "S")) { + idist = 2; + } else if (lsame_(dist, "N")) { + idist = 3; + } else { + idist = -1; + } + +/* Decode SYM */ + + if (lsame_(sym, "N")) { + isym = 1; + irsign = 0; + csym = FALSE_; + } else if (lsame_(sym, "P")) { + isym = 2; + irsign = 0; + csym = FALSE_; + } else if (lsame_(sym, "S")) { + isym = 2; + irsign = 0; + csym = TRUE_; + } else if (lsame_(sym, "H")) { + isym = 2; + irsign = 1; + csym = FALSE_; + } else { + isym = -1; + } + +/* Decode PACK */ + + isympk = 0; + if (lsame_(pack, "N")) { + ipack = 0; + } else if (lsame_(pack, "U")) { + ipack = 1; + isympk = 1; + } else if (lsame_(pack, "L")) { + ipack = 2; + isympk = 1; + } else if (lsame_(pack, "C")) { + ipack = 3; + isympk = 2; + } else if (lsame_(pack, "R")) { + ipack = 4; + isympk = 3; + } else if (lsame_(pack, "B")) { + ipack = 5; + isympk = 3; + } else if (lsame_(pack, "Q")) { + ipack = 6; + isympk = 2; + } else if (lsame_(pack, "Z")) { + ipack = 7; + } else { + ipack = -1; + } + +/* Set certain internal parameters */ + + mnmin = f2cmin(*m,*n); +/* Computing MIN */ + i__1 = *kl, i__2 = *m - 1; + llb = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *ku, i__2 = *n - 1; + uub = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *m, i__2 = *n + llb; + mr = f2cmin(i__1,i__2); +/* Computing MIN */ + i__1 = *n, i__2 = *m + uub; + nc = f2cmin(i__1,i__2); + + if (ipack == 5 || ipack == 6) { + minlda = uub + 1; + } else if (ipack == 7) { + minlda = llb + uub + 1; + } else { + minlda = *m; + } + +/* Use Givens rotation method if bandwidth small enough, */ +/* or if LDA is too small to store the matrix unpacked. */ + + givens = FALSE_; + if (isym == 1) { +/* Computing MAX */ + i__1 = 1, i__2 = mr + nc; + if ((doublereal) (llb + uub) < (doublereal) f2cmax(i__1,i__2) * .3) { + givens = TRUE_; + } + } else { + if (llb << 1 < *m) { + givens = TRUE_; + } + } + if (*lda < *m && *lda >= minlda) { + givens = TRUE_; + } + +/* Set INFO if an error */ + + if (*m < 0) { + *info = -1; + } else if (*m != *n && isym != 1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (idist == -1) { + *info = -3; + } else if (isym == -1) { + *info = -5; + } else if (abs(*mode) > 6) { + *info = -7; + } else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) { + *info = -8; + } else if (*kl < 0) { + *info = -10; + } else if (*ku < 0 || isym != 1 && *kl != *ku) { + *info = -11; + } else if (ipack == -1 || isympk == 1 && isym == 1 || isympk == 2 && isym + == 1 && *kl > 0 || isympk == 3 && isym == 1 && *ku > 0 || isympk + != 0 && *m != *n) { + *info = -12; + } else if (*lda < f2cmax(1,minlda)) { + *info = -14; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLATMT", &i__1); + return 0; + } + +/* Initialize random number generator */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096; +/* L100: */ + } + + if (iseed[4] % 2 != 1) { + ++iseed[4]; + } + +/* 2) Set up D if indicated. */ + +/* Compute D according to COND and MODE */ + + dlatm7_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], &mnmin, rank, & + iinfo); + if (iinfo != 0) { + *info = 1; + return 0; + } + +/* Choose Top-Down if D is (apparently) increasing, */ +/* Bottom-Up if D is (apparently) decreasing. */ + + if (abs(d__[1]) <= (d__1 = d__[*rank], abs(d__1))) { + topdwn = TRUE_; + } else { + topdwn = FALSE_; + } + + if (*mode != 0 && abs(*mode) != 6) { + +/* Scale by DMAX */ + + temp = abs(d__[1]); + i__1 = *rank; + for (i__ = 2; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1)); + temp = f2cmax(d__2,d__3); +/* L110: */ + } + + if (temp > 0.) { + alpha = *dmax__ / temp; + } else { + *info = 2; + return 0; + } + + dscal_(rank, &alpha, &d__[1], &c__1); + + } + + zlaset_("Full", lda, n, &c_b1, &c_b1, &a[a_offset], lda); + +/* 3) Generate Banded Matrix using Givens rotations. */ +/* Also the special case of UUB=LLB=0 */ + +/* Compute Addressing constants to cover all */ +/* storage formats. Whether GE, HE, SY, GB, HB, or SB, */ +/* upper or lower triangle or both, */ +/* the (i,j)-th element is in */ +/* A( i - ISKEW*j + IOFFST, j ) */ + + if (ipack > 4) { + ilda = *lda - 1; + iskew = 1; + if (ipack > 5) { + ioffst = uub + 1; + } else { + ioffst = 1; + } + } else { + ilda = *lda; + iskew = 0; + ioffst = 0; + } + +/* IPACKG is the format that the matrix is generated in. If this is */ +/* different from IPACK, then the matrix must be repacked at the */ +/* end. It also signals how to compute the norm, for scaling. */ + + ipackg = 0; + +/* Diagonal Matrix -- We are done, unless it */ +/* is to be stored HP/SP/PP/TP (PACK='R' or 'C') */ + + if (llb == 0 && uub == 0) { + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__2 = (1 - iskew) * j + ioffst + j * a_dim1; + i__3 = j; + z__1.r = d__[i__3], z__1.i = 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L120: */ + } + + if (ipack <= 2 || ipack >= 5) { + ipackg = ipack; + } + + } else if (givens) { + +/* Check whether to use Givens rotations, */ +/* Householder transformations, or nothing. */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + if (ipack > 4) { + ipackg = ipack; + } else { + ipackg = 0; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__2 = (1 - iskew) * j + ioffst + j * a_dim1; + i__3 = j; + z__1.r = d__[i__3], z__1.i = 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L130: */ + } + + if (topdwn) { + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* Last row actually rotated is M */ +/* Last column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__3 = *m + jku; + i__2 = f2cmin(i__3,*n) + jkl - 1; + for (jr = 1; jr <= i__2; ++jr) { + extra.r = 0., extra.i = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_( &c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; +/* Computing MAX */ + i__3 = 1, i__4 = jr - jkl; + icol = f2cmax(i__3,i__4); + if (jr < *m) { +/* Computing MIN */ + i__3 = *n, i__4 = jr + jku; + il = f2cmin(i__3,i__4) + 1 - icol; + L__1 = jr > jkl; + zlarot_(&c_true, &L__1, &c_false, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ir = jr; + ic = icol; + i__3 = -jkl - jku; + for (jch = jr - jkl; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ir < *m) { + zlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &realc, + &s, &dummy); + d__1 = dlarnd_(&c__5, &iseed[1]); + dummy.r = d__1, dummy.i = 0.; + z__2.r = realc * dummy.r, z__2.i = realc * + dummy.i; + d_cnjg(&z__1, &z__2); + c__.r = z__1.r, c__.i = z__1.i; + z__3.r = -s.r, z__3.i = -s.i; + z__2.r = z__3.r * dummy.r - z__3.i * dummy.i, + z__2.i = z__3.r * dummy.i + z__3.i * + dummy.r; + d_cnjg(&z__1, &z__2); + s.r = z__1.r, s.i = z__1.i; + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + ztemp.r = 0., ztemp.i = 0.; + iltemp = jch > jku; + zlarot_(&c_false, &iltemp, &c_true, &il, &c__, &s, + &a[irow - iskew * ic + ioffst + ic * + a_dim1], &ilda, &ztemp, &extra); + if (iltemp) { + zlartg_(&a[irow + 1 - iskew * (ic + 1) + + ioffst + (ic + 1) * a_dim1], &ztemp, & + realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_( &c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__2.r = realc * dummy.r, z__2.i = realc * + dummy.i; + d_cnjg(&z__1, &z__2); + c__.r = z__1.r, c__.i = z__1.i; + z__3.r = -s.r, z__3.i = -s.i; + z__2.r = z__3.r * dummy.r - z__3.i * dummy.i, + z__2.i = z__3.r * dummy.i + z__3.i * + dummy.r; + d_cnjg(&z__1, &z__2); + s.r = z__1.r, s.i = z__1.i; + +/* Computing MAX */ + i__4 = 1, i__5 = jch - jku - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + extra.r = 0., extra.i = 0.; + L__1 = jch > jku + jkl; + zlarot_(&c_true, &L__1, &c_true, &il, &c__, & + s, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, &ztemp) + ; + ic = icol; + ir = irow; + } +/* L140: */ + } +/* L150: */ + } +/* L160: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* Computing MIN */ + i__3 = *n + jkl; + i__2 = f2cmin(i__3,*m) + jku - 1; + for (jc = 1; jc <= i__2; ++jc) { + extra.r = 0., extra.i = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; +/* Computing MAX */ + i__3 = 1, i__4 = jc - jku; + irow = f2cmax(i__3,i__4); + if (jc < *n) { +/* Computing MIN */ + i__3 = *m, i__4 = jc + jkl; + il = f2cmin(i__3,i__4) + 1 - irow; + L__1 = jc > jku; + zlarot_(&c_false, &L__1, &c_false, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &extra, &dummy); + } + +/* Chase "EXTRA" back up */ + + ic = jc; + ir = irow; + i__3 = -jkl - jku; + for (jch = jc - jku; i__3 < 0 ? jch >= 1 : jch <= 1; + jch += i__3) { + if (ic < *n) { + zlartg_(&a[ir + 1 - iskew * (ic + 1) + ioffst + + (ic + 1) * a_dim1], &extra, &realc, + &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__2.r = realc * dummy.r, z__2.i = realc * + dummy.i; + d_cnjg(&z__1, &z__2); + c__.r = z__1.r, c__.i = z__1.i; + z__3.r = -s.r, z__3.i = -s.i; + z__2.r = z__3.r * dummy.r - z__3.i * dummy.i, + z__2.i = z__3.r * dummy.i + z__3.i * + dummy.r; + d_cnjg(&z__1, &z__2); + s.r = z__1.r, s.i = z__1.i; + } +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl; + icol = f2cmax(i__4,i__5); + il = ic + 2 - icol; + ztemp.r = 0., ztemp.i = 0.; + iltemp = jch > jkl; + zlarot_(&c_true, &iltemp, &c_true, &il, &c__, &s, + &a[ir - iskew * icol + ioffst + icol * + a_dim1], &ilda, &ztemp, &extra); + if (iltemp) { + zlartg_(&a[ir + 1 - iskew * (icol + 1) + + ioffst + (icol + 1) * a_dim1], &ztemp, + &realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__2.r = realc * dummy.r, z__2.i = realc * + dummy.i; + d_cnjg(&z__1, &z__2); + c__.r = z__1.r, c__.i = z__1.i; + z__3.r = -s.r, z__3.i = -s.i; + z__2.r = z__3.r * dummy.r - z__3.i * dummy.i, + z__2.i = z__3.r * dummy.i + z__3.i * + dummy.r; + d_cnjg(&z__1, &z__2); + s.r = z__1.r, s.i = z__1.i; +/* Computing MAX */ + i__4 = 1, i__5 = jch - jkl - jku; + irow = f2cmax(i__4,i__5); + il = ir + 2 - irow; + extra.r = 0., extra.i = 0.; + L__1 = jch > jkl + jku; + zlarot_(&c_false, &L__1, &c_true, &il, &c__, & + s, &a[irow - iskew * icol + ioffst + + icol * a_dim1], &ilda, &extra, &ztemp) + ; + ic = icol; + ir = irow; + } +/* L170: */ + } +/* L180: */ + } +/* L190: */ + } + + } else { + +/* Bottom-Up -- Start at the bottom right. */ + + jkl = 0; + i__1 = uub; + for (jku = 1; jku <= i__1; ++jku) { + +/* Transform from bandwidth JKL, JKU-1 to JKL, JKU */ + +/* First row actually rotated is M */ +/* First column actually rotated is MIN( M+JKU, N ) */ + +/* Computing MIN */ + i__2 = *m, i__3 = *n + jkl; + iendch = f2cmin(i__2,i__3) - 1; +/* Computing MIN */ + i__2 = *m + jku; + i__3 = 1 - jkl; + for (jc = f2cmin(i__2,*n) - 1; jc >= i__3; --jc) { + extra.r = 0., extra.i = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_( &c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_( &c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; +/* Computing MAX */ + i__2 = 1, i__4 = jc - jku + 1; + irow = f2cmax(i__2,i__4); + if (jc > 0) { +/* Computing MIN */ + i__2 = *m, i__4 = jc + jkl + 1; + il = f2cmin(i__2,i__4) + 1 - irow; + L__1 = jc + jkl < *m; + zlarot_(&c_false, &c_false, &L__1, &il, &c__, &s, + &a[irow - iskew * jc + ioffst + jc * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ic = jc; + i__2 = iendch; + i__4 = jkl + jku; + for (jch = jc + jkl; i__4 < 0 ? jch >= i__2 : jch <= + i__2; jch += i__4) { + ilextr = ic > 0; + if (ilextr) { + zlartg_(&a[jch - iskew * ic + ioffst + ic * + a_dim1], &extra, &realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__1.r = realc * dummy.r, z__1.i = realc * + dummy.i; + c__.r = z__1.r, c__.i = z__1.i; + z__1.r = s.r * dummy.r - s.i * dummy.i, + z__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = z__1.r, s.i = z__1.i; + } + ic = f2cmax(1,ic); +/* Computing MIN */ + i__5 = *n - 1, i__6 = jch + jku; + icol = f2cmin(i__5,i__6); + iltemp = jch + jku < *n; + ztemp.r = 0., ztemp.i = 0.; + i__5 = icol + 2 - ic; + zlarot_(&c_true, &ilextr, &iltemp, &i__5, &c__, & + s, &a[jch - iskew * ic + ioffst + ic * + a_dim1], &ilda, &extra, &ztemp); + if (iltemp) { + zlartg_(&a[jch - iskew * icol + ioffst + icol + * a_dim1], &ztemp, &realc, &s, &dummy) + ; + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__1.r = realc * dummy.r, z__1.i = realc * + dummy.i; + c__.r = z__1.r, c__.i = z__1.i; + z__1.r = s.r * dummy.r - s.i * dummy.i, + z__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = z__1.r, s.i = z__1.i; +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra.r = 0., extra.i = 0.; + L__1 = jch + jkl + jku <= iendch; + zlarot_(&c_false, &c_true, &L__1, &il, &c__, & + s, &a[jch - iskew * icol + ioffst + + icol * a_dim1], &ilda, &ztemp, &extra) + ; + ic = icol; + } +/* L200: */ + } +/* L210: */ + } +/* L220: */ + } + + jku = uub; + i__1 = llb; + for (jkl = 1; jkl <= i__1; ++jkl) { + +/* Transform from bandwidth JKL-1, JKU to JKL, JKU */ + +/* First row actually rotated is MIN( N+JKL, M ) */ +/* First column actually rotated is N */ + +/* Computing MIN */ + i__3 = *n, i__4 = *m + jku; + iendch = f2cmin(i__3,i__4) - 1; +/* Computing MIN */ + i__3 = *n + jkl; + i__4 = 1 - jku; + for (jr = f2cmin(i__3,*m) - 1; jr >= i__4; --jr) { + extra.r = 0., extra.i = 0.; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; +/* Computing MAX */ + i__3 = 1, i__2 = jr - jkl + 1; + icol = f2cmax(i__3,i__2); + if (jr > 0) { +/* Computing MIN */ + i__3 = *n, i__2 = jr + jku + 1; + il = f2cmin(i__3,i__2) + 1 - icol; + L__1 = jr + jku < *n; + zlarot_(&c_true, &c_false, &L__1, &il, &c__, &s, & + a[jr - iskew * icol + ioffst + icol * + a_dim1], &ilda, &dummy, &extra); + } + +/* Chase "EXTRA" back down */ + + ir = jr; + i__3 = iendch; + i__2 = jkl + jku; + for (jch = jr + jku; i__2 < 0 ? jch >= i__3 : jch <= + i__3; jch += i__2) { + ilextr = ir > 0; + if (ilextr) { + zlartg_(&a[ir - iskew * jch + ioffst + jch * + a_dim1], &extra, &realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_( &c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__1.r = realc * dummy.r, z__1.i = realc * + dummy.i; + c__.r = z__1.r, c__.i = z__1.i; + z__1.r = s.r * dummy.r - s.i * dummy.i, + z__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = z__1.r, s.i = z__1.i; + } + ir = f2cmax(1,ir); +/* Computing MIN */ + i__5 = *m - 1, i__6 = jch + jkl; + irow = f2cmin(i__5,i__6); + iltemp = jch + jkl < *m; + ztemp.r = 0., ztemp.i = 0.; + i__5 = irow + 2 - ir; + zlarot_(&c_false, &ilextr, &iltemp, &i__5, &c__, & + s, &a[ir - iskew * jch + ioffst + jch * + a_dim1], &ilda, &extra, &ztemp); + if (iltemp) { + zlartg_(&a[irow - iskew * jch + ioffst + jch * + a_dim1], &ztemp, &realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__1.r = realc * dummy.r, z__1.i = realc * + dummy.i; + c__.r = z__1.r, c__.i = z__1.i; + z__1.r = s.r * dummy.r - s.i * dummy.i, + z__1.i = s.r * dummy.i + s.i * + dummy.r; + s.r = z__1.r, s.i = z__1.i; +/* Computing MIN */ + i__5 = iendch, i__6 = jch + jkl + jku; + il = f2cmin(i__5,i__6) + 2 - jch; + extra.r = 0., extra.i = 0.; + L__1 = jch + jkl + jku <= iendch; + zlarot_(&c_true, &c_true, &L__1, &il, &c__, & + s, &a[irow - iskew * jch + ioffst + + jch * a_dim1], &ilda, &ztemp, &extra); + ir = irow; + } +/* L230: */ + } +/* L240: */ + } +/* L250: */ + } + + } + + } else { + +/* Symmetric -- A = U D U' */ +/* Hermitian -- A = U D U* */ + + ipackg = ipack; + ioffg = ioffst; + + if (topdwn) { + +/* Top-Down -- Generate Upper triangle only */ + + if (ipack >= 5) { + ipackg = 6; + ioffg = uub + 1; + } else { + ipackg = 1; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__4 = (1 - iskew) * j + ioffg + j * a_dim1; + i__2 = j; + z__1.r = d__[i__2], z__1.i = 0.; + a[i__4].r = z__1.r, a[i__4].i = z__1.i; +/* L260: */ + } + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + i__4 = *n - 1; + for (jc = 1; jc <= i__4; ++jc) { +/* Computing MAX */ + i__2 = 1, i__3 = jc - k; + irow = f2cmax(i__2,i__3); +/* Computing MIN */ + i__2 = jc + 1, i__3 = k + 2; + il = f2cmin(i__2,i__3); + extra.r = 0., extra.i = 0.; + i__2 = jc - iskew * (jc + 1) + ioffg + (jc + 1) * + a_dim1; + ztemp.r = a[i__2].r, ztemp.i = a[i__2].i; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_( &c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + d_cnjg(&z__1, &ztemp); + ztemp.r = z__1.r, ztemp.i = z__1.i; + d_cnjg(&z__1, &c__); + ct.r = z__1.r, ct.i = z__1.i; + d_cnjg(&z__1, &s); + st.r = z__1.r, st.i = z__1.i; + } + L__1 = jc > k; + zlarot_(&c_false, &L__1, &c_true, &il, &c__, &s, &a[ + irow - iskew * jc + ioffg + jc * a_dim1], & + ilda, &extra, &ztemp); +/* Computing MIN */ + i__3 = k, i__5 = *n - jc; + i__2 = f2cmin(i__3,i__5) + 1; + zlarot_(&c_true, &c_true, &c_false, &i__2, &ct, &st, & + a[(1 - iskew) * jc + ioffg + jc * a_dim1], & + ilda, &ztemp, &dummy); + +/* Chase EXTRA back up the matrix */ + + icol = jc; + i__2 = -k; + for (jch = jc - k; i__2 < 0 ? jch >= 1 : jch <= 1; + jch += i__2) { + zlartg_(&a[jch + 1 - iskew * (icol + 1) + ioffg + + (icol + 1) * a_dim1], &extra, &realc, &s, + &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__2.r = realc * dummy.r, z__2.i = realc * + dummy.i; + d_cnjg(&z__1, &z__2); + c__.r = z__1.r, c__.i = z__1.i; + z__3.r = -s.r, z__3.i = -s.i; + z__2.r = z__3.r * dummy.r - z__3.i * dummy.i, + z__2.i = z__3.r * dummy.i + z__3.i * + dummy.r; + d_cnjg(&z__1, &z__2); + s.r = z__1.r, s.i = z__1.i; + i__3 = jch - iskew * (jch + 1) + ioffg + (jch + 1) + * a_dim1; + ztemp.r = a[i__3].r, ztemp.i = a[i__3].i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + d_cnjg(&z__1, &ztemp); + ztemp.r = z__1.r, ztemp.i = z__1.i; + d_cnjg(&z__1, &c__); + ct.r = z__1.r, ct.i = z__1.i; + d_cnjg(&z__1, &s); + st.r = z__1.r, st.i = z__1.i; + } + i__3 = k + 2; + zlarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &ztemp, &extra); +/* Computing MAX */ + i__3 = 1, i__5 = jch - k; + irow = f2cmax(i__3,i__5); +/* Computing MIN */ + i__3 = jch + 1, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra.r = 0., extra.i = 0.; + L__1 = jch > k; + zlarot_(&c_false, &L__1, &c_true, &il, &ct, &st, & + a[irow - iskew * jch + ioffg + jch * + a_dim1], &ilda, &extra, &ztemp); + icol = jch; +/* L270: */ + } +/* L280: */ + } +/* L290: */ + } + +/* If we need lower triangle, copy from upper. Note that */ +/* the order of copying is chosen to work for 'q' -> 'b' */ + + if (ipack != ipackg && ipack != 3) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst - iskew * jc; + if (csym) { +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + i__2 = jr + irow + jc * a_dim1; + i__3 = jc - iskew * jr + ioffg + jr * a_dim1; + a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i; +/* L300: */ + } + } else { +/* Computing MIN */ + i__2 = *n, i__3 = jc + uub; + i__4 = f2cmin(i__2,i__3); + for (jr = jc; jr <= i__4; ++jr) { + i__2 = jr + irow + jc * a_dim1; + d_cnjg(&z__1, &a[jc - iskew * jr + ioffg + jr + * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L310: */ + } + } +/* L320: */ + } + if (ipack == 5) { + i__1 = *n; + for (jc = *n - uub + 1; jc <= i__1; ++jc) { + i__4 = uub + 1; + for (jr = *n + 2 - jc; jr <= i__4; ++jr) { + i__2 = jr + jc * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; +/* L330: */ + } +/* L340: */ + } + } + if (ipackg == 6) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } else { + +/* Bottom-Up -- Generate Lower triangle only */ + + if (ipack >= 5) { + ipackg = 5; + if (ipack == 6) { + ioffg = 1; + } + } else { + ipackg = 2; + } + + i__1 = mnmin; + for (j = 1; j <= i__1; ++j) { + i__4 = (1 - iskew) * j + ioffg + j * a_dim1; + i__2 = j; + z__1.r = d__[i__2], z__1.i = 0.; + a[i__4].r = z__1.r, a[i__4].i = z__1.i; +/* L350: */ + } + + i__1 = uub; + for (k = 1; k <= i__1; ++k) { + for (jc = *n - 1; jc >= 1; --jc) { +/* Computing MIN */ + i__4 = *n + 1 - jc, i__2 = k + 2; + il = f2cmin(i__4,i__2); + extra.r = 0., extra.i = 0.; + i__4 = (1 - iskew) * jc + 1 + ioffg + jc * a_dim1; + ztemp.r = a[i__4].r, ztemp.i = a[i__4].i; + angle = dlarnd_(&c__1, &iseed[1]) * + 6.2831853071795864769252867663; + d__1 = cos(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + c__.r = z__1.r, c__.i = z__1.i; + d__1 = sin(angle); + //zlarnd_(&z__2, &c__5, &iseed[1]); + z__2=zlarnd_(&c__5, &iseed[1]); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + s.r = z__1.r, s.i = z__1.i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + d_cnjg(&z__1, &ztemp); + ztemp.r = z__1.r, ztemp.i = z__1.i; + d_cnjg(&z__1, &c__); + ct.r = z__1.r, ct.i = z__1.i; + d_cnjg(&z__1, &s); + st.r = z__1.r, st.i = z__1.i; + } + L__1 = *n - jc > k; + zlarot_(&c_false, &c_true, &L__1, &il, &c__, &s, &a[( + 1 - iskew) * jc + ioffg + jc * a_dim1], &ilda, + &ztemp, &extra); +/* Computing MAX */ + i__4 = 1, i__2 = jc - k + 1; + icol = f2cmax(i__4,i__2); + i__4 = jc + 2 - icol; + zlarot_(&c_true, &c_false, &c_true, &i__4, &ct, &st, & + a[jc - iskew * icol + ioffg + icol * a_dim1], + &ilda, &dummy, &ztemp); + +/* Chase EXTRA back down the matrix */ + + icol = jc; + i__4 = *n - 1; + i__2 = k; + for (jch = jc + k; i__2 < 0 ? jch >= i__4 : jch <= + i__4; jch += i__2) { + zlartg_(&a[jch - iskew * icol + ioffg + icol * + a_dim1], &extra, &realc, &s, &dummy); + //zlarnd_(&z__1, &c__5, &iseed[1]); + z__1=zlarnd_(&c__5, &iseed[1]); + dummy.r = z__1.r, dummy.i = z__1.i; + z__1.r = realc * dummy.r, z__1.i = realc * + dummy.i; + c__.r = z__1.r, c__.i = z__1.i; + z__1.r = s.r * dummy.r - s.i * dummy.i, z__1.i = + s.r * dummy.i + s.i * dummy.r; + s.r = z__1.r, s.i = z__1.i; + i__3 = (1 - iskew) * jch + 1 + ioffg + jch * + a_dim1; + ztemp.r = a[i__3].r, ztemp.i = a[i__3].i; + if (csym) { + ct.r = c__.r, ct.i = c__.i; + st.r = s.r, st.i = s.i; + } else { + d_cnjg(&z__1, &ztemp); + ztemp.r = z__1.r, ztemp.i = z__1.i; + d_cnjg(&z__1, &c__); + ct.r = z__1.r, ct.i = z__1.i; + d_cnjg(&z__1, &s); + st.r = z__1.r, st.i = z__1.i; + } + i__3 = k + 2; + zlarot_(&c_true, &c_true, &c_true, &i__3, &c__, & + s, &a[jch - iskew * icol + ioffg + icol * + a_dim1], &ilda, &extra, &ztemp); +/* Computing MIN */ + i__3 = *n + 1 - jch, i__5 = k + 2; + il = f2cmin(i__3,i__5); + extra.r = 0., extra.i = 0.; + L__1 = *n - jch > k; + zlarot_(&c_false, &c_true, &L__1, &il, &ct, &st, & + a[(1 - iskew) * jch + ioffg + jch * + a_dim1], &ilda, &ztemp, &extra); + icol = jch; +/* L360: */ + } +/* L370: */ + } +/* L380: */ + } + +/* If we need upper triangle, copy from lower. Note that */ +/* the order of copying is chosen to work for 'b' -> 'q' */ + + if (ipack != ipackg && ipack != 4) { + for (jc = *n; jc >= 1; --jc) { + irow = ioffst - iskew * jc; + if (csym) { +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + i__2 = jr + irow + jc * a_dim1; + i__4 = jc - iskew * jr + ioffg + jr * a_dim1; + a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i; +/* L390: */ + } + } else { +/* Computing MAX */ + i__2 = 1, i__4 = jc - uub; + i__1 = f2cmax(i__2,i__4); + for (jr = jc; jr >= i__1; --jr) { + i__2 = jr + irow + jc * a_dim1; + d_cnjg(&z__1, &a[jc - iskew * jr + ioffg + jr + * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L400: */ + } + } +/* L410: */ + } + if (ipack == 6) { + i__1 = uub; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; +/* L420: */ + } +/* L430: */ + } + } + if (ipackg == 5) { + ipackg = ipack; + } else { + ipackg = 0; + } + } + } + +/* Ensure that the diagonal is real if Hermitian */ + + if (! csym) { + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + irow = ioffst + (1 - iskew) * jc; + i__2 = irow + jc * a_dim1; + i__4 = irow + jc * a_dim1; + d__1 = a[i__4].r; + z__1.r = d__1, z__1.i = 0.; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L440: */ + } + } + + } + + } else { + +/* 4) Generate Banded Matrix by first */ +/* Rotating by random Unitary matrices, */ +/* then reducing the bandwidth using Householder */ +/* transformations. */ + +/* Note: we should get here only if LDA .ge. N */ + + if (isym == 1) { + +/* Non-symmetric -- A = U D V */ + + zlagge_(&mr, &nc, &llb, &uub, &d__[1], &a[a_offset], lda, &iseed[ + 1], &work[1], &iinfo); + } else { + +/* Symmetric -- A = U D U' or */ +/* Hermitian -- A = U D U* */ + + if (csym) { + zlagsy_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[ + 1], &iinfo); + } else { + zlaghe_(m, &llb, &d__[1], &a[a_offset], lda, &iseed[1], &work[ + 1], &iinfo); + } + } + + if (iinfo != 0) { + *info = 3; + return 0; + } + } + +/* 5) Pack the matrix */ + + if (ipack != ipackg) { + if (ipack == 1) { + +/* 'U' -- Upper triangular, not packed */ + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__4 = i__ + j * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; +/* L450: */ + } +/* L460: */ + } + + } else if (ipack == 2) { + +/* 'L' -- Lower triangular, not packed */ + + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__4 = i__ + j * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; +/* L470: */ + } +/* L480: */ + } + + } else if (ipack == 3) { + +/* 'C' -- Upper triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + i__4 = irow + icol * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L490: */ + } +/* L500: */ + } + + } else if (ipack == 4) { + +/* 'R' -- Lower triangle packed Columnwise. */ + + icol = 1; + irow = 0; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + ++irow; + if (irow > *lda) { + irow = 1; + ++icol; + } + i__4 = irow + icol * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L510: */ + } +/* L520: */ + } + + } else if (ipack >= 5) { + +/* 'B' -- The lower triangle is packed as a band matrix. */ +/* 'Q' -- The upper triangle is packed as a band matrix. */ +/* 'Z' -- The whole matrix is packed as a band matrix. */ + + if (ipack == 5) { + uub = 0; + } + if (ipack == 6) { + llb = 0; + } + + i__1 = uub; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = j + llb; + for (i__ = f2cmin(i__2,*m); i__ >= 1; --i__) { + i__2 = i__ - j + uub + 1 + j * a_dim1; + i__4 = i__ + j * a_dim1; + a[i__2].r = a[i__4].r, a[i__2].i = a[i__4].i; +/* L530: */ + } +/* L540: */ + } + + i__1 = *n; + for (j = uub + 2; j <= i__1; ++j) { +/* Computing MIN */ + i__4 = j + llb; + i__2 = f2cmin(i__4,*m); + for (i__ = j - uub; i__ <= i__2; ++i__) { + i__4 = i__ - j + uub + 1 + j * a_dim1; + i__3 = i__ + j * a_dim1; + a[i__4].r = a[i__3].r, a[i__4].i = a[i__3].i; +/* L550: */ + } +/* L560: */ + } + } + +/* If packed, zero out extraneous elements. */ + +/* Symmetric/Triangular Packed -- */ +/* zero out everything after A(IROW,ICOL) */ + + if (ipack == 3 || ipack == 4) { + i__1 = *m; + for (jc = icol; jc <= i__1; ++jc) { + i__2 = *lda; + for (jr = irow + 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; +/* L570: */ + } + irow = 0; +/* L580: */ + } + + } else if (ipack >= 5) { + +/* Packed Band -- */ +/* 1st row is now in A( UUB+2-j, j), zero above it */ +/* m-th row is now in A( M+UUB-j,j), zero below it */ +/* last non-zero diagonal is now in A( UUB+LLB+1,j ), */ +/* zero below it, too. */ + + ir1 = uub + llb + 2; + ir2 = uub + *m + 2; + i__1 = *n; + for (jc = 1; jc <= i__1; ++jc) { + i__2 = uub + 1 - jc; + for (jr = 1; jr <= i__2; ++jr) { + i__4 = jr + jc * a_dim1; + a[i__4].r = 0., a[i__4].i = 0.; +/* L590: */ + } +/* Computing MAX */ +/* Computing MIN */ + i__3 = ir1, i__5 = ir2 - jc; + i__2 = 1, i__4 = f2cmin(i__3,i__5); + i__6 = *lda; + for (jr = f2cmax(i__2,i__4); jr <= i__6; ++jr) { + i__2 = jr + jc * a_dim1; + a[i__2].r = 0., a[i__2].i = 0.; +/* L600: */ + } +/* L610: */ + } + } + } + + return 0; + +/* End of ZLATMT */ + +} /* zlatmt_ */ +