/* Subroutine */ int macedt_(char *dirnam, integer *iout, integer *iprn, char
*memnam, integer *ng, real *xsec, integer *minsg, integer *maxsg,
real *scat, real *delay, ftnlen dirnam_len, ftnlen memnam_len)
{
/* Format strings */
static char fmt_7000[] = "(\002 \002,\002MACEDT\002,114(\002=\002))";
static char fmt_6000[] = "(\002 \002,\002 G \002,\002 PRODUCTION"
" \002,\002 FISSION \002,\002 CAPTURE \002,\002 ABSORPTION"
" \002,\002 FISS.SPCTR \002,\002 DIFFUSION1 \002,\002 DIFFUSION2"
" \002,\002 TOTAL \002,\002 ACTIVATION \002)";
static char fmt_6010[] = "(\002 \002,i4,2x,1p10e12.5,/,7x,1p10e12.5)";
static char fmt_6020[] = "(\002 \002,\002 G/G' \002,10(4x,i4,4x),10(/,8"
"x,10(4x,i4,4x)))";
static char fmt_6030[] = "(\002 \002,i4,2x,1p10e12.5,10(/,7x,1p10e12.5))";
static char fmt_6040[] = "(\002 \002,\002 G/J \002,10(4x,i4,4x),10(/,8"
"x,10(4x,i4,4x)))";
static char fmt_7010[] = "(\002 \002,114(\002=\002),\002MACEDT\002)";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen), s_copy(char *, char *,
ftnlen, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static integer i__, j, n;
static real x, d1, d2;
static integer ic, ig, ir, igg, irc, lgv, lss, nfam, leng;
static real absp;
static char ptag[1];
static real xact;
static integer llgv[107];
static real fiss, prod;
static integer llss[107];
static real totl;
static integer igflg, ixflg;
extern /* Subroutine */ int pdsin_(char *, char *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
static real wscat[11449] /* was [107][107] */;
#define iwork ((integer *)&wkpds_1)
static char member[8];
static integer igstop, igstrt;
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, 0, 0 };
static cilist io___3 = { 0, 6, 0, 0, 0 };
static cilist io___18 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, 0, 0 };
static cilist io___35 = { 0, 0, 0, 0, 0 };
static cilist io___36 = { 0, 6, 0, 0, 0 };
static cilist io___38 = { 0, 0, 0, 0, 0 };
static cilist io___39 = { 0, 6, 0, 0, 0 };
static cilist io___40 = { 0, 0, 0, 0, 0 };
static cilist io___41 = { 0, 0, 0, fmt_7000, 0 };
static cilist io___42 = { 0, 0, 0, 0, 0 };
static cilist io___43 = { 0, 0, 0, 0, 0 };
static cilist io___44 = { 0, 0, 0, 0, 0 };
static cilist io___45 = { 0, 0, 0, 0, 0 };
static cilist io___46 = { 0, 0, 0, 0, 0 };
static cilist io___47 = { 0, 0, 0, 0, 0 };
static cilist io___48 = { 0, 0, 0, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___50 = { 0, 0, 0, 0, 0 };
static cilist io___51 = { 0, 0, 0, fmt_6000, 0 };
static cilist io___52 = { 0, 0, 0, fmt_6010, 0 };
static cilist io___54 = { 0, 0, 0, 0, 0 };
static cilist io___55 = { 0, 0, 0, 0, 0 };
static cilist io___56 = { 0, 0, 0, 0, 0 };
static cilist io___57 = { 0, 0, 0, 0, 0 };
static cilist io___58 = { 0, 0, 0, fmt_6020, 0 };
static cilist io___59 = { 0, 0, 0, fmt_6030, 0 };
static cilist io___60 = { 0, 0, 0, 0, 0 };
static cilist io___61 = { 0, 0, 0, 0, 0 };
static cilist io___62 = { 0, 0, 0, 0, 0 };
static cilist io___63 = { 0, 0, 0, 0, 0 };
static cilist io___64 = { 0, 0, 0, 0, 0 };
static cilist io___65 = { 0, 0, 0, fmt_6040, 0 };
static cilist io___66 = { 0, 0, 0, fmt_6010, 0 };
static cilist io___67 = { 0, 0, 0, 0, 0 };
static cilist io___68 = { 0, 0, 0, 0, 0 };
static cilist io___69 = { 0, 0, 0, 0, 0 };
static cilist io___70 = { 0, 0, 0, 0, 0 };
static cilist io___71 = { 0, 0, 0, fmt_6040, 0 };
static cilist io___72 = { 0, 0, 0, fmt_6010, 0 };
static cilist io___73 = { 0, 0, 0, 0, 0 };
static cilist io___74 = { 0, 0, 0, 0, 0 };
static cilist io___75 = { 0, 0, 0, 0, 0 };
static cilist io___76 = { 0, 0, 0, 0, 0 };
static cilist io___77 = { 0, 0, 0, fmt_6040, 0 };
static cilist io___78 = { 0, 0, 0, fmt_6010, 0 };
static cilist io___79 = { 0, 0, 0, 0, 0 };
static cilist io___80 = { 0, 0, 0, 0, 0 };
static cilist io___81 = { 0, 0, 0, fmt_7010, 0 };
static cilist io___82 = { 0, 0, 0, 0, 0 };
/* ============================== FOR MAIN =============================== */
/* DEL PARAMETER (MAXNG=107, MAXXS=10, MAXUP=48) */
/* PARAMETER DEFINISION FOR PDSMDL */
/* ------------------------------------------------------------------ */
/* PARAMETER MEANING RECOMMENDED */
/* NAME MEANING DEFAULT VALUE */
/* ------------------------------------------------------------------ */
/* MAXNG MAXIMUM FINE ENERGY GROUPS 107 */
/* MAXNGC MAXIMUM CONDENSED ENERGY GROUPS 20 */
/* MAXSTP MAXIMUM BURNUP STEPS 35 */
/* MAXNUC MAXIMUM BURNABLE NUCLIDES IN CHAIN 110 */
/* MAXZN MAXIMUM BURNABLE ZONES 50 */
/* MAXNR MAXIMUM R-REGIONS 300 */
/* MAXXS MAXIMUM XS-TYPES 10 */
/* MAXUP MAXIMUM UP-SCATTERING GROUPS 48 */
/* MAXWRK MAXIMUM LENGTH OF A PDS MEMBER 200000 */
/* ------------------------------------------------------------------ */
/* ------------------------------------------------------------------ */
/* ======================================================================= */
/* DEL PARAMETER (MAXWRK=10000) */
/* ------------------------------ INPUT ---------------------------------- */
/* DIRNAM : DIRECTORY NAME (A72) OF PDS : /XXX/XXX/MACRO01 */
/* IOUT : LOGICAL DEVICE FOR OUTPUT */
/* IPRN : =0(NO PRINT), =1(PRINT OUT IN DEVICE IOUT) */
/* MEMNAM : PDS MEMBER NAME TO EDIT(A8) */
/* NG : NUMBER OF ENERGY GROUPS CORRESPONDING TO INPUT */
/* MACRO MEMBER NAME */
/* ------------------------------ OUTPUT --------------------------------- */
/* XSEC(G,I) : MACROSCOPIC XS OF XS-TYPE:I, ENERGY GROUP:G */
/* I=1 : PRODUCTION */
/* I=2 : FISSION */
/* I=3 : CAPTURE */
/* I=4 : ABSORPTION */
/* I=5 : FISSION SPECTRUM (X) */
/* I=6 : DIFFUSION COEFFICIENT (D1) */
/* I=7 : DIFFUSION COEFFICIENT (D2) */
/* I=8 : TOTAL (ABSORPTION + SCATTERING + N,2N) OR */
/* TRANSPORT XS (DEPEND ON MEMBER NAME) */
/* I=9 : ACTIVATION XS */
/* MINSG : MIN. GROUP OF UP-SCATTERING (ALLOW MINSG.LE.0) */
/* MAXSG : MAX. GROUP OF DOWN-SCATTERING (ALLOW MAXSG.GT.NG) */
/* SCAT(G,G') : SCATTERING MATRIX (G => G') */
/* PTAG=0,2,4 ; P0 SCATTERING MATRIX + 2*(N,2N MATRIX) */
/* PTAG=1,3 : P1 SCATTERING MATRIX * 3.0 */
/* PTAG=N,M ; (N,2N) SCATTERING MATRIX */
/* XSEC(G,8) = ABS(G) + SUM-G'(SCAT(G,G')) */
/* - SUM-G'(SN2N(G,G')) */
/* DELAY(J,G,I) : DELAYED NEUTRON DATA FOR FAMILY J, ENERGY G */
/* I=1 : DELAYED BETA(J)*DELAYED-NYU.SIGF(G) */
/* I=2 : DELAYED NEUTRON FISSION SPECTRUM */
/* I=3 : DELAYED BETA(J)*DELAYED-NYU.SIGF(G)/DECAY CNST */
/* ----------------------------------------------------------------------- */
/* Parameter adjustments */
delay -= 1621;
scat -= -5135;
xsec -= 108;
/* Function Body */
if (*ng > 107) {
io___2.ciunit = *iout;
s_wsle(&io___2);
do_lio(&c__9, &c__1, " ERROR(MACEDT): NUMBER OF ENERGY GROUPS(=", (
ftnlen)41);
do_lio(&c__3, &c__1, (char *)&(*ng), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)33);
do_lio(&c__3, &c__1, (char *)&c__107, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
if (*iout != 6) {
s_wsle(&io___3);
do_lio(&c__9, &c__1, " ERROR(MACEDT): NUMBER OF ENERGY GROUPS(=",
(ftnlen)41);
do_lio(&c__3, &c__1, (char *)&(*ng), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)
33);
do_lio(&c__3, &c__1, (char *)&c__107, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
}
s_stop("", (ftnlen)0);
}
igflg = 1;
ixflg = 0;
*(unsigned char *)ptag = *(unsigned char *)&memnam[7];
if (*(unsigned char *)ptag == '0' || *(unsigned char *)ptag == '1') {
igflg = 0;
} else if (*(unsigned char *)ptag == 'Y') {
ixflg = 1;
} else if (*(unsigned char *)ptag == 'Z') {
igflg = 0;
ixflg = 1;
} else if (*(unsigned char *)ptag == 'N') {
igflg = 0;
}
/* ************************** */
/* ZERO SET *--------------------------------------------- */
/* ************************** */
for (i__ = 1; i__ <= 200000; ++i__) {
wkpds_1.work[i__ - 1] = 0.f;
/* L100: */
}
for (ig = 1; ig <= 107; ++ig) {
if (ixflg == 1) {
goto L115;
}
llss[ig - 1] = 0;
llgv[ig - 1] = 0;
for (n = 1; n <= 10; ++n) {
xsec[ig + n * 107] = 0.f;
/* L110: */
}
if (ixflg == 0) {
goto L125;
}
L115:
for (j = 1; j <= 15; ++j) {
delay[j + (ig + 107) * 15] = 0.f;
delay[j + (ig + 214) * 15] = 0.f;
delay[j + (ig + 321) * 15] = 0.f;
/* L120: */
}
if (ixflg == 1) {
goto L200;
}
L125:
for (igg = 1; igg <= 107; ++igg) {
wscat[ig + igg * 107 - 108] = 0.f;
/* L130: */
}
for (igg = -48; igg <= 107; ++igg) {
scat[ig + igg * 107] = 0.f;
/* L140: */
}
L200:
;
}
/* ************************** */
/* MACROSCOPIC XS EDIT *--------------------------------------------- */
/* ************************** */
if (ixflg != 0) {
goto L400;
}
s_copy(member, memnam, (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, member, wkpds_1.work, &leng, &irc, iout, (ftnlen)72, (
ftnlen)8);
if (irc != 0) {
io___18.ciunit = *iout;
s_wsle(&io___18);
do_lio(&c__9, &c__1, " ERROR(MACEDT): PDSIN ERROR, CODE=", (ftnlen)34)
;
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
if (*iout != 6) {
s_wsle(&io___19);
do_lio(&c__9, &c__1, " ERROR(MACEDT): PDSIN ERROR, CODE=", (
ftnlen)34);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
}
s_stop("", (ftnlen)0);
}
ic = 0;
i__1 = *ng;
for (ig = 1; ig <= i__1; ++ig) {
for (n = 1; n <= 10; ++n) {
xsec[ig + n * 107] = wkpds_1.work[ic + n - 1];
/* L310: */
}
lss = iwork[ic];
lgv = iwork[ic + 1];
if (lgv == 0) {
io___23.ciunit = *iout;
s_wsle(&io___23);
do_lio(&c__9, &c__1, " CAUTION(MACEDT): LGV=0 FOR IG=", (ftnlen)
31);
do_lio(&c__3, &c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsle();
if (*iout != 6) {
s_wsle(&io___24);
do_lio(&c__9, &c__1, " CAUTION(MACEDT): LGV=0 FOR IG=", (
ftnlen)31);
do_lio(&c__3, &c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsle();
}
}
if (lgv > 0) {
llss[ig - 1] = lss;
llgv[ig - 1] = lgv;
i__2 = lgv;
for (igg = 1; igg <= i__2; ++igg) {
wscat[ig + igg * 107 - 108] = wkpds_1.work[ic + 10 + igg - 1];
/* L320: */
}
}
ic = ic + 10 + lgv;
/* L300: */
}
i__1 = *ng;
for (ig = 1; ig <= i__1; ++ig) {
xact = xsec[ig + 321];
fiss = xsec[ig + 428];
prod = xsec[ig + 535];
totl = xsec[ig + 642];
x = xsec[ig + 749];
d1 = xsec[ig + 856];
d2 = xsec[ig + 963];
absp = xsec[ig + 1070];
xsec[ig + 107] = prod;
xsec[ig + 214] = fiss;
xsec[ig + 321] = absp - fiss;
xsec[ig + 428] = absp;
xsec[ig + 535] = x;
xsec[ig + 642] = d1;
xsec[ig + 749] = d2;
xsec[ig + 856] = totl;
xsec[ig + 963] = xact;
/* L330: */
}
/* ----- SCATTERING MATRIX ----------------------------------------------- */
*minsg = 1;
*maxsg = *ng;
i__1 = *ng;
for (ig = 1; ig <= i__1; ++ig) {
igstrt = ig - llss[ig - 1] + 1;
igstop = ig + llgv[ig - 1] - llss[ig - 1];
if (igstrt < *minsg) {
*minsg = igstrt;
}
if (igstop > *maxsg) {
*maxsg = igstop;
}
i__2 = llgv[ig - 1];
for (igg = 1; igg <= i__2; ++igg) {
scat[ig + (igstrt + igg - 1) * 107] = wscat[ig + igg * 107 - 108];
/* L350: */
}
/* L340: */
}
/* ************************** */
/* DELAYED NEUTRON DATA *--------------------------------------------- */
/* ************************** */
L400:
if (ixflg != 1) {
goto L1000;
}
s_copy(member, memnam, (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, member, wkpds_1.work, &leng, &irc, iout, (ftnlen)72, (
ftnlen)8);
if (irc != 0) {
io___35.ciunit = *iout;
s_wsle(&io___35);
do_lio(&c__9, &c__1, " ERROR(MACEDT): PDSIN ERROR, CODE=", (ftnlen)34)
;
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
if (*iout != 6) {
s_wsle(&io___36);
do_lio(&c__9, &c__1, " ERROR(MACEDT): PDSIN ERROR, CODE=", (
ftnlen)34);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
}
s_stop("", (ftnlen)0);
}
nfam = leng / *ng / 3;
if (nfam != 6 && nfam != 15) {
io___38.ciunit = *iout;
s_wsle(&io___38);
do_lio(&c__9, &c__1, " ERROR(MACEDT): NUMBER OF DELAYED NEUTRON ", (
ftnlen)42);
do_lio(&c__9, &c__1, "FAMILY(=", (ftnlen)8);
do_lio(&c__3, &c__1, (char *)&nfam, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS INVALID", (ftnlen)12);
e_wsle();
if (*iout != 6) {
s_wsle(&io___39);
do_lio(&c__9, &c__1, " ERROR(MACEDT): NUMBER OF DELAYED NEUTRON ",
(ftnlen)42);
do_lio(&c__9, &c__1, "FAMILY(=", (ftnlen)8);
do_lio(&c__3, &c__1, (char *)&nfam, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS INVALID", (ftnlen)12);
e_wsle();
}
s_stop("", (ftnlen)0);
}
i__1 = *ng;
for (ig = 1; ig <= i__1; ++ig) {
i__2 = nfam;
for (j = 1; j <= i__2; ++j) {
ic = (ig - 1) * nfam + j;
delay[j + (ig + 107) * 15] = wkpds_1.work[ic - 1];
delay[j + (ig + 214) * 15] = wkpds_1.work[*ng * nfam + ic - 1];
delay[j + (ig + 321) * 15] = wkpds_1.work[(*ng << 1) * nfam + ic
- 1];
/* L410: */
}
}
/* ************************** */
/* PRINT OUT *--------------------------------------------- */
/* ************************** */
L1000:
if (*iprn == 0) {
goto L9000;
}
io___40.ciunit = *iout;
s_wsle(&io___40);
e_wsle();
io___41.ciunit = *iout;
s_wsfe(&io___41);
e_wsfe();
io___42.ciunit = *iout;
s_wsle(&io___42);
e_wsle();
io___43.ciunit = *iout;
s_wsle(&io___43);
do_lio(&c__9, &c__1, " ********** MEMBER NAME = ", (ftnlen)28);
do_lio(&c__9, &c__1, memnam, (ftnlen)8);
do_lio(&c__9, &c__1, " **********", (ftnlen)11);
e_wsle();
io___44.ciunit = *iout;
s_wsle(&io___44);
e_wsle();
io___45.ciunit = *iout;
s_wsle(&io___45);
do_lio(&c__9, &c__1, " NG = ", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)&(*ng), (ftnlen)sizeof(integer));
e_wsle();
io___46.ciunit = *iout;
s_wsle(&io___46);
do_lio(&c__9, &c__1, " MINSG = ", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)&(*minsg), (ftnlen)sizeof(integer));
e_wsle();
io___47.ciunit = *iout;
s_wsle(&io___47);
do_lio(&c__9, &c__1, " MAXSG = ", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)&(*maxsg), (ftnlen)sizeof(integer));
e_wsle();
if (ixflg == 0) {
io___48.ciunit = *iout;
s_wsle(&io___48);
e_wsle();
io___49.ciunit = *iout;
s_wsle(&io___49);
do_lio(&c__9, &c__1, " --- MACROSCPIC CROSS SECTION ---", (ftnlen)
35);
e_wsle();
io___50.ciunit = *iout;
s_wsle(&io___50);
e_wsle();
io___51.ciunit = *iout;
s_wsfe(&io___51);
e_wsfe();
i__2 = *ng;
for (ig = 1; ig <= i__2; ++ig) {
io___52.ciunit = *iout;
s_wsfe(&io___52);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
for (ir = 1; ir <= 9; ++ir) {
do_fio(&c__1, (char *)&xsec[ig + ir * 107], (ftnlen)sizeof(
real));
}
e_wsfe();
/* L1010: */
}
io___54.ciunit = *iout;
s_wsle(&io___54);
e_wsle();
io___55.ciunit = *iout;
s_wsle(&io___55);
e_wsle();
io___56.ciunit = *iout;
s_wsle(&io___56);
do_lio(&c__9, &c__1, " --- SCATTERING MATRIX(G=>G') ---", (ftnlen)
35);
e_wsle();
io___57.ciunit = *iout;
s_wsle(&io___57);
e_wsle();
io___58.ciunit = *iout;
s_wsfe(&io___58);
i__2 = *maxsg;
for (i__ = *minsg; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *ng;
for (ig = 1; ig <= i__2; ++ig) {
io___59.ciunit = *iout;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
i__1 = *maxsg;
for (igg = *minsg; igg <= i__1; ++igg) {
do_fio(&c__1, (char *)&scat[ig + igg * 107], (ftnlen)sizeof(
real));
}
e_wsfe();
/* L1020: */
}
io___60.ciunit = *iout;
s_wsle(&io___60);
e_wsle();
} else {
io___61.ciunit = *iout;
s_wsle(&io___61);
e_wsle();
io___62.ciunit = *iout;
s_wsle(&io___62);
e_wsle();
io___63.ciunit = *iout;
s_wsle(&io___63);
do_lio(&c__9, &c__1, " --- DELAYED NEUTRON DATA (D-PRODUCTION) --- "
, (ftnlen)47);
e_wsle();
io___64.ciunit = *iout;
s_wsle(&io___64);
e_wsle();
io___65.ciunit = *iout;
s_wsfe(&io___65);
i__2 = nfam;
for (j = 1; j <= i__2; ++j) {
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *ng;
for (ig = 1; ig <= i__2; ++ig) {
io___66.ciunit = *iout;
s_wsfe(&io___66);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
i__1 = nfam;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&delay[j + (ig + 107) * 15], (ftnlen)
sizeof(real));
}
e_wsfe();
/* L1030: */
}
io___67.ciunit = *iout;
s_wsle(&io___67);
e_wsle();
io___68.ciunit = *iout;
s_wsle(&io___68);
e_wsle();
io___69.ciunit = *iout;
s_wsle(&io___69);
do_lio(&c__9, &c__1, " --- DELAYED NEUTRON DATA (D-FISS.SPECTR) --"
"- ", (ftnlen)48);
e_wsle();
io___70.ciunit = *iout;
s_wsle(&io___70);
e_wsle();
io___71.ciunit = *iout;
s_wsfe(&io___71);
i__2 = nfam;
for (j = 1; j <= i__2; ++j) {
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *ng;
for (ig = 1; ig <= i__2; ++ig) {
io___72.ciunit = *iout;
s_wsfe(&io___72);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
i__1 = nfam;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&delay[j + (ig + 214) * 15], (ftnlen)
sizeof(real));
}
e_wsfe();
/* L1040: */
}
io___73.ciunit = *iout;
s_wsle(&io___73);
e_wsle();
io___74.ciunit = *iout;
s_wsle(&io___74);
e_wsle();
io___75.ciunit = *iout;
s_wsle(&io___75);
do_lio(&c__9, &c__1, " --- DELAYED NEUTRON DATA (INV.DECAY CST) --"
"- ", (ftnlen)48);
e_wsle();
io___76.ciunit = *iout;
s_wsle(&io___76);
e_wsle();
io___77.ciunit = *iout;
s_wsfe(&io___77);
i__2 = nfam;
for (j = 1; j <= i__2; ++j) {
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *ng;
for (ig = 1; ig <= i__2; ++ig) {
io___78.ciunit = *iout;
s_wsfe(&io___78);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
i__1 = nfam;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&delay[j + (ig + 321) * 15], (ftnlen)
sizeof(real));
}
e_wsfe();
/* L1050: */
}
io___79.ciunit = *iout;
s_wsle(&io___79);
e_wsle();
}
io___80.ciunit = *iout;
s_wsle(&io___80);
e_wsle();
io___81.ciunit = *iout;
s_wsfe(&io___81);
e_wsfe();
io___82.ciunit = *iout;
s_wsle(&io___82);
e_wsle();
L9000:
return 0;
} /* macedt_ */
/* * /////////////////////////////////////////////////////////////////////////// */
/* Subroutine */ int newdriv_(integer *iparm, doublereal *rparm, integer *
iwork, doublereal *rwork, doublereal *u, doublereal *xf, doublereal *
yf, doublereal *zf, doublereal *gxcf, doublereal *gycf, doublereal *
gzcf, doublereal *a1cf, doublereal *a2cf, doublereal *a3cf,
doublereal *ccf, doublereal *fcf, doublereal *tcf)
{
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Local variables */
extern /* Subroutine */ int newdriv2_(integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
static integer nc, nf, nx, ny, nz, nxc, nyc, nzc, k_w1__, k_w2__, k_ac__,
k_cc__, k_fc__, k_pc__, k_iz__, n_iz__, narr, nlev, niwk;
extern /* Subroutine */ int mgsz_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *);
static integer nrwk, mxlv, k_ipc__, n_ipc__, k_rpc__, n_rpc__, narrc,
mgdisc, mgcoar;
extern integer maxlev_(integer *, integer *, integer *);
static integer ierror, iretot, iintot, mgsolv;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 6, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, 0, 0 };
static cilist io___26 = { 0, 6, 0, 0, 0 };
static cilist io___27 = { 0, 6, 0, 0, 0 };
/* * ********************************************************************* */
/* * purpose: */
/* * */
/* * driver for a screaming inexact-newton-multilevel solver. */
/* * */
/* * author: michael holst */
/* * ********************************************************************* */
/* * */
/* * *** input parameters *** */
/* * */
/* * *** variables returned from mgsz *** */
/* * */
/* * *** misc variables *** */
/* * */
/* * *** decode some parameters *** */
/* Parameter adjustments */
--tcf;
--fcf;
--ccf;
--a3cf;
--a2cf;
--a1cf;
--gzcf;
--gycf;
--gxcf;
--zf;
--yf;
--xf;
--u;
--rwork;
--iwork;
--rparm;
--iparm;
/* Function Body */
nrwk = iparm[1];
niwk = iparm[2];
nx = iparm[3];
ny = iparm[4];
nz = iparm[5];
nlev = iparm[6];
/* * */
/* * *** some checks on input *** */
if (nlev <= 0 || nx <= 0 || ny <= 0 || nz <= 0) {
s_wsle(&io___7);
do_lio(&c__9, &c__1, "% NEWDRIV: nx,ny,nz, and nlev must be positiv"
"e...", (ftnlen)50);
e_wsle();
ierror = -1;
iparm[51] = ierror;
return 0;
}
mxlv = maxlev_(&nx, &ny, &nz);
if (nlev > mxlv) {
s_wsle(&io___10);
do_lio(&c__9, &c__1, "% NEWDRIV: max levels for your grid size is: ",
(ftnlen)46);
do_lio(&c__3, &c__1, (char *)&mxlv, (ftnlen)sizeof(integer));
e_wsle();
ierror = -2;
iparm[51] = ierror;
return 0;
}
/* * */
/* * *** basic grid sizes, etc. *** */
mgcoar = iparm[18];
mgdisc = iparm[19];
mgsolv = iparm[21];
mgsz_(&mgcoar, &mgdisc, &mgsolv, &nx, &ny, &nz, &nlev, &nxc, &nyc, &nzc, &
nf, &nc, &narr, &narrc, &n_rpc__, &n_iz__, &n_ipc__, &iretot, &
iintot);
/* * */
/* * *** allocate space for two additional work vectors *** */
iretot += nf << 1;
/* * */
/* * *** some more checks on input *** */
if (nrwk < iretot || niwk < iintot) {
s_wsle(&io___26);
do_lio(&c__9, &c__1, "% NEWDRIV: real work space must be: ", (
ftnlen)39);
do_lio(&c__3, &c__1, (char *)&iretot, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___27);
do_lio(&c__9, &c__1, "% NEWDRIV: integer work space must be: ", (
ftnlen)39);
do_lio(&c__3, &c__1, (char *)&iintot, (ftnlen)sizeof(integer));
e_wsle();
ierror = -3;
iparm[51] = ierror;
return 0;
}
/* * */
/* * *** split up the integer work array *** */
k_iz__ = 1;
k_ipc__ = k_iz__ + n_iz__;
/* * */
/* * *** split up the real work array *** */
k_rpc__ = 1;
k_cc__ = k_rpc__ + n_rpc__;
k_fc__ = k_cc__ + narr;
k_w1__ = k_fc__ + narr;
k_w2__ = k_w1__ + nf;
k_pc__ = k_w2__ + nf;
k_ac__ = k_pc__ + narrc * 27;
/* * ***k_ac_after = 4*nf + 14*narrc */
/* * */
/* * *** call the multigrid driver *** */
newdriv2_(&iparm[1], &rparm[1], &nx, &ny, &nz, &u[1], &iwork[k_iz__], &
rwork[k_w1__], &rwork[k_w2__], &iwork[k_ipc__], &rwork[k_rpc__], &
rwork[k_pc__], &rwork[k_ac__], &rwork[k_cc__], &rwork[k_fc__], &
xf[1], &yf[1], &zf[1], &gxcf[1], &gycf[1], &gzcf[1], &a1cf[1], &
a2cf[1], &a3cf[1], &ccf[1], &fcf[1], &tcf[1]);
/* * */
/* * *** return and end *** */
return 0;
} /* newdriv_ */
/* Main program */ int MAIN__(void)
{
/* Initialized data */
static doublereal threq = 2.;
static char intstr[10] = "0123456789";
/* Format strings */
static char fmt_9994[] = "(\002 Tests of the COMPLEX*16 LAPACK routines"
" \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002.\002,i1,/"
"/\002 The following parameter values will be used:\002)";
static char fmt_9996[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
"6,\002; must be >=\002,i6)";
static char fmt_9995[] = "(\002 Invalid input value: \002,a4,\002=\002,i"
"6,\002; must be <=\002,i6)";
static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
"st ratio is \002,\002less than\002,f8.2,/)";
static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
"rors\002)";
static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
" be\002,d16.6)";
static char fmt_9990[] = "(/1x,a3,\002: Unrecognized path name\002)";
static char fmt_9989[] = "(/1x,a3,\002 routines were not tested\002)";
static char fmt_9988[] = "(/1x,a3,\002 driver routines were not teste"
"d\002)";
static char fmt_9998[] = "(/\002 End of tests\002)";
static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
"nds\002,/)";
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
cilist ci__1;
cllist cl__1;
/* Builtin functions */
integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
, char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
char *, ftnlen);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsle(cilist *), e_wsle(void), s_rsfe(cilist *), e_rsfe(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer f_clos(cllist *);
/* Local variables */
doublecomplex a[153384] /* was [21912][7] */, b[8448] /* was [2112][
4] */;
integer i__, j, k;
doublereal s[264];
char c1[1], c2[2];
doublereal s1, s2;
integer ic, la, nb, nm, nn, vers_patch__, vers_major__, vers_minor__, lda,
nnb;
doublereal eps;
integer nns, nnb2;
char path[3];
integer mval[12], nval[12], nrhs;
doublecomplex work[20856] /* was [132][158] */;
integer lafac;
logical fatal;
char aline[72];
extern logical lsame_(char *, char *);
integer nbval[12], nmats, nsval[12], nxval[12], iwork[3300];
doublereal rwork[19832];
integer nbval2[12];
extern /* Subroutine */ int zchkq3_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, doublecomplex *, doublecomplex *, doublereal *, doublereal *,
doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *);
extern doublereal dlamch_(char *), dsecnd_(void);
extern /* Subroutine */ int alareq_(char *, integer *, logical *, integer
*, integer *, integer *), zchkgb_(logical *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, doublereal *, logical *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zchkge_(logical *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, logical *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *, integer *), zchkhe_(
logical *, integer *, integer *, integer *, integer *, integer *,
integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int zchkpb_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *, logical
*, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublereal *, integer *), ilaver_(integer *, integer *, integer
*), zchkeq_(doublereal *, integer *), zchktb_(logical *, integer *
, integer *, integer *, integer *, doublereal *, logical *,
integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
integer *), zchkhp_(logical *, integer *, integer *, integer *,
integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zchkgt_(logical *, integer *, integer *, integer *,
integer *, doublereal *, logical *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *, integer *), zchklq_(
logical *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, logical *, integer
*, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *);
doublereal thresh;
extern /* Subroutine */ int zchkpo_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *, logical
*, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublereal *, integer *), zchkpp_(logical *, integer *, integer
*, integer *, integer *, doublereal *, logical *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
integer *);
logical tstchk;
extern /* Subroutine */ int zchkql_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zchkpt_(logical *, integer *, integer *, integer *,
integer *, doublereal *, logical *, doublecomplex *, doublereal *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex
*, doublecomplex *, doublereal *, integer *);
logical dotype[30];
extern /* Subroutine */ int zchkqp_(logical *, integer *, integer *,
integer *, integer *, doublereal *, logical *, doublecomplex *,
doublecomplex *, doublereal *, doublereal *, doublecomplex *,
doublecomplex *, doublereal *, integer *, integer *), zchkqr_(
logical *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, logical *, integer
*, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *), zchkrq_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zchksp_(logical *, integer *, integer *, integer *,
integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zchktp_(logical *, integer *, integer *, integer *,
integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *), zchktr_(logical *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *), zchksy_(logical *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, integer *,
integer *), zdrvgb_(logical *, integer *, integer *, integer *,
doublereal *, logical *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
doublecomplex *, doublereal *, integer *, integer *), zchktz_(
logical *, integer *, integer *, integer *, integer *, doublereal
*, logical *, doublecomplex *, doublecomplex *, doublereal *,
doublereal *, doublecomplex *, doublecomplex *, doublereal *,
integer *), zdrvge_(logical *, integer *, integer *, integer *,
doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
doublereal *, integer *, integer *), zdrvhe_(logical *, integer *
, integer *, integer *, doublereal *, logical *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublecomplex *, doublereal *,
integer *, integer *), zdrvgt_(logical *, integer *, integer *,
integer *, doublereal *, logical *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *, integer *), zdrvhp_(
logical *, integer *, integer *, integer *, doublereal *, logical
*, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublereal *, integer *, integer *);
integer ntypes;
logical tsterr;
extern /* Subroutine */ int zdrvls_(logical *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, doublereal *, logical *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublereal *, doublereal *, doublecomplex *, doublereal *,
integer *, integer *);
logical tstdrv;
extern /* Subroutine */ int zdrvpb_(logical *, integer *, integer *,
integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
doublereal *, integer *), zdrvpo_(logical *, integer *, integer *
, integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
doublereal *, integer *), zdrvpp_(logical *, integer *, integer *
, integer *, doublereal *, logical *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublecomplex *, doublereal *, doublecomplex *,
doublereal *, integer *), zdrvpt_(logical *, integer *, integer *
, integer *, doublereal *, logical *, doublecomplex *, doublereal
*, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublereal *, integer *),
zdrvsp_(logical *, integer *, integer *, integer *, doublereal *,
logical *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublecomplex *, doublereal *, integer *, integer *), zdrvsy_(
logical *, integer *, integer *, integer *, doublereal *, logical
*, integer *, doublecomplex *, doublecomplex *, doublecomplex *,
doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex *
, doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 5, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___11 = { 0, 5, 0, 0, 0 };
static cilist io___13 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___14 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___15 = { 0, 5, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___19 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___20 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___21 = { 0, 5, 0, 0, 0 };
static cilist io___23 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___24 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___25 = { 0, 5, 0, 0, 0 };
static cilist io___27 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___28 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___29 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___30 = { 0, 5, 0, 0, 0 };
static cilist io___32 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___33 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___34 = { 0, 5, 0, 0, 0 };
static cilist io___36 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___37 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___38 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___39 = { 0, 5, 0, 0, 0 };
static cilist io___41 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___42 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___43 = { 0, 5, 0, 0, 0 };
static cilist io___45 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___46 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___51 = { 0, 5, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___54 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___55 = { 0, 5, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___58 = { 0, 5, 0, 0, 0 };
static cilist io___60 = { 0, 5, 0, 0, 0 };
static cilist io___62 = { 0, 5, 0, 0, 0 };
static cilist io___64 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___66 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___67 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___69 = { 0, 6, 0, 0, 0 };
static cilist io___78 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___79 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___87 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___89 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___92 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___93 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___94 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___95 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___96 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___97 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___98 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___99 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___100 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___101 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___102 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___103 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___104 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___105 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___106 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___107 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___108 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___109 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___110 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___111 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___112 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___113 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___114 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___115 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___116 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___117 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___118 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___119 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___120 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___121 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___122 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___123 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___125 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___126 = { 0, 6, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* January 2007 */
/* Purpose */
/* ======= */
/* ZCHKAA is the main test program for the COMPLEX*16 linear equation */
/* routines. */
/* The program must be driven by a short data file. The first 14 records */
/* specify problem dimensions and program options using list-directed */
/* input. The remaining lines specify the LAPACK test paths and the */
/* number of matrix types to use in testing. An annotated example of a */
/* data file can be obtained by deleting the first 3 characters from the */
/* following 38 lines: */
/* Data file for testing COMPLEX*16 LAPACK linear equation routines */
/* 7 Number of values of M */
/* 0 1 2 3 5 10 16 Values of M (row dimension) */
/* 7 Number of values of N */
/* 0 1 2 3 5 10 16 Values of N (column dimension) */
/* 1 Number of values of NRHS */
/* 2 Values of NRHS (number of right hand sides) */
/* 5 Number of values of NB */
/* 1 3 3 3 20 Values of NB (the blocksize) */
/* 1 0 5 9 1 Values of NX (crossover point) */
/* 30.0 Threshold value of test ratio */
/* T Put T to test the LAPACK routines */
/* T Put T to test the driver routines */
/* T Put T to test the error exits */
/* ZGE 11 List types on next line if 0 < NTYPES < 11 */
/* ZGB 8 List types on next line if 0 < NTYPES < 8 */
/* ZGT 12 List types on next line if 0 < NTYPES < 12 */
/* ZPO 9 List types on next line if 0 < NTYPES < 9 */
/* ZPP 9 List types on next line if 0 < NTYPES < 9 */
/* ZPB 8 List types on next line if 0 < NTYPES < 8 */
/* ZPT 12 List types on next line if 0 < NTYPES < 12 */
/* ZHE 10 List types on next line if 0 < NTYPES < 10 */
/* ZHP 10 List types on next line if 0 < NTYPES < 10 */
/* ZSY 11 List types on next line if 0 < NTYPES < 11 */
/* ZSP 11 List types on next line if 0 < NTYPES < 11 */
/* ZTR 18 List types on next line if 0 < NTYPES < 18 */
/* ZTP 18 List types on next line if 0 < NTYPES < 18 */
/* ZTB 17 List types on next line if 0 < NTYPES < 17 */
/* ZQR 8 List types on next line if 0 < NTYPES < 8 */
/* ZRQ 8 List types on next line if 0 < NTYPES < 8 */
/* ZLQ 8 List types on next line if 0 < NTYPES < 8 */
/* ZQL 8 List types on next line if 0 < NTYPES < 8 */
/* ZQP 6 List types on next line if 0 < NTYPES < 6 */
/* ZTZ 3 List types on next line if 0 < NTYPES < 3 */
/* ZLS 6 List types on next line if 0 < NTYPES < 6 */
/* ZEQ */
/* Internal Parameters */
/* =================== */
/* NMAX INTEGER */
/* The maximum allowable value for N. */
/* MAXIN INTEGER */
/* The number of different values that can be used for each of */
/* M, N, or NB */
/* MAXRHS INTEGER */
/* The maximum number of right hand sides */
/* NIN INTEGER */
/* The unit number for input */
/* NOUT INTEGER */
/* The unit number for output */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Arrays in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
s1 = dsecnd_();
lda = 132;
fatal = FALSE_;
/* Read a dummy line. */
s_rsle(&io___6);
e_rsle();
/* Report values of parameters. */
ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
s_wsfe(&io___10);
do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
e_wsfe();
/* Read the values of M */
s_rsle(&io___11);
do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
e_rsle();
if (nm < 1) {
s_wsfe(&io___13);
do_fio(&c__1, " NM ", (ftnlen)4);
do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nm = 0;
fatal = TRUE_;
} else if (nm > 12) {
s_wsfe(&io___14);
do_fio(&c__1, " NM ", (ftnlen)4);
do_fio(&c__1, (char *)&nm, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nm = 0;
fatal = TRUE_;
}
s_rsle(&io___15);
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
if (mval[i__ - 1] < 0) {
s_wsfe(&io___18);
do_fio(&c__1, " M ", (ftnlen)4);
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (mval[i__ - 1] > 132) {
s_wsfe(&io___19);
do_fio(&c__1, " M ", (ftnlen)4);
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L10: */
}
if (nm > 0) {
s_wsfe(&io___20);
do_fio(&c__1, "M ", (ftnlen)4);
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the values of N */
s_rsle(&io___21);
do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
e_rsle();
if (nn < 1) {
s_wsfe(&io___23);
do_fio(&c__1, " NN ", (ftnlen)4);
do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nn = 0;
fatal = TRUE_;
} else if (nn > 12) {
s_wsfe(&io___24);
do_fio(&c__1, " NN ", (ftnlen)4);
do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nn = 0;
fatal = TRUE_;
}
s_rsle(&io___25);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nval[i__ - 1] < 0) {
s_wsfe(&io___27);
do_fio(&c__1, " N ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (nval[i__ - 1] > 132) {
s_wsfe(&io___28);
do_fio(&c__1, " N ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__132, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L20: */
}
if (nn > 0) {
s_wsfe(&io___29);
do_fio(&c__1, "N ", (ftnlen)4);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the values of NRHS */
s_rsle(&io___30);
do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
e_rsle();
if (nns < 1) {
s_wsfe(&io___32);
do_fio(&c__1, " NNS", (ftnlen)4);
do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nns = 0;
fatal = TRUE_;
} else if (nns > 12) {
s_wsfe(&io___33);
do_fio(&c__1, " NNS", (ftnlen)4);
do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nns = 0;
fatal = TRUE_;
}
s_rsle(&io___34);
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nsval[i__ - 1] < 0) {
s_wsfe(&io___36);
do_fio(&c__1, "NRHS", (ftnlen)4);
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (nsval[i__ - 1] > 16) {
s_wsfe(&io___37);
do_fio(&c__1, "NRHS", (ftnlen)4);
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L30: */
}
if (nns > 0) {
s_wsfe(&io___38);
do_fio(&c__1, "NRHS", (ftnlen)4);
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the values of NB */
s_rsle(&io___39);
do_lio(&c__3, &c__1, (char *)&nnb, (ftnlen)sizeof(integer));
e_rsle();
if (nnb < 1) {
s_wsfe(&io___41);
do_fio(&c__1, "NNB ", (ftnlen)4);
do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nnb = 0;
fatal = TRUE_;
} else if (nnb > 12) {
s_wsfe(&io___42);
do_fio(&c__1, "NNB ", (ftnlen)4);
do_fio(&c__1, (char *)&nnb, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nnb = 0;
fatal = TRUE_;
}
s_rsle(&io___43);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nbval[i__ - 1] < 0) {
s_wsfe(&io___45);
do_fio(&c__1, " NB ", (ftnlen)4);
do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L40: */
}
if (nnb > 0) {
s_wsfe(&io___46);
do_fio(&c__1, "NB ", (ftnlen)4);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Set NBVAL2 to be the set of unique values of NB */
nnb2 = 0;
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
nb = nbval[i__ - 1];
i__2 = nnb2;
for (j = 1; j <= i__2; ++j) {
if (nb == nbval2[j - 1]) {
goto L60;
}
/* L50: */
}
++nnb2;
nbval2[nnb2 - 1] = nb;
L60:
;
}
/* Read the values of NX */
s_rsle(&io___51);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nxval[i__ - 1] < 0) {
s_wsfe(&io___53);
do_fio(&c__1, " NX ", (ftnlen)4);
do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L70: */
}
if (nnb > 0) {
s_wsfe(&io___54);
do_fio(&c__1, "NX ", (ftnlen)4);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the threshold value for the test ratios. */
s_rsle(&io___55);
do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_rsle();
s_wsfe(&io___57);
do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_wsfe();
/* Read the flag that indicates whether to test the LAPACK routines. */
s_rsle(&io___58);
do_lio(&c__8, &c__1, (char *)&tstchk, (ftnlen)sizeof(logical));
e_rsle();
/* Read the flag that indicates whether to test the driver routines. */
s_rsle(&io___60);
do_lio(&c__8, &c__1, (char *)&tstdrv, (ftnlen)sizeof(logical));
e_rsle();
/* Read the flag that indicates whether to test the error exits. */
s_rsle(&io___62);
do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
e_rsle();
if (fatal) {
s_wsfe(&io___64);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* Calculate and print the machine dependent constants. */
eps = dlamch_("Underflow threshold");
s_wsfe(&io___66);
do_fio(&c__1, "underflow", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Overflow threshold");
s_wsfe(&io___67);
do_fio(&c__1, "overflow ", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Epsilon");
s_wsfe(&io___68);
do_fio(&c__1, "precision", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
s_wsle(&io___69);
e_wsle();
nrhs = nsval[0];
L80:
/* Read a test path and the number of matrix types to use. */
ci__1.cierr = 0;
ci__1.ciend = 1;
ci__1.ciunit = 5;
ci__1.cifmt = "(A72)";
i__1 = s_rsfe(&ci__1);
if (i__1 != 0) {
goto L140;
}
i__1 = do_fio(&c__1, aline, (ftnlen)72);
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L140;
}
s_copy(path, aline, (ftnlen)3, (ftnlen)3);
nmats = 30;
i__ = 3;
L90:
++i__;
if (i__ > 72) {
goto L130;
}
if (*(unsigned char *)&aline[i__ - 1] == ' ') {
goto L90;
}
nmats = 0;
L100:
*(unsigned char *)c1 = *(unsigned char *)&aline[i__ - 1];
for (k = 1; k <= 10; ++k) {
if (*(unsigned char *)c1 == *(unsigned char *)&intstr[k - 1]) {
ic = k - 1;
goto L120;
}
/* L110: */
}
goto L130;
L120:
nmats = nmats * 10 + ic;
++i__;
if (i__ > 72) {
goto L130;
}
goto L100;
L130:
*(unsigned char *)c1 = *(unsigned char *)path;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Check first character for correct precision. */
if (! lsame_(c1, "Zomplex precision")) {
s_wsfe(&io___78);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else if (nmats <= 0) {
/* Check for a positive number of tests requested. */
s_wsfe(&io___79);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else if (lsamen_(&c__2, c2, "GE")) {
/* GE: general matrices */
ntypes = 11;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkge_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
&thresh, &tsterr, &lda, a, &a[21912], &a[43824], b, &b[
2112], &b[4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___87);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvge_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___89);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "GB")) {
/* GB: general banded matrices */
la = 43692;
lafac = 65472;
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkgb_(dotype, &nm, mval, &nn, nval, &nnb2, nbval2, &nns, nsval,
&thresh, &tsterr, a, &la, &a[43824], &lafac, b, &b[2112],
&b[4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___92);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvgb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &la, &a[
43824], &lafac, &a[109560], b, &b[2112], &b[4224], &b[
6336], s, work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___93);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "GT")) {
/* GT: general tridiagonal matrices */
ntypes = 12;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkgt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, &a[
21912], b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___94);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvgt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, &a[21912],
b, &b[2112], &b[4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___95);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PO")) {
/* PO: positive definite matrices */
ntypes = 9;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkpo_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
4224], work, rwork, &c__6);
} else {
s_wsfe(&io___96);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvpo_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
work, rwork, &c__6);
} else {
s_wsfe(&io___97);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PP")) {
/* PP: positive definite packed matrices */
ntypes = 9;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkpp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
&a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
&c__6);
} else {
s_wsfe(&io___98);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvpp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
work, rwork, &c__6);
} else {
s_wsfe(&io___99);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PB")) {
/* PB: positive definite banded matrices */
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkpb_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
4224], work, rwork, &c__6);
} else {
s_wsfe(&io___100);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvpb_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], &b[6336], s,
work, rwork, &c__6);
} else {
s_wsfe(&io___101);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PT")) {
/* PT: positive definite tridiagonal matrices */
ntypes = 12;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkpt_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, a, s, &
a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
} else {
s_wsfe(&io___102);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvpt_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, a, s, &a[
21912], b, &b[2112], &b[4224], work, rwork, &c__6);
} else {
s_wsfe(&io___103);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "HE")) {
/* HE: Hermitian indefinite matrices */
ntypes = 10;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkhe_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___104);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvhe_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___105);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "HP")) {
/* HP: Hermitian indefinite packed matrices */
ntypes = 10;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkhp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
&a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___106);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvhp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___107);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "SY")) {
/* SY: symmetric indefinite matrices */
ntypes = 11;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchksy_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
tsterr, &lda, a, &a[21912], &a[43824], b, &b[2112], &b[
4224], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___108);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvsy_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___109);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "SP")) {
/* SP: symmetric indefinite packed matrices */
ntypes = 11;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchksp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
&a[21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___110);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
if (tstdrv) {
zdrvsp_(dotype, &nn, nval, &nrhs, &thresh, &tsterr, &lda, a, &a[
21912], &a[43824], b, &b[2112], &b[4224], work, rwork,
iwork, &c__6);
} else {
s_wsfe(&io___111);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "TR")) {
/* TR: triangular matrices */
ntypes = 18;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchktr_(dotype, &nn, nval, &nnb2, nbval2, &nns, nsval, &thresh, &
tsterr, &lda, a, &a[21912], b, &b[2112], &b[4224], work,
rwork, &c__6);
} else {
s_wsfe(&io___112);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "TP")) {
/* TP: triangular packed matrices */
ntypes = 18;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchktp_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
&a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
} else {
s_wsfe(&io___113);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "TB")) {
/* TB: triangular banded matrices */
ntypes = 17;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchktb_(dotype, &nn, nval, &nns, nsval, &thresh, &tsterr, &lda, a,
&a[21912], b, &b[2112], &b[4224], work, rwork, &c__6);
} else {
s_wsfe(&io___114);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "QR")) {
/* QR: QR factorization */
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkqr_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
rwork, iwork, &c__6);
} else {
s_wsfe(&io___115);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "LQ")) {
/* LQ: LQ factorization */
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchklq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
rwork, iwork, &c__6);
} else {
s_wsfe(&io___116);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "QL")) {
/* QL: QL factorization */
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkql_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
rwork, iwork, &c__6);
} else {
s_wsfe(&io___117);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "RQ")) {
/* RQ: RQ factorization */
ntypes = 8;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkrq_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &nrhs, &
thresh, &tsterr, &c__132, a, &a[21912], &a[43824], &a[
65736], &a[87648], b, &b[2112], &b[4224], &b[6336], work,
rwork, iwork, &c__6);
} else {
s_wsfe(&io___118);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "EQ")) {
/* EQ: Equilibration routines for general and positive definite */
/* matrices (THREQ should be between 2 and 10) */
if (tstchk) {
zchkeq_(&threq, &c__6);
} else {
s_wsfe(&io___119);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "TZ")) {
/* TZ: Trapezoidal matrix */
ntypes = 3;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchktz_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
21912], s, &s[132], b, work, rwork, &c__6);
} else {
s_wsfe(&io___120);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "QP")) {
/* QP: QR factorization with pivoting */
ntypes = 6;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstchk) {
zchkqp_(dotype, &nm, mval, &nn, nval, &thresh, &tsterr, a, &a[
21912], s, &s[132], b, work, rwork, iwork, &c__6);
zchkq3_(dotype, &nm, mval, &nn, nval, &nnb, nbval, nxval, &thresh,
a, &a[21912], s, &s[132], b, work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___121);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "LS")) {
/* LS: Least squares drivers */
ntypes = 6;
alareq_(path, &nmats, dotype, &ntypes, &c__5, &c__6);
if (tstdrv) {
zdrvls_(dotype, &nm, mval, &nn, nval, &nns, nsval, &nnb, nbval,
nxval, &thresh, &tsterr, a, &a[21912], &a[43824], &a[
65736], &a[87648], s, &s[132], work, rwork, iwork, &c__6);
} else {
s_wsfe(&io___122);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else {
s_wsfe(&io___123);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
/* Go back to get another input line. */
goto L80;
/* Branch to this line when the last record is read. */
L140:
cl__1.cerr = 0;
cl__1.cunit = 5;
cl__1.csta = 0;
f_clos(&cl__1);
s2 = dsecnd_();
s_wsfe(&io___125);
e_wsfe();
s_wsfe(&io___126);
d__1 = s2 - s1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
/* End of ZCHKAA */
return 0;
} /* MAIN__ */
/*< >*/
/* Subroutine */ int iapibrdf_(integer *pild, doublereal *pxlt, doublereal *
prl, doublereal *ptl, doublereal *prs, integer *pihs, doublereal *pc,
integer *mu, integer *np, doublereal *rm, doublereal *rp, doublereal *
brdfint)
{
/* System generated locals */
integer rm_offset, brdfint_dim1, brdfint_offset, i__1, i__2;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle();
/* Subroutine */ int s_stop(char *, ftnlen);
double acos(doublereal);
/* Local variables */
integer j, k;
doublereal fi, mu1, mu2;
extern /* Subroutine */ int lad_();
integer ihs;
extern doublereal ro_1__(doublereal *, doublereal *, doublereal *,
doublereal *);
doublereal phi_i__, phi_v__;
extern /* Subroutine */ int solve_(doublereal *), gauleg_(doublereal *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal theta_i__, theta_v__;
/* Fortran I/O blocks */
static cilist io___2 = { 0, 6, 0, 0, 0 };
static cilist io___3 = { 0, 6, 0, 0, 0 };
static cilist io___4 = { 0, 6, 0, 0, 0 };
static cilist io___5 = { 0, 6, 0, 0, 0 };
static cilist io___6 = { 0, 6, 0, 0, 0 };
static cilist io___7 = { 0, 6, 0, 0, 0 };
static cilist io___8 = { 0, 6, 0, 0, 0 };
static cilist io___9 = { 0, 6, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, 0, 0 };
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___12 = { 0, 6, 0, 0, 0 };
static cilist io___13 = { 0, 6, 0, 0, 0 };
static cilist io___14 = { 0, 6, 0, 0, 0 };
/* interface between the computer code of the model of Iaquinta and Pinty
*/
/* the computer code is courtesy of Jean Ianquinta */
/* see module IAPITOOLS.f for a complete description */
/*< integer np,mu >*/
/*< real rm(-mu:mu),rp(np),brdfint(-mu:mu,np) >*/
/*< real ro_1 >*/
/*< integer iwr,k,j >*/
/*< integer pild,pihs >*/
/*< real pxlt,prl,ptl,prs,pc >*/
/*< logical ier >*/
/*< common/sixs_ier/iwr,ier >*/
/*< real mu1,mu2,fi >*/
/*< real pi >*/
/* begin of Iaquinta and Pinty model parameter and declaration */
/*< parameter (Pi=3.141592653589793) >*/
/*< common /gauss_m/xgm (20),wgm (20),n >*/
/*< real xgm,wgm >*/
/*< integer n >*/
/*< common /p/xLt,Rl,Tl,Rs,c,ild >*/
/*< real xLt,Rl,Tl,Rs,c >*/
/*< integer ild >*/
/*< common /ld/a_ld,b_ld,c_ld,d_ld >*/
/*< real a_ld,b_ld,c_ld,d_ld >*/
/*< common /Ro/Ro_1_c,Ro_1_s,Ro_mult >*/
/*< real Ro_1_c,Ro_1_s,Ro_mult >*/
/*< real Theta_i,Phi_i >*/
/*< real Theta_v,Phi_v >*/
/*< integer ihs >*/
/* xLt = leaf area index */
/* Rl = leaf reflection coefficient (Bi-Lambertian) */
/* Tl = leaf transmission coefficient (Bi-Lambertian) */
/* ild = leaf angle distribution : */
/* 1 = planophile */
/* 2 = erectophile */
/* 3 = plagiophile */
/* 4 = extremophile */
/* 5 = uniform */
/* Rs = soil albedo */
/* c = 2*r*Lambda */
/* Ro_1_c = single scattering by the canopy term */
/* Ro_1_s = uncollided by the leaves (or singly scattered by */
/* the soil) radiation */
/* (Ro_1 = Ro_1_c + Ro_1_s) */
/* Ro_mult = multiple scattering */
/* transfer paramater to common / / parameter struture */
/*< ild=pild >*/
/* Parameter adjustments */
rm_offset = -(*mu);
rm -= rm_offset;
brdfint_dim1 = *mu - (-(*mu)) + 1;
brdfint_offset = -(*mu) + brdfint_dim1;
brdfint -= brdfint_offset;
--rp;
/* Function Body */
p_1.ild = *pild;
/*< Xlt=pXlt >*/
p_1.xlt = *pxlt;
/*< Rl=pRl >*/
p_1.rl = *prl;
/*< Tl=pTl >*/
p_1.tl = *ptl;
/*< Rs=pRs >*/
p_1.rs = *prs;
/*< ihs=pihs >*/
ihs = *pihs;
/*< c=pc >*/
p_1.c__ = *pc;
/* Check parameter validity */
/*< >*/
if (p_1.ild != 1 && p_1.ild != 2 && p_1.ild != 3 && p_1.ild != 4 &&
p_1.ild != 5) {
/*< print*,'Leaf angle distribution !' >*/
s_wsle(&io___2);
do_lio(&c__9, &c__1, "Leaf angle distribution !", 25L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/*< if (xlt.le.0.) then >*/
if (p_1.xlt <= 0.) {
/*< print*,'Leaf area index < 0. !' >*/
s_wsle(&io___3);
do_lio(&c__9, &c__1, "Leaf area index < 0. !", 22L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/*< if (xlt.lt.1.) then >*/
if (p_1.xlt < 1.) {
/*< print*,'Leaf area index < 1. !' >*/
s_wsle(&io___4);
do_lio(&c__9, &c__1, "Leaf area index < 1. !", 22L);
e_wsle();
/*< endif >*/
}
/*< if (xlt.gt.15.) then >*/
if (p_1.xlt > 15.) {
/*< print*,'Leaf area index > 15. !' >*/
s_wsle(&io___5);
do_lio(&c__9, &c__1, "Leaf area index > 15. !", 23L);
e_wsle();
/*< endif >*/
}
/*< if (Rl.lt.0.) then >*/
if (p_1.rl < 0.) {
/*< print*,'Leaf reflectance < 0. !' >*/
s_wsle(&io___6);
do_lio(&c__9, &c__1, "Leaf reflectance < 0. !", 23L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/*< if (Rl.gt..99) then >*/
if (p_1.rl > .99) {
/*< print*,'Leaf reflectance > .99 !' >*/
s_wsle(&io___7);
do_lio(&c__9, &c__1, "Leaf reflectance > .99 !", 24L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/*< if (Tl.lt.0.) then >*/
if (p_1.tl < 0.) {
/*< print*,'Leaf transmittance < 0. !' >*/
s_wsle(&io___8);
do_lio(&c__9, &c__1, "Leaf transmittance < 0. !", 25L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/*< if (Tl.gt..99) then >*/
if (p_1.tl > .99) {
/*< print*,'Leaf transmittance > .99 !' >*/
s_wsle(&io___9);
do_lio(&c__9, &c__1, "Leaf transmittance > .99 !", 26L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/*< if (Rl+Tl.gt..99) then >*/
if (p_1.rl + p_1.tl > .99) {
/*< print*,'Single scattering albedo > .99 !' >*/
s_wsle(&io___10);
do_lio(&c__9, &c__1, "Single scattering albedo > .99 !", 32L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/*< if (Rs.lt.0.) then >*/
if (p_1.rs < 0.) {
/*< print*,'Soil albedo < 0. !' >*/
s_wsle(&io___11);
do_lio(&c__9, &c__1, "Soil albedo < 0. !", 18L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/*< if (Rs.gt..99) then >*/
if (p_1.rs > .99) {
/*< print*,'Soil albedo > .99 !' >*/
s_wsle(&io___12);
do_lio(&c__9, &c__1, "Soil albedo > .99 !", 19L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/*< if (c.lt.0.) then >*/
if (p_1.c__ < 0.) {
/*< print*,'Hot-spot parameter < 0. !' >*/
s_wsle(&io___13);
do_lio(&c__9, &c__1, "Hot-spot parameter < 0. !", 25L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/*< if (c.gt.2.) then >*/
if (p_1.c__ > 2.) {
/*< print*,'Hot-spot parameter > 2. !' >*/
s_wsle(&io___14);
do_lio(&c__9, &c__1, "Hot-spot parameter > 2. !", 25L);
e_wsle();
/*< stop >*/
s_stop("", 0L);
/*< endif >*/
}
/* compute leaf area angle distribution */
/*< call lad >*/
lad_();
/* - Hot-spot parameter */
/*< if (ihs.eq.0) c=0. >*/
if (ihs == 0) {
p_1.c__ = 0.;
}
/*< mu1=rm(0) >*/
mu1 = rm[0];
/*< Theta_i=acos(mu1) >*/
theta_i__ = acos(mu1);
/*< Theta_i=Pi-Theta_i >*/
theta_i__ = 3.141592653589793 - theta_i__;
/* - Gauss's quadrature (n points) */
/*< n=10 >*/
gauss_m__1.n = 10;
/*< call gauleg (-1.,1.,xgm,wgm,n) >*/
gauleg_(&c_b52, &c_b53, gauss_m__1.xgm, gauss_m__1.wgm, &gauss_m__1.n);
/* - Computation of the multiple scattering (Ro_mult) */
/*< call solve (Theta_i) >*/
solve_(&theta_i__);
/*< do 1 k=1,np >*/
i__1 = *np;
for (k = 1; k <= i__1; ++k) {
/*< do 2 j=1,mu >*/
i__2 = *mu;
for (j = 1; j <= i__2; ++j) {
/*< mu2=rm(j) >*/
mu2 = rm[j];
/*< if (j.eq.mu) then >*/
if (j == *mu) {
/*< fi=rm(-mu) >*/
fi = rm[-(*mu)];
/*< else >*/
} else {
/*< fi=rp(k)+rm(-mu) >*/
fi = rp[k] + rm[-(*mu)];
/*< endif >*/
}
/*< Theta_v=acos(mu2) >*/
theta_v__ = acos(mu2);
/*< if (fi.lt.0.) fi=fi+2.*pi >*/
if (fi < 0.) {
fi += 6.2831853071795862;
}
/*< if (fi.gt.(2.*pi)) fi=fi-2.*pi >*/
if (fi > 6.2831853071795862) {
fi += -6.2831853071795862;
}
/*< Phi_i=fi >*/
phi_i__ = fi;
/*< Phi_v=0. >*/
phi_v__ = 0.;
/*< brdfint(j,k)=Ro_1(Theta_i,Phi_i,Theta_v,Phi_v)+Ro_mult >*/
brdfint[j + k * brdfint_dim1] = ro_1__(&theta_i__, &phi_i__, &
theta_v__, &phi_v__) + ro_1.ro_mult__;
/*< 2 continue >*/
/* L2: */
}
/*< 1 continue >*/
/* L1: */
}
/*< return >*/
return 0;
/*< end >*/
} /* iapibrdf_ */
/* Subroutine */ int sdrgsx_(integer *nsize, integer *ncmax, real *thresh,
integer *nin, integer *nout, real *a, integer *lda, real *b, real *ai,
real *bi, real *z__, real *q, real *alphar, real *alphai, real *beta,
real *c__, integer *ldc, real *s, real *work, integer *lwork,
integer *iwork, integer *liwork, logical *bwork, integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 SDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9997[] = "(\002 SDRGSX: SGET53 returned INFO=\002,i1,"
"\002 for eigenvalue \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JT"
"YPE=\002,i6,\002)\002)";
static char fmt_9996[] = "(\002 SDRGSX: S not in Schur form at eigenvalu"
"e \002,i6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002"
")\002)";
static char fmt_9995[] = "(/1x,a3,\002 -- Real Expert Generalized Schur "
"form\002,\002 problem driver\002)";
static char fmt_9993[] = "(\002 Matrix types: \002,/\002 1: A is a blo"
"ck diagonal matrix of Jordan blocks \002,\002and B is the identi"
"ty \002,/\002 matrix, \002,/\002 2: A and B are upper tri"
"angular matrices, \002,/\002 3: A and B are as type 2, but eac"
"h second diagonal \002,\002block in A_11 and \002,/\002 eac"
"h third diaongal block in A_22 are 2x2 blocks,\002,/\002 4: A "
"and B are block diagonal matrices, \002,/\002 5: (A,B) has pot"
"entially close or common \002,\002eigenvalues.\002,/)";
static char fmt_9992[] = "(/\002 Tests performed: (S is Schur, T is tri"
"angular, \002,\002Q and Z are \002,a,\002,\002,/19x,\002 a is al"
"pha, b is beta, and \002,a,\002 means \002,a,\002.)\002,/\002 1"
" = | A - Q S Z\002,a,\002 | / ( |A| n ulp ) 2 = | B - Q T "
"Z\002,a,\002 | / ( |B| n ulp )\002,/\002 3 = | I - QQ\002,a,"
"\002 | / ( n ulp ) 4 = | I - ZZ\002,a,\002 | / ( n u"
"lp )\002,/\002 5 = 1/ULP if A is not in \002,\002Schur form "
"S\002,/\002 6 = difference between (alpha,beta)\002,\002 and di"
"agonals of (S,T)\002,/\002 7 = 1/ULP if SDIM is not the correc"
"t number of \002,\002selected eigenvalues\002,/\002 8 = 1/ULP "
"if DIFEST/DIFTRU > 10*THRESH or \002,\002DIFTRU/DIFEST > 10*THRE"
"SH\002,/\002 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B"
") \002,\002when reordering fails\002,/\002 10 = 1/ULP if PLEST/"
"PLTRU > THRESH or \002,\002PLTRU/PLEST > THRESH\002,/\002 ( T"
"est 10 is only for input examples )\002,/)";
static char fmt_9991[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,f8.2)";
static char fmt_9990[] = "(\002 Matrix order=\002,i2,\002, type=\002,i2"
",\002, a=\002,e10.4,\002, order(A_11)=\002,i2,\002, result \002,"
"i2,\002 is \002,0p,e10.4)";
static char fmt_9998[] = "(\002 SDRGSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input Example #\002,i2,\002"
")\002)";
static char fmt_9994[] = "(\002Input Example\002)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, c_dim1, c_offset, q_dim1, q_offset, z_dim1, z_offset,
i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8, r__9, r__10;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
static real temp1, temp2;
static integer i__, j;
static real abnrm;
static integer ifunc, iinfo, linfo;
extern /* Subroutine */ int sget51_(integer *, integer *, real *, integer
*, real *, integer *, real *, integer *, real *, integer *, real *
, real *), sget53_(real *, integer *, real *, integer *, real *,
real *, real *, real *, integer *);
static char sense[1];
static integer nerrs, i1, ntest;
static real pltru;
extern /* Subroutine */ int slakf2_(integer *, integer *, real *, integer
*, real *, real *, real *, real *, integer *), slatm5_(integer *,
integer *, integer *, real *, integer *, real *, integer *, real *
, integer *, real *, integer *, real *, integer *, real *,
integer *, real *, integer *, real *, integer *, real *, integer *
, integer *);
static logical ilabad;
static real thrsh2;
extern /* Subroutine */ int slabad_(real *, real *);
static integer mm, bdspac;
static real pl[2];
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int xerbla_(char *, integer *);
static real difest[2];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static real bignum;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
static real weight;
extern /* Subroutine */ int sgesvd_(char *, char *, integer *, integer *,
real *, integer *, real *, real *, integer *, real *, integer *,
real *, integer *, integer *), slacpy_(char *,
integer *, integer *, real *, integer *, real *, integer *);
static real diftru;
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *), sggesx_(char *, char *, char *
, L_fp, char *, integer *, real *, integer *, real *, integer *,
integer *, real *, real *, real *, real *, integer *, real *,
integer *, real *, real *, real *, integer *, integer *, integer *
, logical *, integer *);
static integer minwrk, maxwrk;
static real smlnum;
static integer mn2, nptknt;
static real ulpinv, result[10];
static integer ntestt;
extern logical slctsx_();
static integer prtype, qba, qbb;
static real ulp;
/* Fortran I/O blocks */
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___42 = { 0, 0, 1, 0, 0 };
static cilist io___43 = { 0, 0, 1, 0, 0 };
static cilist io___44 = { 0, 0, 0, 0, 0 };
static cilist io___45 = { 0, 0, 0, 0, 0 };
static cilist io___46 = { 0, 0, 0, 0, 0 };
static cilist io___48 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___49 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___50 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___51 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___52 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9988, 0 };
#define ai_ref(a_1,a_2) ai[(a_2)*ai_dim1 + a_1]
#define bi_ref(a_1,a_2) bi[(a_2)*bi_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
October 31, 1999
Purpose
=======
SDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
problem expert driver SGGESX.
SGGESX factors A and B as Q S Z' and Q T Z', where ' means
transpose, T is upper triangular, S is in generalized Schur form
(block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
the 2x2 blocks corresponding to complex conjugate pairs of
generalized eigenvalues), and Q and Z are orthogonal. It also
computes the generalized eigenvalues (alpha(1),beta(1)), ...,
(alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the
characteristic equation
det( A - w(j) B ) = 0
Optionally it also reorders the eigenvalues so that a selected
cluster of eigenvalues appears in the leading diagonal block of the
Schur forms; computes a reciprocal condition number for the average
of the selected eigenvalues; and computes a reciprocal condition
number for the right and left deflating subspaces corresponding to
the selected eigenvalues.
When SDRGSX is called with NSIZE > 0, five (5) types of built-in
matrix pairs are used to test the routine SGGESX.
When SDRGSX is called with NSIZE = 0, it reads in test matrix data
to test SGGESX.
For each matrix pair, the following tests will be performed and
compared with the threshhold THRESH except for the tests (7) and (9):
(1) | A - Q S Z' | / ( |A| n ulp )
(2) | B - Q T Z' | / ( |B| n ulp )
(3) | I - QQ' | / ( n ulp )
(4) | I - ZZ' | / ( n ulp )
(5) if A is in Schur form (i.e. quasi-triangular form)
(6) maximum over j of D(j) where:
if alpha(j) is real:
|alpha(j) - S(j,j)| |beta(j) - T(j,j)|
D(j) = ------------------------ + -----------------------
max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
if alpha(j) is complex:
| det( s S - w T ) |
D(j) = ---------------------------------------------------
ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
and S and T are here the 2 x 2 diagonal blocks of S and T
corresponding to the j-th and j+1-th eigenvalues.
(7) if sorting worked and SDIM is the number of eigenvalues
which were selected.
(8) the estimated value DIF does not differ from the true values of
Difu and Difl more than a factor 10*THRESH. If the estimate DIF
equals zero the corresponding true values of Difu and Difl
should be less than EPS*norm(A, B). If the true value of Difu
and Difl equal zero, the estimate DIF should be less than
EPS*norm(A, B).
(9) If INFO = N+3 is returned by SGGESX, the reordering "failed"
and we check that DIF = PL = PR = 0 and that the true value of
Difu and Difl is < EPS*norm(A, B). We count the events when
INFO=N+3.
For read-in test matrices, the above tests are run except that the
exact value for DIF (and PL) is input data. Additionally, there is
one more test run for read-in test matrices:
(10) the estimated value PL does not differ from the true value of
PLTRU more than a factor THRESH. If the estimate PL equals
zero the corresponding true value of PLTRU should be less than
EPS*norm(A, B). If the true value of PLTRU equal zero, the
estimate PL should be less than EPS*norm(A, B).
Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)
matrix pairs are generated and tested. NSIZE should be kept small.
SVD (routine SGESVD) is used for computing the true value of DIF_u
and DIF_l when testing the built-in test problems.
Built-in Test Matrices
======================
All built-in test matrices are the 2 by 2 block of triangular
matrices
A = [ A11 A12 ] and B = [ B11 B12 ]
[ A22 ] [ B22 ]
where for different type of A11 and A22 are given as the following.
A12 and B12 are chosen so that the generalized Sylvester equation
A11*R - L*A22 = -A12
B11*R - L*B22 = -B12
have prescribed solution R and L.
Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
B11 = I_m, B22 = I_k
where J_k(a,b) is the k-by-k Jordan block with ``a'' on
diagonal and ``b'' on superdiagonal.
Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and
B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each
second diagonal block in A_11 and each third diagonal block
in A_22 are made as 2 by 2 blocks.
Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
for i=1,...,m, j=1,...,m and
A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
for i=m+1,...,k, j=m+1,...,k
Type 5: (A,B) and have potentially close or common eigenvalues and
very large departure from block diagonality A_11 is chosen
as the m x m leading submatrix of A_1:
| 1 b |
| -b 1 |
| 1+d b |
| -b 1+d |
A_1 = | d 1 |
| -1 d |
| -d 1 |
| -1 -d |
| 1 |
and A_22 is chosen as the k x k leading submatrix of A_2:
| -1 b |
| -b -1 |
| 1-d b |
| -b 1-d |
A_2 = | d 1+b |
| -1-b d |
| -d 1+b |
| -1+b -d |
| 1-d |
and matrix B are chosen as identity matrices (see SLATM5).
Arguments
=========
NSIZE (input) INTEGER
The maximum size of the matrices to use. NSIZE >= 0.
If NSIZE = 0, no built-in tests matrices are used, but
read-in test matrices are used to test SGGESX.
NCMAX (input) INTEGER
Maximum allowable NMAX for generating Kroneker matrix
in call to SLAKF2
THRESH (input) REAL
A test will count as "failed" if the "error", computed as
described above, exceeds THRESH. Note that the error
is scaled to be O(1), so THRESH should be a reasonably
small multiple of 1, e.g., 10 or 100. In particular,
it should not depend on the precision (single vs. double)
or the size of the matrix. THRESH >= 0.
NIN (input) INTEGER
The FORTRAN unit number for reading in the data file of
problems to solve.
NOUT (input) INTEGER
The FORTRAN unit number for printing out error messages
(e.g., if a routine returns IINFO not equal to 0.)
A (workspace) REAL array, dimension (LDA, NSIZE)
Used to store the matrix whose eigenvalues are to be
computed. On exit, A contains the last matrix actually used.
LDA (input) INTEGER
The leading dimension of A, B, AI, BI, Z and Q,
LDA >= max( 1, NSIZE ). For the read-in test,
LDA >= max( 1, N ), N is the size of the test matrices.
B (workspace) REAL array, dimension (LDA, NSIZE)
Used to store the matrix whose eigenvalues are to be
computed. On exit, B contains the last matrix actually used.
AI (workspace) REAL array, dimension (LDA, NSIZE)
Copy of A, modified by SGGESX.
BI (workspace) REAL array, dimension (LDA, NSIZE)
Copy of B, modified by SGGESX.
Z (workspace) REAL array, dimension (LDA, NSIZE)
Z holds the left Schur vectors computed by SGGESX.
Q (workspace) REAL array, dimension (LDA, NSIZE)
Q holds the right Schur vectors computed by SGGESX.
ALPHAR (workspace) REAL array, dimension (NSIZE)
ALPHAI (workspace) REAL array, dimension (NSIZE)
BETA (workspace) REAL array, dimension (NSIZE)
On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
C (workspace) REAL array, dimension (LDC, LDC)
Store the matrix generated by subroutine SLAKF2, this is the
matrix formed by Kronecker products used for estimating
DIF.
LDC (input) INTEGER
The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
S (workspace) REAL array, dimension (LDC)
Singular values of C
WORK (workspace) REAL array, dimension (LWORK)
LWORK (input) INTEGER
The dimension of the array WORK.
LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) )
IWORK (workspace) INTEGER array, dimension (LIWORK)
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= NSIZE + 6.
BWORK (workspace) LOGICAL array, dimension (LDA)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: A routine returned an error code.
=====================================================================
Check for errors
Parameter adjustments */
q_dim1 = *lda;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
z_dim1 = *lda;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1 * 1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1 * 1;
ai -= ai_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;
--alphar;
--alphai;
--beta;
c_dim1 = *ldc;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--s;
--work;
--iwork;
--bwork;
/* Function Body */
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.f) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < *nsize) {
*info = -6;
} else if (*ldc < 1 || *ldc < *nsize * *nsize / 2) {
*info = -17;
} else if (*liwork < *nsize + 6) {
*info = -21;
}
/* Compute workspace
(Note: Comments in the code beginning "Workspace:" describe the
minimal amount of workspace needed at that point in the code,
as well as the preferred amount for good performance.
NB refers to the optimal block size for the immediately
following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
/* MINWRK = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2-2 )
Computing MAX */
i__1 = (*nsize + 1) * 10, i__2 = *nsize * 5 * *nsize / 2;
minwrk = max(i__1,i__2);
/* workspace for sggesx */
maxwrk = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1, "SGEQRF", " ",
nsize, &c__1, nsize, &c__0, (ftnlen)6, (ftnlen)1);
/* Computing MAX */
i__1 = maxwrk, i__2 = (*nsize + 1) * 9 + *nsize * ilaenv_(&c__1,
"SORGQR", " ", nsize, &c__1, nsize, &c_n1, (ftnlen)6, (ftnlen)
1);
maxwrk = max(i__1,i__2);
/* workspace for sgesvd */
bdspac = *nsize * 5 * *nsize / 2;
/* Computing MAX */
i__3 = *nsize * *nsize / 2;
i__4 = *nsize * *nsize / 2;
i__1 = maxwrk, i__2 = *nsize * 3 * *nsize / 2 + *nsize * *nsize *
ilaenv_(&c__1, "SGEBRD", " ", &i__3, &i__4, &c_n1, &c_n1, (
ftnlen)6, (ftnlen)1);
maxwrk = max(i__1,i__2);
maxwrk = max(maxwrk,bdspac);
maxwrk = max(maxwrk,minwrk);
work[1] = (real) maxwrk;
}
if (*lwork < minwrk) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRGSX", &i__1);
return 0;
}
/* Important constants */
ulp = slamch_("P");
ulpinv = 1.f / ulp;
smlnum = slamch_("S") / ulp;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
thrsh2 = *thresh * 10.f;
ntestt = 0;
nerrs = 0;
/* Go to the tests for read-in matrix pairs */
ifunc = 0;
if (*nsize == 0) {
goto L70;
}
/* Test the built-in matrix pairs.
Loop over different functions (IFUNC) of SGGESX, types (PRTYPE)
of test matrices, different size (M+N) */
prtype = 0;
qba = 3;
qbb = 4;
weight = sqrt(ulp);
for (ifunc = 0; ifunc <= 3; ++ifunc) {
for (prtype = 1; prtype <= 5; ++prtype) {
i__1 = *nsize - 1;
for (mn_1.m = 1; mn_1.m <= i__1; ++mn_1.m) {
i__2 = *nsize - mn_1.m;
for (mn_1.n = 1; mn_1.n <= i__2; ++mn_1.n) {
weight = 1.f / weight;
mn_1.mplusn = mn_1.m + mn_1.n;
/* Generate test matrices */
mn_1.fs = TRUE_;
mn_1.k = 0;
slaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
c_b26, &ai[ai_offset], lda);
slaset_("Full", &mn_1.mplusn, &mn_1.mplusn, &c_b26, &
c_b26, &bi[bi_offset], lda);
slatm5_(&prtype, &mn_1.m, &mn_1.n, &ai[ai_offset], lda, &
ai_ref(mn_1.m + 1, mn_1.m + 1), lda, &ai_ref(1,
mn_1.m + 1), lda, &bi[bi_offset], lda, &bi_ref(
mn_1.m + 1, mn_1.m + 1), lda, &bi_ref(1, mn_1.m +
1), lda, &q[q_offset], lda, &z__[z_offset], lda, &
weight, &qba, &qbb);
/* Compute the Schur factorization and swapping the
m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
Swapping is accomplished via the function SLCTSX
which is supplied below. */
if (ifunc == 0) {
*(unsigned char *)sense = 'N';
} else if (ifunc == 1) {
*(unsigned char *)sense = 'E';
} else if (ifunc == 2) {
*(unsigned char *)sense = 'V';
} else if (ifunc == 3) {
*(unsigned char *)sense = 'B';
}
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &a[a_offset], lda);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &b[b_offset], lda);
sggesx_("V", "V", "S", (L_fp)slctsx_, sense, &mn_1.mplusn,
&ai[ai_offset], lda, &bi[bi_offset], lda, &mm, &
alphar[1], &alphai[1], &beta[1], &q[q_offset],
lda, &z__[z_offset], lda, pl, difest, &work[1],
lwork, &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "SGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(integer)
);
e_wsfe();
*info = linfo;
goto L30;
}
/* Compute the norm(A, B) */
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset]
, lda, &work[1], &mn_1.mplusn);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset]
, lda, &work[mn_1.mplusn * mn_1.mplusn + 1], &
mn_1.mplusn);
i__3 = mn_1.mplusn << 1;
abnrm = slange_("Fro", &mn_1.mplusn, &i__3, &work[1], &
mn_1.mplusn, &work[1]);
/* Do tests (1) to (4) */
sget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[
ai_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], result);
sget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &z__[z_offset]
, lda, &work[1], &result[1]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &q[q_offset], lda, &q[q_offset],
lda, &work[1], &result[2]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[
bi_offset], lda, &z__[z_offset], lda, &z__[
z_offset], lda, &work[1], &result[3]);
ntest = 4;
/* Do tests (5) and (6): check Schur form of A and
compare eigenvalues with diagonals. */
temp1 = 0.f;
result[4] = 0.f;
result[5] = 0.f;
i__3 = mn_1.mplusn;
for (j = 1; j <= i__3; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.f) {
/* Computing MAX */
r__7 = smlnum, r__8 = (r__2 = alphar[j], dabs(
r__2)), r__7 = max(r__7,r__8), r__8 = (
r__3 = ai_ref(j, j), dabs(r__3));
/* Computing MAX */
r__9 = smlnum, r__10 = (r__5 = beta[j], dabs(r__5)
), r__9 = max(r__9,r__10), r__10 = (r__6 =
bi_ref(j, j), dabs(r__6));
temp2 = ((r__1 = alphar[j] - ai_ref(j, j), dabs(
r__1)) / dmax(r__7,r__8) + (r__4 = beta[j]
- bi_ref(j, j), dabs(r__4)) / dmax(r__9,
r__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai_ref(j + 1, j) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai_ref(j, j - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
} else {
if (alphai[j] > 0.f) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= mn_1.mplusn) {
ilabad = TRUE_;
} else if (i1 < mn_1.mplusn - 1) {
if (ai_ref(i1 + 2, i1 + 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai_ref(i1, i1 - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
sget53_(&ai_ref(i1, i1), lda, &bi_ref(i1, i1),
lda, &beta[j], &alphar[j], &alphai[j]
, &temp2, &iinfo);
if (iinfo >= 3) {
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&iinfo, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (
ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)
sizeof(integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = dmax(temp1,temp2);
if (ilabad) {
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* L10: */
}
result[5] = temp1;
ntest += 2;
/* Test (7) (if sorting worked) */
result[6] = 0.f;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
} else if (mm != mn_1.n) {
result[6] = ulpinv;
}
++ntest;
/* Test (8): compare the estimated value DIF and its
value. first, compute the exact DIF. */
result[7] = 0.f;
mn2 = mm * (mn_1.mplusn - mm) << 1;
if (ifunc >= 2 && mn2 <= *ncmax * *ncmax) {
/* Note: for either following two causes, there are
almost same number of test cases fail the test. */
i__3 = mn_1.mplusn - mm;
slakf2_(&mm, &i__3, &ai[ai_offset], lda, &ai_ref(mm +
1, mm + 1), &bi[bi_offset], &bi_ref(mm + 1,
mm + 1), &c__[c_offset], ldc);
i__3 = *lwork - 2;
sgesvd_("N", "N", &mn2, &mn2, &c__[c_offset], ldc, &s[
1], &work[1], &c__1, &work[2], &c__1, &work[3]
, &i__3, info);
diftru = s[mn2];
if (difest[1] == 0.f) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.f) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru *
thrsh2 < difest[1]) {
/* Computing MAX */
r__1 = diftru / difest[1], r__2 = difest[1] /
diftru;
result[7] = dmax(r__1,r__2);
}
++ntest;
}
/* Test (9) */
result[8] = 0.f;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.f) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.f) {
result[8] = ulpinv;
}
++ntest;
}
ntestt += ntest;
/* Print out tests which fail. */
for (j = 1; j <= 9; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, "SGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___36.ciunit = *nout;
s_wsfe(&io___36);
e_wsfe();
/* Tests performed */
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4f) {
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(real));
e_wsfe();
} else {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&prtype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&mn_1.m, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)
sizeof(real));
e_wsfe();
}
}
/* L20: */
}
L30:
;
}
/* L40: */
}
/* L50: */
}
/* L60: */
}
goto L150;
L70:
/* Read in data from file to check accuracy of condition estimation
Read input data until N=0 */
nptknt = 0;
L80:
io___42.ciunit = *nin;
i__1 = s_rsle(&io___42);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer))
;
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
if (mn_1.mplusn == 0) {
goto L140;
}
io___43.ciunit = *nin;
i__1 = s_rsle(&io___43);
if (i__1 != 0) {
goto L140;
}
i__1 = do_lio(&c__3, &c__1, (char *)&mn_1.n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L140;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L140;
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___44.ciunit = *nin;
s_rsle(&io___44);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&ai_ref(i__, j), (ftnlen)sizeof(real)
);
}
e_rsle();
/* L90: */
}
i__1 = mn_1.mplusn;
for (i__ = 1; i__ <= i__1; ++i__) {
io___45.ciunit = *nin;
s_rsle(&io___45);
i__2 = mn_1.mplusn;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&bi_ref(i__, j), (ftnlen)sizeof(real)
);
}
e_rsle();
/* L100: */
}
io___46.ciunit = *nin;
s_rsle(&io___46);
do_lio(&c__4, &c__1, (char *)&pltru, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&diftru, (ftnlen)sizeof(real));
e_rsle();
++nptknt;
mn_1.fs = TRUE_;
mn_1.k = 0;
mn_1.m = mn_1.mplusn - mn_1.n;
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &a[
a_offset], lda);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &b[
b_offset], lda);
/* Compute the Schur factorization while swaping the
m-by-m (1,1)-blocks with n-by-n (2,2)-blocks. */
sggesx_("V", "V", "S", (L_fp)slctsx_, "B", &mn_1.mplusn, &ai[ai_offset],
lda, &bi[bi_offset], lda, &mm, &alphar[1], &alphai[1], &beta[1], &
q[q_offset], lda, &z__[z_offset], lda, pl, difest, &work[1],
lwork, &iwork[1], liwork, &bwork[1], &linfo);
if (linfo != 0 && linfo != mn_1.mplusn + 2) {
result[0] = ulpinv;
io___48.ciunit = *nout;
s_wsfe(&io___48);
do_fio(&c__1, "SGGESX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L130;
}
/* Compute the norm(A, B)
(should this be norm of (A,B) or (AI,BI)?) */
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &ai[ai_offset], lda, &work[1],
&mn_1.mplusn);
slacpy_("Full", &mn_1.mplusn, &mn_1.mplusn, &bi[bi_offset], lda, &work[
mn_1.mplusn * mn_1.mplusn + 1], &mn_1.mplusn);
i__1 = mn_1.mplusn << 1;
abnrm = slange_("Fro", &mn_1.mplusn, &i__1, &work[1], &mn_1.mplusn, &work[
1]);
/* Do tests (1) to (4) */
sget51_(&c__1, &mn_1.mplusn, &a[a_offset], lda, &ai[ai_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], result);
sget51_(&c__1, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &z__[z_offset], lda, &work[1], &result[1]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &q[
q_offset], lda, &q[q_offset], lda, &work[1], &result[2]);
sget51_(&c__3, &mn_1.mplusn, &b[b_offset], lda, &bi[bi_offset], lda, &z__[
z_offset], lda, &z__[z_offset], lda, &work[1], &result[3]);
/* Do tests (5) and (6): check Schur form of A and compare
eigenvalues with diagonals. */
ntest = 6;
temp1 = 0.f;
result[4] = 0.f;
result[5] = 0.f;
i__1 = mn_1.mplusn;
for (j = 1; j <= i__1; ++j) {
ilabad = FALSE_;
if (alphai[j] == 0.f) {
/* Computing MAX */
r__7 = smlnum, r__8 = (r__2 = alphar[j], dabs(r__2)), r__7 = max(
r__7,r__8), r__8 = (r__3 = ai_ref(j, j), dabs(r__3));
/* Computing MAX */
r__9 = smlnum, r__10 = (r__5 = beta[j], dabs(r__5)), r__9 = max(
r__9,r__10), r__10 = (r__6 = bi_ref(j, j), dabs(r__6));
temp2 = ((r__1 = alphar[j] - ai_ref(j, j), dabs(r__1)) / dmax(
r__7,r__8) + (r__4 = beta[j] - bi_ref(j, j), dabs(r__4)) /
dmax(r__9,r__10)) / ulp;
if (j < mn_1.mplusn) {
if (ai_ref(j + 1, j) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (j > 1) {
if (ai_ref(j, j - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
} else {
if (alphai[j] > 0.f) {
i1 = j;
} else {
i1 = j - 1;
}
if (i1 <= 0 || i1 >= mn_1.mplusn) {
ilabad = TRUE_;
} else if (i1 < mn_1.mplusn - 1) {
if (ai_ref(i1 + 2, i1 + 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
} else if (i1 > 1) {
if (ai_ref(i1, i1 - 1) != 0.f) {
ilabad = TRUE_;
result[4] = ulpinv;
}
}
if (! ilabad) {
sget53_(&ai_ref(i1, i1), lda, &bi_ref(i1, i1), lda, &beta[j],
&alphar[j], &alphai[j], &temp2, &iinfo);
if (iinfo >= 3) {
io___49.ciunit = *nout;
s_wsfe(&io___49);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
}
} else {
temp2 = ulpinv;
}
}
temp1 = dmax(temp1,temp2);
if (ilabad) {
io___50.ciunit = *nout;
s_wsfe(&io___50);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L110: */
}
result[5] = temp1;
/* Test (7) (if sorting worked) <--------- need to be checked. */
ntest = 7;
result[6] = 0.f;
if (linfo == mn_1.mplusn + 3) {
result[6] = ulpinv;
}
/* Test (8): compare the estimated value of DIF and its true value. */
ntest = 8;
result[7] = 0.f;
if (difest[1] == 0.f) {
if (diftru > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru == 0.f) {
if (difest[1] > abnrm * ulp) {
result[7] = ulpinv;
}
} else if (diftru > thrsh2 * difest[1] || diftru * thrsh2 < difest[1]) {
/* Computing MAX */
r__1 = diftru / difest[1], r__2 = difest[1] / diftru;
result[7] = dmax(r__1,r__2);
}
/* Test (9) */
ntest = 9;
result[8] = 0.f;
if (linfo == mn_1.mplusn + 2) {
if (diftru > abnrm * ulp) {
result[8] = ulpinv;
}
if (ifunc > 1 && difest[1] != 0.f) {
result[8] = ulpinv;
}
if (ifunc == 1 && pl[0] != 0.f) {
result[8] = ulpinv;
}
}
/* Test (10): compare the estimated value of PL and it true value. */
ntest = 10;
result[9] = 0.f;
if (pl[0] == 0.f) {
if (pltru > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru == 0.f) {
if (pl[0] > abnrm * ulp) {
result[9] = ulpinv;
}
} else if (pltru > *thresh * pl[0] || pltru * *thresh < pl[0]) {
result[9] = ulpinv;
}
ntestt += ntest;
/* Print out tests which fail. */
i__1 = ntest;
for (j = 1; j <= i__1; ++j) {
if (result[j - 1] >= *thresh) {
/* If this is the first test to fail,
print a header to the data file. */
if (nerrs == 0) {
io___51.ciunit = *nout;
s_wsfe(&io___51);
do_fio(&c__1, "SGX", (ftnlen)3);
e_wsfe();
/* Matrix types */
io___52.ciunit = *nout;
s_wsfe(&io___52);
e_wsfe();
/* Tests performed */
io___53.ciunit = *nout;
s_wsfe(&io___53);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
for (i__ = 1; i__ <= 4; ++i__) {
do_fio(&c__1, "'", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
if (result[j - 1] < 1e4f) {
io___54.ciunit = *nout;
s_wsfe(&io___54);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
e_wsfe();
} else {
io___55.ciunit = *nout;
s_wsfe(&io___55);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&mn_1.mplusn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j - 1], (ftnlen)sizeof(real));
e_wsfe();
}
}
/* L120: */
}
L130:
goto L80;
L140:
L150:
/* Summary */
alasvm_("SGX", nout, &nerrs, &ntestt, &c__0);
work[1] = (real) maxwrk;
return 0;
/* End of SDRGSX */
} /* sdrgsx_ */
/* Subroutine */ int zchkgl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(\002 .. test output of ZGGBAL .. \002)";
static char fmt_9998[] = "(\002 ratio of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(\002 example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(\002 example number where ILO or IHI is wrong"
" = \002,i4)";
static char fmt_9995[] = "(\002 example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(\002 number of examples where info is not 0 "
" = \002,i4)";
static char fmt_9993[] = "(\002 total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
doublecomplex z__1;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double z_abs(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
doublecomplex a[400] /* was [20][20] */, b[400] /* was [20][
20] */;
integer i__, j, n;
doublecomplex ain[400] /* was [20][20] */, bin[400] /* was [20][
20] */;
integer ihi, ilo;
doublereal eps;
integer knt, info, lmax[3];
doublereal rmax, vmax, work[120];
integer ihiin, ninfo, iloin;
doublereal anorm, bnorm;
extern doublereal dlamch_(char *);
doublereal lscale[20];
extern /* Subroutine */ int zggbal_(char *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
doublereal rscale[20];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
doublereal lsclin[20], rsclin[20];
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___9 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKGL tests ZGGBAL, a routine for balancing a matrix pair (A, B). */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L90;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = *nin;
s_rsle(&io___9);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___12.ciunit = *nin;
s_rsle(&io___12);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L30: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___19.ciunit = *nin;
s_rsle(&io___19);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&bin[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L50: */
}
io___21.ciunit = *nin;
s_rsle(&io___21);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&lsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
io___23.ciunit = *nin;
s_rsle(&io___23);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&rsclin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
anorm = zlange_("M", &n, &n, a, &c__20, work);
bnorm = zlange_("M", &n, &n, b, &c__20, work);
++knt;
zggbal_("B", &n, a, &c__20, b, &c__20, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
z__1.r = a[i__3].r - ain[i__4].r, z__1.i = a[i__3].i - ain[i__4]
.i;
d__1 = vmax, d__2 = z_abs(&z__1);
vmax = max(d__1,d__2);
/* Computing MAX */
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
z__1.r = b[i__3].r - bin[i__4].r, z__1.i = b[i__3].i - bin[i__4]
.i;
d__1 = vmax, d__2 = z_abs(&z__1);
vmax = max(d__1,d__2);
/* L60: */
}
/* L70: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = lscale[i__ - 1] - lsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = rscale[i__ - 1] - rsclin[i__ - 1], abs(
d__1));
vmax = max(d__2,d__3);
/* L80: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L90:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKGL */
} /* zchkgl_ */
/* Subroutine */ int zchkgk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGGBAK .. \002)";
static char fmt_9998[] = "(\002 value of largest test error "
" =\002,d12.3)";
static char fmt_9997[] = "(\002 example number where ZGGBAL info is not "
"0 =\002,i4)";
static char fmt_9996[] = "(\002 example number where ZGGBAK(L) info is n"
"ot 0 =\002,i4)";
static char fmt_9995[] = "(\002 example number where ZGGBAK(R) info is n"
"ot 0 =\002,i4)";
static char fmt_9994[] = "(\002 example number having largest error "
" =\002,i4)";
static char fmt_9992[] = "(\002 number of examples where info is not 0 "
" =\002,i4)";
static char fmt_9991[] = "(\002 total number of examples tested "
" =\002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double d_imag(doublecomplex *);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static integer info, lmax[4];
static doublereal rmax, vmax;
static doublecomplex work[2500] /* was [50][50] */, a[2500] /*
was [50][50] */, b[2500] /* was [50][50] */, e[2500] /*
was [50][50] */, f[2500] /* was [50][50] */;
static integer i__, j, m, n, ninfo;
static doublereal anorm, bnorm;
extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *,
integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
static doublereal rwork[300];
static doublecomplex af[2500] /* was [50][50] */, bf[2500] /*
was [50][50] */;
extern doublereal dlamch_(char *);
static doublecomplex vl[2500] /* was [50][50] */;
static doublereal lscale[50];
extern /* Subroutine */ int zggbak_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublecomplex *,
integer *, integer *), zggbal_(char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublereal *, doublereal *, doublereal *, integer *);
static doublecomplex vr[2500] /* was [50][50] */;
static doublereal rscale[50];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
extern /* Subroutine */ int zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer ihi, ilo;
static doublereal eps;
static doublecomplex vlf[2500] /* was [50][50] */;
static integer knt;
static doublecomplex vrf[2500] /* was [50][50] */;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9991, 0 };
#define a_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define e_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define e_ref(a_1,a_2) e[e_subscr(a_1,a_2)]
#define f_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define f_ref(a_1,a_2) f[f_subscr(a_1,a_2)]
#define vl_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define vl_ref(a_1,a_2) vl[vl_subscr(a_1,a_2)]
#define vr_subscr(a_1,a_2) (a_2)*50 + a_1 - 51
#define vr_ref(a_1,a_2) vr[vr_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
ZCHKGK tests ZGGBAK, a routine for backward balancing of
a matrix pair (A, B).
Arguments
=========
NIN (input) INTEGER
The logical unit number for input. NIN > 0.
NOUT (input) INTEGER
The logical unit number for output. NOUT > 0.
===================================================================== */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L100;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___10.ciunit = *nin;
s_rsle(&io___10);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = *nin;
s_rsle(&io___13);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&b_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L30: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = *nin;
s_rsle(&io___15);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&vl_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&vr_ref(i__, j), (ftnlen)sizeof(
doublecomplex));
}
e_rsle();
/* L50: */
}
++knt;
anorm = zlange_("M", &n, &n, a, &c__50, rwork);
bnorm = zlange_("M", &n, &n, b, &c__50, rwork);
zlacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
zlacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
zggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, rwork,
&info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
zlacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
zlacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
zggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[1] = knt;
}
zggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[2] = knt;
}
/* Test of ZGGBAK
Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
where tilde(A) denotes the transformed matrix. */
zgemm_("N", "N", &n, &m, &n, &c_b2, af, &c__50, vr, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
c__50);
zgemm_("N", "N", &n, &m, &n, &c_b2, a, &c__50, vrf, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = e_subscr(i__, j);
i__4 = f_subscr(i__, j);
z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
vmax = max(d__3,d__4);
/* L60: */
}
/* L70: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
zgemm_("N", "N", &n, &m, &n, &c_b2, bf, &c__50, vr, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vl, &c__50, work, &c__50, &c_b1, e, &
c__50);
zgemm_("n", "n", &n, &m, &n, &c_b2, b, &c__50, vrf, &c__50, &c_b1, work, &
c__50);
zgemm_("C", "N", &m, &m, &n, &c_b2, vlf, &c__50, work, &c__50, &c_b1, f, &
c__50);
vmax = 0.;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = e_subscr(i__, j);
i__4 = f_subscr(i__, j);
z__2.r = e[i__3].r - f[i__4].r, z__2.i = e[i__3].i - f[i__4].i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2));
vmax = max(d__3,d__4);
/* L80: */
}
/* L90: */
}
vmax /= eps * max(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
goto L10;
L100:
io___35.ciunit = *nout;
s_wsfe(&io___35);
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
e_wsfe();
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKGK */
} /* zchkgk_ */
/* Subroutine */ int check0_(doublereal *sfac)
{
/* Initialized data */
static doublereal ds1[8] = { .8,.6,.8,-.6,.8,0.,1.,0. };
static doublereal datrue[8] = { .5,.5,.5,-.5,-.5,0.,1.,1. };
static doublereal dbtrue[8] = { 0.,.6,0.,-.6,0.,0.,1.,0. };
static doublereal da1[8] = { .3,.4,-.3,-.4,-.3,0.,0.,1. };
static doublereal db1[8] = { .4,.3,.4,.3,-.4,0.,1.,0. };
static doublereal dc1[8] = { .6,.8,-.6,.8,.6,1.,0.,1. };
/* Local variables */
integer k;
doublereal sa, sb, sc, ss;
/* Fortran I/O blocks */
static cilist io___18 = { 0, 6, 0, 0, 0 };
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Subroutines .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* .. Executable Statements .. */
/* Compute true values which cannot be prestored */
/* in decimal notation */
dbtrue[0] = 1.6666666666666667;
dbtrue[2] = -1.6666666666666667;
dbtrue[4] = 1.6666666666666667;
for (k = 1; k <= 8; ++k) {
/* .. Set N=K for identification in output if any .. */
combla_1.n = k;
if (combla_1.icase == 3) {
/* .. DROTG .. */
if (k > 8) {
goto L40;
}
sa = da1[k - 1];
sb = db1[k - 1];
drotg_(&sa, &sb, &sc, &ss);
stest1_(&sa, &datrue[k - 1], &datrue[k - 1], sfac);
stest1_(&sb, &dbtrue[k - 1], &dbtrue[k - 1], sfac);
stest1_(&sc, &dc1[k - 1], &dc1[k - 1], sfac);
stest1_(&ss, &ds1[k - 1], &ds1[k - 1], sfac);
} else {
s_wsle(&io___18);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK0", (ftnlen)28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L20: */
}
L40:
return 0;
} /* check0_ */
/* Subroutine */ int check1_(doublereal *sfac)
{
/* Initialized data */
static doublereal sa[10] = { .3,-1.,0.,1.,.3,.3,.3,.3,.3,.3 };
static doublereal dv[80] /* was [8][5][2] */ = { .1,2.,2.,2.,2.,2.,2.,
2.,.3,3.,3.,3.,3.,3.,3.,3.,.3,-.4,4.,4.,4.,4.,4.,4.,.2,-.6,.3,5.,
5.,5.,5.,5.,.1,-.3,.5,-.1,6.,6.,6.,6.,.1,8.,8.,8.,8.,8.,8.,8.,.3,
9.,9.,9.,9.,9.,9.,9.,.3,2.,-.4,2.,2.,2.,2.,2.,.2,3.,-.6,5.,.3,2.,
2.,2.,.1,4.,-.3,6.,-.5,7.,-.1,3. };
static doublereal dtrue1[5] = { 0.,.3,.5,.7,.6 };
static doublereal dtrue3[5] = { 0.,.3,.7,1.1,1. };
static doublereal dtrue5[80] /* was [8][5][2] */ = { .1,2.,2.,2.,
2.,2.,2.,2.,-.3,3.,3.,3.,3.,3.,3.,3.,0.,0.,4.,4.,4.,4.,4.,4.,.2,
-.6,.3,5.,5.,5.,5.,5.,.03,-.09,.15,-.03,6.,6.,6.,6.,.1,8.,8.,8.,
8.,8.,8.,8.,.09,9.,9.,9.,9.,9.,9.,9.,.09,2.,-.12,2.,2.,2.,2.,2.,
.06,3.,-.18,5.,.09,2.,2.,2.,.03,4.,-.09,6.,-.15,7.,-.03,3. };
static integer itrue2[5] = { 0,1,2,2,3 };
/* System generated locals */
integer i__1;
doublereal d__1;
/* Local variables */
integer i__;
doublereal sx[8];
integer np1, len;
doublereal stemp[1], strue[8];
/* Fortran I/O blocks */
static cilist io___31 = { 0, 6, 0, 0, 0 };
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* .. Executable Statements .. */
for (combla_1.incx = 1; combla_1.incx <= 2; ++combla_1.incx) {
for (np1 = 1; np1 <= 5; ++np1) {
combla_1.n = np1 - 1;
len = max(combla_1.n,1) << 1;
/* .. Set vector arguments .. */
i__1 = len;
for (i__ = 1; i__ <= i__1; ++i__) {
sx[i__ - 1] = dv[i__ + (np1 + combla_1.incx * 5 << 3) - 49];
/* L20: */
}
if (combla_1.icase == 7) {
/* .. DNRM2 .. */
stemp[0] = dtrue1[np1 - 1];
d__1 = dnrm2_(&combla_1.n, sx, &combla_1.incx);
stest1_(&d__1, stemp, stemp, sfac);
} else if (combla_1.icase == 8) {
/* .. DASUM .. */
stemp[0] = dtrue3[np1 - 1];
d__1 = dasum_(&combla_1.n, sx, &combla_1.incx);
stest1_(&d__1, stemp, stemp, sfac);
} else if (combla_1.icase == 9) {
/* .. DSCAL .. */
dscal_(&combla_1.n, &sa[(combla_1.incx - 1) * 5 + np1 - 1],
sx, &combla_1.incx);
i__1 = len;
for (i__ = 1; i__ <= i__1; ++i__) {
strue[i__ - 1] = dtrue5[i__ + (np1 + combla_1.incx * 5 <<
3) - 49];
/* L40: */
}
stest_(&len, sx, strue, strue, sfac);
} else if (combla_1.icase == 10) {
/* .. IDAMAX .. */
i__1 = idamax_(&combla_1.n, sx, &combla_1.incx);
itest1_(&i__1, &itrue2[np1 - 1]);
} else {
s_wsle(&io___31);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK1", (ftnlen)
28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L60: */
}
/* L80: */
}
return 0;
} /* check1_ */
/* Subroutine */ int zchkbl_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of ZGEBAL .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number where ILO or IHI wrong "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9994[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9993[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4, d__5, d__6;
doublecomplex z__1, z__2;
/* Local variables */
doublecomplex a[400] /* was [20][20] */;
integer i__, j, n;
doublecomplex ain[400] /* was [20][20] */;
integer ihi, ilo, knt, info, lmax[3];
doublereal meps, temp, rmax, vmax, scale[20];
integer ihiin, ninfo, iloin;
doublereal anorm, sfmin, dummy[1];
extern doublereal dlamch_(char *);
extern /* Subroutine */ int zgebal_(char *, integer *, doublecomplex *,
integer *, integer *, integer *, doublereal *, integer *);
doublereal scalin[20];
extern doublereal zlange_(char *, integer *, integer *, doublecomplex *,
integer *, doublereal *);
/* Fortran I/O blocks */
static cilist io___8 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZCHKBL tests ZGEBAL, a routine for balancing a general complex */
/* matrix and isolating some of its eigenvalues. */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
vmax = 0.;
sfmin = dlamch_("S");
meps = dlamch_("E");
L10:
io___8.ciunit = *nin;
s_rsle(&io___8);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L70;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___11.ciunit = *nin;
s_rsle(&io___11);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&a[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L20: */
}
io___14.ciunit = *nin;
s_rsle(&io___14);
do_lio(&c__3, &c__1, (char *)&iloin, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihiin, (ftnlen)sizeof(integer));
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ain[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L30: */
}
io___19.ciunit = *nin;
s_rsle(&io___19);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&scalin[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
anorm = zlange_("M", &n, &n, a, &c__20, dummy);
++knt;
zgebal_("B", &n, a, &c__20, &ilo, &ihi, scale, &info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
if (ilo != iloin || ihi != ihiin) {
++ninfo;
lmax[1] = knt;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
/* Computing MAX */
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
d__5 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j *
20 - 21]), abs(d__2)), d__6 = (d__3 = ain[i__4].r, abs(
d__3)) + (d__4 = d_imag(&ain[i__ + j * 20 - 21]), abs(
d__4));
temp = max(d__5,d__6);
temp = max(temp,sfmin);
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
z__2.r = a[i__3].r - ain[i__4].r, z__2.i = a[i__3].i - ain[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
/* Computing MAX */
d__3 = vmax, d__4 = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&
z__1), abs(d__2))) / temp;
vmax = max(d__3,d__4);
/* L40: */
}
/* L50: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = scale[i__ - 1], d__2 = scalin[i__ - 1];
temp = max(d__1,d__2);
temp = max(temp,sfmin);
/* Computing MAX */
d__2 = vmax, d__3 = (d__1 = scale[i__ - 1] - scalin[i__ - 1], abs(
d__1)) / temp;
vmax = max(d__2,d__3);
/* L60: */
}
if (vmax > rmax) {
lmax[2] = knt;
rmax = vmax;
}
goto L10;
L70:
io___28.ciunit = *nout;
s_wsfe(&io___28);
e_wsfe();
io___29.ciunit = *nout;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___30.ciunit = *nout;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___31.ciunit = *nout;
s_wsfe(&io___31);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKBL */
} /* zchkbl_ */
/* Subroutine */ int schkgk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of SGGBAK .. \002)";
static char fmt_9998[] = "(\002 value of largest test error "
" =\002,e12.3)";
static char fmt_9997[] = "(\002 example number where SGGBAL info is not "
"0 =\002,i4)";
static char fmt_9996[] = "(\002 example number where SGGBAK(L) info is n"
"ot 0 =\002,i4)";
static char fmt_9995[] = "(\002 example number where SGGBAK(R) info is n"
"ot 0 =\002,i4)";
static char fmt_9994[] = "(\002 example number having largest error "
" =\002,i4)";
static char fmt_9992[] = "(\002 number of examples where info is not 0 "
" =\002,i4)";
static char fmt_9991[] = "(\002 total number of examples tested "
" =\002,i4)";
/* System generated locals */
integer i__1, i__2;
real r__1, r__2, r__3;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
char *, ftnlen);
/* Local variables */
real a[2500] /* was [50][50] */, b[2500] /* was [50][50] */, e[
2500] /* was [50][50] */, f[2500] /* was [50][50] */;
integer i__, j, m, n;
real af[2500] /* was [50][50] */, bf[2500] /* was [50][50] */,
vl[2500] /* was [50][50] */, vr[2500] /* was [50][50] */;
integer ihi, ilo;
real eps, vlf[2500] /* was [50][50] */;
integer knt;
real vrf[2500] /* was [50][50] */;
integer info, lmax[4];
real rmax, vmax, work[2500] /* was [50][50] */;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
integer ninfo;
real anorm, bnorm;
extern /* Subroutine */ int sggbak_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, integer *
), sggbal_(char *, integer *, real *, integer *,
real *, integer *, integer *, integer *, real *, real *, real *,
integer *);
real lscale[50];
extern doublereal slamch_(char *);
real rscale[50];
extern doublereal slange_(char *, integer *, integer *, real *, integer *,
real *);
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___35 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___39 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9991, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SCHKGK tests SGGBAK, a routine for backward balancing of */
/* a matrix pair (A, B). */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Initialization */
lmax[0] = 0;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
ninfo = 0;
knt = 0;
rmax = 0.f;
eps = slamch_("Precision");
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L100;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___10.ciunit = *nin;
s_rsle(&io___10);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&a[i__ + j * 50 - 51], (ftnlen)
sizeof(real));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = *nin;
s_rsle(&io___13);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&b[i__ + j * 50 - 51], (ftnlen)
sizeof(real));
}
e_rsle();
/* L30: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = *nin;
s_rsle(&io___15);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&vl[i__ + j * 50 - 51], (ftnlen)
sizeof(real));
}
e_rsle();
/* L40: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&vr[i__ + j * 50 - 51], (ftnlen)
sizeof(real));
}
e_rsle();
/* L50: */
}
++knt;
anorm = slange_("M", &n, &n, a, &c__50, work);
bnorm = slange_("M", &n, &n, b, &c__50, work);
slacpy_("FULL", &n, &n, a, &c__50, af, &c__50);
slacpy_("FULL", &n, &n, b, &c__50, bf, &c__50);
sggbal_("B", &n, a, &c__50, b, &c__50, &ilo, &ihi, lscale, rscale, work, &
info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
slacpy_("FULL", &n, &m, vl, &c__50, vlf, &c__50);
slacpy_("FULL", &n, &m, vr, &c__50, vrf, &c__50);
sggbak_("B", "L", &n, &ilo, &ihi, lscale, rscale, &m, vl, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[1] = knt;
}
sggbak_("B", "R", &n, &ilo, &ihi, lscale, rscale, &m, vr, &c__50, &info);
if (info != 0) {
++ninfo;
lmax[2] = knt;
}
/* Test of SGGBAK */
/* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR */
/* where tilde(A) denotes the transformed matrix. */
sgemm_("N", "N", &n, &m, &n, &c_b52, af, &c__50, vr, &c__50, &c_b55, work,
&c__50);
sgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e,
&c__50);
sgemm_("N", "N", &n, &m, &n, &c_b52, a, &c__50, vrf, &c__50, &c_b55, work,
&c__50);
sgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f,
&c__50);
vmax = 0.f;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = vmax, r__3 = (r__1 = e[i__ + j * 50 - 51] - f[i__ + j * 50
- 51], dabs(r__1));
vmax = dmax(r__2,r__3);
/* L60: */
}
/* L70: */
}
vmax /= eps * dmax(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
/* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR */
sgemm_("N", "N", &n, &m, &n, &c_b52, bf, &c__50, vr, &c__50, &c_b55, work,
&c__50);
sgemm_("T", "N", &m, &m, &n, &c_b52, vl, &c__50, work, &c__50, &c_b55, e,
&c__50);
sgemm_("N", "N", &n, &m, &n, &c_b52, b, &c__50, vrf, &c__50, &c_b55, work,
&c__50);
sgemm_("T", "N", &m, &m, &n, &c_b52, vlf, &c__50, work, &c__50, &c_b55, f,
&c__50);
vmax = 0.f;
i__1 = m;
for (j = 1; j <= i__1; ++j) {
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__) {
/* Computing MAX */
r__2 = vmax, r__3 = (r__1 = e[i__ + j * 50 - 51] - f[i__ + j * 50
- 51], dabs(r__1));
vmax = dmax(r__2,r__3);
/* L80: */
}
/* L90: */
}
vmax /= eps * dmax(anorm,bnorm);
if (vmax > rmax) {
lmax[3] = knt;
rmax = vmax;
}
goto L10;
L100:
io___34.ciunit = *nout;
s_wsfe(&io___34);
e_wsfe();
io___35.ciunit = *nout;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(real));
e_wsfe();
io___36.ciunit = *nout;
s_wsfe(&io___36);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___37.ciunit = *nout;
s_wsfe(&io___37);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *nout;
s_wsfe(&io___38);
do_fio(&c__1, (char *)&lmax[2], (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *nout;
s_wsfe(&io___39);
do_fio(&c__1, (char *)&lmax[3], (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of SCHKGK */
} /* schkgk_ */
/* Main program */ int main(int argc, char **argv)
{
/* Format strings */
static char fmt_9999[] = "(\002 *** Error: LSAME( \002,a1,\002, \002,"
"a1,\002) is .FALSE.\002)";
static char fmt_9998[] = "(\002 *** Error: LSAME( \002,a1,\002, \002,"
"a1,\002) is .TRUE.\002)";
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_wsfe(void);
/* Local variables */
integer i1, i2;
extern logical lsame_(char *, char *);
/* Fortran I/O blocks */
static cilist io___3 = { 0, 6, 0, 0, 0 };
static cilist io___4 = { 0, 6, 0, 0, 0 };
static cilist io___5 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___6 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___7 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___8 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___9 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___10 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___11 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___12 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___13 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___14 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___15 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___16 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
/* -- LAPACK test routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
libf2c_init(argc, argv);
/* Determine the character set. */
i1 = 'A';
i2 = 'a';
if (i2 - i1 == 32) {
s_wsle(&io___3);
do_lio(&c__9, &c__1, " ASCII character set", (ftnlen)20);
e_wsle();
} else {
s_wsle(&io___4);
do_lio(&c__9, &c__1, " Non-ASCII character set, IOFF should be ", (
ftnlen)41);
i__1 = i2 - i1;
do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsle();
}
/* Test LSAME. */
if (! lsame_("A", "A")) {
s_wsfe(&io___5);
do_fio(&c__1, "A", (ftnlen)1);
do_fio(&c__1, "A", (ftnlen)1);
e_wsfe();
}
if (! lsame_("A", "a")) {
s_wsfe(&io___6);
do_fio(&c__1, "A", (ftnlen)1);
do_fio(&c__1, "a", (ftnlen)1);
e_wsfe();
}
if (! lsame_("a", "A")) {
s_wsfe(&io___7);
do_fio(&c__1, "a", (ftnlen)1);
do_fio(&c__1, "A", (ftnlen)1);
e_wsfe();
}
if (! lsame_("a", "a")) {
s_wsfe(&io___8);
do_fio(&c__1, "a", (ftnlen)1);
do_fio(&c__1, "a", (ftnlen)1);
e_wsfe();
}
if (lsame_("A", "B")) {
s_wsfe(&io___9);
do_fio(&c__1, "A", (ftnlen)1);
do_fio(&c__1, "B", (ftnlen)1);
e_wsfe();
}
if (lsame_("A", "b")) {
s_wsfe(&io___10);
do_fio(&c__1, "A", (ftnlen)1);
do_fio(&c__1, "b", (ftnlen)1);
e_wsfe();
}
if (lsame_("a", "B")) {
s_wsfe(&io___11);
do_fio(&c__1, "a", (ftnlen)1);
do_fio(&c__1, "B", (ftnlen)1);
e_wsfe();
}
if (lsame_("a", "b")) {
s_wsfe(&io___12);
do_fio(&c__1, "a", (ftnlen)1);
do_fio(&c__1, "b", (ftnlen)1);
e_wsfe();
}
if (lsame_("O", "/")) {
s_wsfe(&io___13);
do_fio(&c__1, "O", (ftnlen)1);
do_fio(&c__1, "/", (ftnlen)1);
e_wsfe();
}
if (lsame_("/", "O")) {
s_wsfe(&io___14);
do_fio(&c__1, "/", (ftnlen)1);
do_fio(&c__1, "O", (ftnlen)1);
e_wsfe();
}
if (lsame_("o", "/")) {
s_wsfe(&io___15);
do_fio(&c__1, "o", (ftnlen)1);
do_fio(&c__1, "/", (ftnlen)1);
e_wsfe();
}
if (lsame_("/", "o")) {
s_wsfe(&io___16);
do_fio(&c__1, "/", (ftnlen)1);
do_fio(&c__1, "o", (ftnlen)1);
e_wsfe();
}
s_wsle(&io___17);
do_lio(&c__9, &c__1, " Tests completed", (ftnlen)16);
e_wsle();
libf2c_close();
return 0;
} /* MAIN__ */
/* * /////////////////////////////////////////////////////////////////////////// */
/* Subroutine */ int nrich_(integer *nx, integer *ny, integer *nz, integer *
ipc, doublereal *rpc, doublereal *ac, doublereal *cc, doublereal *fc,
doublereal *x, doublereal *w1, doublereal *w2, doublereal *r__,
integer *itmax, integer *iters, doublereal *errtol, doublereal *omega,
integer *iresid, integer *iadjoint)
{
/* System generated locals */
integer ac_dim1, ac_offset, cc_dim1, cc_dim2, cc_offset, fc_dim1, fc_dim2,
fc_offset, x_dim1, x_dim2, x_offset, w1_dim1, w1_dim2, w1_offset,
w2_dim1, w2_dim2, w2_offset, r_dim1, r_dim2, r_offset;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Local variables */
extern /* Subroutine */ int nrich7_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *), nrich27_(
integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
integer *, doublereal *, doublereal *, integer *, integer *);
static integer numdia;
/* Fortran I/O blocks */
static cilist io___2 = { 0, 6, 0, 0, 0 };
/* * ********************************************************************* */
/* * purpose: */
/* * */
/* * call the fast diagonal iterative method. */
/* * */
/* * author: michael holst */
/* * ********************************************************************* */
/* * */
/* mdir 0 0 */
/* * */
/* * *** do in one step *** */
/* Parameter adjustments */
r_dim1 = *nx;
r_dim2 = *ny;
r_offset = 1 + r_dim1 * (1 + r_dim2);
r__ -= r_offset;
w2_dim1 = *nx;
w2_dim2 = *ny;
w2_offset = 1 + w2_dim1 * (1 + w2_dim2);
w2 -= w2_offset;
w1_dim1 = *nx;
w1_dim2 = *ny;
w1_offset = 1 + w1_dim1 * (1 + w1_dim2);
w1 -= w1_offset;
x_dim1 = *nx;
x_dim2 = *ny;
x_offset = 1 + x_dim1 * (1 + x_dim2);
x -= x_offset;
fc_dim1 = *nx;
fc_dim2 = *ny;
fc_offset = 1 + fc_dim1 * (1 + fc_dim2);
fc -= fc_offset;
cc_dim1 = *nx;
cc_dim2 = *ny;
cc_offset = 1 + cc_dim1 * (1 + cc_dim2);
cc -= cc_offset;
ac_dim1 = *nx * *ny * *nz;
ac_offset = 1 + ac_dim1;
ac -= ac_offset;
--ipc;
--rpc;
/* Function Body */
numdia = ipc[11];
if (numdia == 7) {
nrich7_(nx, ny, nz, &ipc[1], &rpc[1], &ac[ac_dim1 + 1], &cc[cc_offset]
, &fc[fc_offset], &ac[(ac_dim1 << 1) + 1], &ac[ac_dim1 * 3 +
1], &ac[(ac_dim1 << 2) + 1], &x[x_offset], &w1[w1_offset], &
w2[w2_offset], &r__[r_offset], itmax, iters, errtol, omega,
iresid, iadjoint);
} else if (numdia == 27) {
nrich27_(nx, ny, nz, &ipc[1], &rpc[1], &ac[ac_dim1 + 1], &cc[
cc_offset], &fc[fc_offset], &ac[(ac_dim1 << 1) + 1], &ac[
ac_dim1 * 3 + 1], &ac[(ac_dim1 << 2) + 1], &ac[ac_dim1 * 5 +
1], &ac[ac_dim1 * 6 + 1], &ac[ac_dim1 * 7 + 1], &ac[(ac_dim1
<< 3) + 1], &ac[ac_dim1 * 9 + 1], &ac[ac_dim1 * 10 + 1], &ac[
ac_dim1 * 11 + 1], &ac[ac_dim1 * 12 + 1], &ac[ac_dim1 * 13 +
1], &ac[ac_dim1 * 14 + 1], &x[x_offset], &w1[w1_offset], &w2[
w2_offset], &r__[r_offset], itmax, iters, errtol, omega,
iresid, iadjoint);
} else {
s_wsle(&io___2);
do_lio(&c__9, &c__1, "% NRICH: invalid stencil type given...", (
ftnlen)38);
e_wsle();
}
/* * */
/* * *** return and end *** */
return 0;
} /* nrich_ */
/* Main program */ int MAIN__(void)
{
/* System generated locals */
integer i__1, i__2;
olist o__1;
cllist cl__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), f_open(olist *), s_rsle(cilist *), e_rsle(void),
f_clos(cllist *), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static real a[1000000] /* was [1000][1000] */, b[1000];
static integer i__, j, k, n;
static real p[1000];
static char orientacao[6];
static real num;
static integer argc;
extern /* Subroutine */ int exit_(void);
static char nome_arquivo__[20];
extern integer iargc_(void), lucol_(integer *, integer *, real *, real *),
sscol_(integer *, integer *, real *, real *, real *), lurow_(
integer *, integer *, real *, real *), ssrow_(integer *, integer *
, real *, real *, real *);
extern /* Subroutine */ int getarg_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___4 = { 0, 6, 0, 0, 0 };
static cilist io___5 = { 0, 1, 0, 0, 0 };
static cilist io___8 = { 0, 1, 0, 0, 0 };
static cilist io___13 = { 0, 1, 0, 0, 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, 0, 0 };
static cilist io___19 = { 0, 6, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, 0, 0 };
/* Matriz LU */
argc = iargc_();
if (argc > 1) {
getarg_(&c__1, nome_arquivo__, (ftnlen)20);
getarg_(&c__2, orientacao, (ftnlen)6);
} else {
s_wsle(&io___4);
do_lio(&c__9, &c__1, "Digite o nome do arquivo e se e orientada a li"
"nha ou coluna. (Ex: m1.dat linha)", (ftnlen)79);
e_wsle();
exit_();
}
o__1.oerr = 0;
o__1.ounit = 1;
o__1.ofnmlen = 20;
o__1.ofnm = nome_arquivo__;
o__1.orl = 0;
o__1.osta = "old";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
s_rsle(&io___5);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
/* Computing 2nd power */
i__2 = n;
i__1 = i__2 * i__2;
for (k = 1; k <= i__1; ++k) {
s_rsle(&io___8);
do_lio(&c__3, &c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&j, (ftnlen)sizeof(integer));
do_lio(&c__4, &c__1, (char *)&num, (ftnlen)sizeof(real));
e_rsle();
a[i__ + 1 + (j + 1) * 1000 - 1001] = num;
}
i__1 = n;
for (k = 1; k <= i__1; ++k) {
s_rsle(&io___13);
do_lio(&c__3, &c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_lio(&c__4, &c__1, (char *)&num, (ftnlen)sizeof(real));
e_rsle();
b[i__] = num;
}
cl__1.cerr = 0;
cl__1.cunit = 1;
cl__1.csta = 0;
f_clos(&cl__1);
/* ====================================================== */
/* OPERACAO POR LINHA */
if (s_cmp(orientacao, "linha", (ftnlen)6, (ftnlen)5) == 0 && lurow_(&n, &
c__1000, a, p) == -1) {
s_wsle(&io___16);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
if (s_cmp(orientacao, "linha", (ftnlen)6, (ftnlen)5) == 0 && ssrow_(&n, &
c__1000, a, p, b) == -1) {
s_wsle(&io___17);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
/* ====================================================== */
/* OPERACAO POR COLUNA */
if (s_cmp(orientacao, "coluna", (ftnlen)6, (ftnlen)6) == 0 && lucol_(&n, &
c__1000, a, p) == -1) {
s_wsle(&io___18);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
if (s_cmp(orientacao, "coluna", (ftnlen)6, (ftnlen)6) == 0 && sscol_(&n, &
c__1000, a, p, b) == -1) {
s_wsle(&io___19);
do_lio(&c__9, &c__1, "Matriz singular.", (ftnlen)16);
e_wsle();
exit_();
}
/* ====================================================== */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
s_wsle(&io___20);
do_lio(&c__4, &c__1, (char *)&b[i__ - 1], (ftnlen)sizeof(real));
e_wsle();
}
return 0;
} /* MAIN__ */
/* $Procedure DAFT2B ( DAF, text to binary ) */
/* Subroutine */ int daft2b_(integer *text, char *binary, integer *resv,
ftnlen binary_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void), s_cmp(char *, char *, ftnlen, ftnlen), s_rnge(char *
, integer, char *, integer);
/* Local variables */
char name__[1000*2];
integer more, i__;
extern /* Subroutine */ int chkin_(char *, ftnlen), dafps_(integer *,
integer *, doublereal *, integer *, doublereal *);
char tarch[8];
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
integer chunk, isize, lsize;
char ttype[8];
extern /* Subroutine */ int idw2at_(char *, char *, char *, ftnlen,
ftnlen, ftnlen), dafada_(doublereal *, integer *);
doublereal dc[125];
extern /* Subroutine */ int dafbna_(integer *, doublereal *, char *,
ftnlen);
integer ic[250];
extern /* Subroutine */ int dafena_(void);
integer nd;
extern logical failed_(void);
integer ni, handle;
extern /* Subroutine */ int dafcls_(integer *);
char ifname[60*2];
extern /* Subroutine */ int dafopn_(char *, integer *, integer *, char *,
integer *, integer *, ftnlen, ftnlen);
doublereal buffer[1024];
char idword[8];
extern /* Subroutine */ int errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
doublereal sum[125];
/* Fortran I/O blocks */
static cilist io___5 = { 1, 0, 1, 0, 0 };
static cilist io___6 = { 1, 0, 1, 0, 0 };
static cilist io___13 = { 1, 0, 1, 0, 0 };
static cilist io___15 = { 1, 0, 1, 0, 0 };
static cilist io___17 = { 1, 0, 1, 0, 0 };
static cilist io___20 = { 1, 0, 1, 0, 0 };
static cilist io___23 = { 1, 0, 1, 0, 0 };
static cilist io___25 = { 1, 0, 1, 0, 0 };
static cilist io___27 = { 1, 0, 1, 0, 0 };
static cilist io___28 = { 1, 0, 1, 0, 0 };
static cilist io___29 = { 1, 0, 1, 0, 0 };
static cilist io___30 = { 1, 0, 1, 0, 0 };
/* $ Abstract */
/* Deprecated. The routine DAFTB supersedes this routine. */
/* NAIF supports this routine only to provide backward */
/* compatibility. */
/* Reconstruct a binary DAF from a text file opened by */
/* the calling program. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Required_Reading */
/* DAF */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TEXT I Logical unit connected to text file. */
/* BINARY I Name of a binary DAF to be created. */
/* RESV I Number of records to reserve. */
/* BSIZE P Buffer size. */
/* $ Detailed_Input */
/* TEXT is a logical unit number, to which a text file has */
/* been connected by the calling program, and into */
/* which the contents of binary DAF have been */
/* written. The file pointer should be placed just */
/* before the file ID word. */
/* BINARY is the name of a binary DAF to be created. */
/* The binary DAF contains the same data as the */
/* text file, but in a form more suitable for use */
/* by application programs. */
/* RESV is the number of records to be reserved in the */
/* binary DAF. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* BSIZE is the size of the buffer used to read array elements */
/* from the text file. No single group of elements should */
/* contains more than BSIZE elements. */
/* $ Exceptions */
/* 1) If for some reason the text file cannot be read, */
/* the error SPICE(DAFREADFAIL) is signalled. */
/* 2) If the architecture of the file is not DAF, as specified by */
/* the ID word, the error SPICE(NOTADAFFILE) will be signalled. */
/* 3) If the text file does not contain matching internal file */
/* names, the error SPICE(DAFNOIFNMATCH) is signalled. */
/* 4) If the text file does not contain matching array names, */
/* the error SPICE(DAFNONAMEMATCH) is signalled. */
/* 5) If the buffer size is not sufficient, the error */
/* SPICE(DAFOVERFLOW) is signalled. */
/* $ Files */
/* See arguments TEXT, BINARY. */
/* $ Particulars */
/* This routine has been made obsolete by the new DAF text to binary */
/* conversion routine DAFTB. This routine remains available for */
/* reasons of backward compatibility. We strongly recommend that you */
/* use the new conversion routines for any new software development. */
/* Please see the header of the routine DAFTB for details. */
/* This routine is necessary for converting older DAF text files into */
/* their equivalent binary formats, as DAFTB uses a different text */
/* file format that is incompatible with the text file format */
/* expected by this routine. */
/* Any binary DAF may be transferred between heterogeneous */
/* Fortran environments by converting it to an equivalent file */
/* containing only ASCII characters. Such a file can be transferred */
/* almost universally, using any number of established protocols */
/* (Kermit, FTP, and so on). Once transferred, the ASCII file can */
/* be reconverted to a binary DAF, using the representations */
/* native to the new host environment. */
/* There are two pairs of routines that can be used to convert */
/* DAFs between binary and ASCII. The first pair, DAFB2A */
/* and DAFA2B, works with complete files. That is, DAFB2A creates */
/* a complete ASCII file containing all of the information in */
/* a particular binary DAF, and nothing else; this file can */
/* be fed directly into DAFA2B to produce a complete binary DAF. */
/* In each case, the names of the files are specified. */
/* A related pair of routines, DAFB2T and DAFT2B, assume that */
/* the ASCII data are to be stored in the midst of a text file. */
/* This allows the calling program to surround the data with */
/* standardized labels, to append several binary DAFs into a */
/* single text file, and so on. */
/* Note that you must select the number of records to be reserved */
/* in the binary DAF. The contents of reserved records are ignored */
/* by the normal transfer process. */
/* $ Examples */
/* DAFB2A and DAFA2B are typically used for simple transfers. */
/* If A.DAF is a binary DAF in environment 1, it can be transferred */
/* to environment 2 in three steps. */
/* 1) Convert it to ASCII: */
/* CALL DAFB2A ( 'A.DAF', 'A.ASCII' ) */
/* 2) Transfer the ASCII file, using FTP, Kermit, or some other */
/* file transfer utility: */
/* ftp> put a.ascii */
/* 3) Convert it to binary on the new machine, */
/* CALL DAFA2B ( 'A.ASCII', 'A.DAF', RESV ) */
/* Note that DAFB2A and DAFA2B work in any standard Fortran-77 */
/* environment. */
/* If the file needs to contain other information---a standard */
/* label, for instance---the first and third steps must be modified */
/* to use DAFB2T and DAFT2B. The first step becomes */
/* (Open a text file) */
/* (Write the label) */
/* CALL DAFB2T ( BINARY, UNIT ) */
/* (Close the text file) */
/* The third step becomes */
/* (Open the text file) */
/* (Read the label) */
/* CALL DAFT2B ( UNIT, BINARY, RESV ) */
/* (Close the text file) */
/* $ Restrictions */
/* DAFT2B cannot be executed while any other DAF is open */
/* for writing. */
/* $ Literature_References */
/* NAIF Document 167.0, "Double Precision Array Files (DAF) */
/* Specification and User's Guide" */
/* $ Author_and_Institution */
/* K. R. Gehringer (JPL) */
/* J.E. McLean (JPL) */
/* I.M. Underwood (JPL) */
/* $ Version */
/* - SPICELIB Version 3.0.1, 26-JUL-2012 (EDW) */
/* Edited Abstract section to use "Deprecated" keyword */
/* and state replacement routine. */
/* Eliminated unneeded Revisions section. */
/* - SPICELIB Version 3.0.0, 04-OCT-1993 (KRG) */
/* Removed the error SPICE(DAFNOIDWORD) as it was no longer */
/* relevant. */
/* Added the error SPICE(NOTADAFFILE) if this routine is called */
/* with a file that does not contain an ID word identifying the */
/* file as a DAF file. */
/* There were no checks of the IOSTAT variable after attempting to */
/* read from the text file, a single test of the IOSTAT variable */
/* was made at the end of the routine. This was not adequate to */
/* detect errors when writing to the text file. So after all of */
/* these read statements, an IF ... END IF block was added to */
/* signal an error if IOSTAT .NE. 0. */
/* IF ( IOSTAT .NE. 0 ) THEN */
/* CALL SETMSG ( 'The attempt to read from file ''#''' // */
/* . ' failed. IOSTAT = #.' ) */
/* CALL ERRFNM ( '#', UNIT ) */
/* CALL SIGERR ( 'SPICE(DAFREADFAIL)' ) */
/* CALL CHKOUT ( 'DAFT2B' ) */
/* RETURN */
/* END IF */
/* Removed the code from the end of the routine that purported to */
/* check for read errors: */
/* C */
/* C If any read screws up, they should all screw up. Why */
/* C make a billion separate checks? */
/* C */
/* IF ( IOSTAT .NE. 0 ) THEN */
/* CALL SETMSG ( 'Value of IOSTAT was: #. ' ) */
/* CALL ERRINT ( '#', IOSTAT ) */
/* CALL SIGERR ( 'SPICE(DAFREADFAIL)' ) */
/* END IF */
/* The answer to the question is: */
/* You have to do a billion separate checks because the IOSTAT */
/* value is only valid for the most recently executed read. */
/* Added a statment to the $ Particulars section to the effect */
/* that this routine has been made obsolete by the introduction of */
/* the routine DAFTB, and that we strongly recommend the use of */
/* the new routine. This routine must, however, be used when */
/* converting older text files to binary, as the old and new */
/* formats are not compatible. */
/* Modified the $ Abstract section to reflect the fact that this */
/* routine is obsolete and maintained for purposes of backward */
/* compatibility only. */
/* - SPICELIB Version 2.0.2, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 2.0.1, 6-AUG-1990 (HAN) */
/* Header documentation was corrected. This routine will */
/* convert a file containing either ID word, 'NAIF/DAF' or */
/* 'NAIF/NIP'. (Previous versions of SPICELIB software used */
/* the ID word 'NAIF/NIP'.) */
/* - SPICELIB Version 2.0.0, 2-AUG-1990 (JEM) */
/* The previous version of this routine always failed and */
/* signalled the error SPICE(DAFNOIDWORD) because of a faulty */
/* logical expression in an error-checking IF statement. */
/* The error SPICE(DAFNOIDWORD) should be signalled if the */
/* next non-blank line in the text file does not begin with the */
/* word 'NAIF/DAF' AND does not begin with the word 'NAIF/NIP'. */
/* Previously the logic was incorrect causing the error to be */
/* signalled every time no matter what the word was. The */
/* correction consisted of replacing '.OR.' with '.AND.' */
/* in the logical expression. */
/* - SPICELIB Version 1.0.1, 22-MAR-1990 (HAN) */
/* Literature references added to the header. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (IMU) */
/* -& */
/* $ Index_Entries */
/* text daf to binary */
/* -& */
/* SPICELIB functions */
/* Local Parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("DAFT2B", (ftnlen)6);
}
s_copy(idword, " ", (ftnlen)8, (ftnlen)1);
s_copy(tarch, " ", (ftnlen)8, (ftnlen)1);
s_copy(ttype, " ", (ftnlen)8, (ftnlen)1);
/* We should be positioned and ready to read the file ID word from */
/* the text file, so let's try it. */
io___5.ciunit = *text;
iostat = s_rsle(&io___5);
if (iostat != 0) {
goto L100001;
}
iostat = do_lio(&c__9, &c__1, idword, (ftnlen)8);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsle();
L100001:
if (iostat != 0) {
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Split the ID word into an architecture and type, and verify that */
/* the architecture is 'DAF'. If it is not, this is the wrong */
/* routine, and an error will be signalled. */
idw2at_(idword, tarch, ttype, (ftnlen)8, (ftnlen)8, (ftnlen)8);
if (s_cmp(tarch, "DAF", (ftnlen)8, (ftnlen)3) != 0) {
setmsg_("File architecture is not 'DAF' for file '#'", (ftnlen)43);
errfnm_("#", text, (ftnlen)1);
sigerr_("SPICE(NOTADAFFILE)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___6.ciunit = *text;
iostat = s_rsle(&io___6);
if (iostat != 0) {
goto L100002;
}
iostat = do_lio(&c__3, &c__1, (char *)&nd, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100002;
}
iostat = do_lio(&c__3, &c__1, (char *)&ni, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100002;
}
iostat = do_lio(&c__9, &c__1, ifname, (ftnlen)60);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsle();
L100002:
if (iostat != 0) {
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Open the new binary file. */
dafopn_(binary, &nd, &ni, ifname, resv, &handle, binary_len, (ftnlen)60);
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Each array is preceded by a '1', which indicates that more */
/* arrays are to come. The array itself begins with the name */
/* and the summary components, and ends with the name again. */
/* The contents are written in arbitrary chunks. The final */
/* chunk is followed by a '0', which indicates that no chunks */
/* remain. The names must match, or the array should not */
/* be terminated normally. */
/* If the chunks in the file are bigger than the local buffer */
/* size, we are in trouble. */
lsize = nd + (ni - 1) / 2 + 1;
isize = lsize << 3;
io___13.ciunit = *text;
iostat = s_rsle(&io___13);
if (iostat != 0) {
goto L100003;
}
iostat = do_lio(&c__3, &c__1, (char *)&more, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100003;
}
iostat = e_rsle();
L100003:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
while(more > 0) {
io___15.ciunit = *text;
iostat = s_rsle(&io___15);
if (iostat != 0) {
goto L100004;
}
iostat = do_lio(&c__9, &c__1, name__, isize);
if (iostat != 0) {
goto L100004;
}
iostat = e_rsle();
L100004:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___17.ciunit = *text;
iostat = s_rsle(&io___17);
if (iostat != 0) {
goto L100005;
}
i__1 = nd;
for (i__ = 1; i__ <= i__1; ++i__) {
iostat = do_lio(&c__5, &c__1, (char *)&dc[(i__2 = i__ - 1) < 125
&& 0 <= i__2 ? i__2 : s_rnge("dc", i__2, "daft2b_", (
ftnlen)465)], (ftnlen)sizeof(doublereal));
if (iostat != 0) {
goto L100005;
}
}
iostat = e_rsle();
L100005:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___20.ciunit = *text;
iostat = s_rsle(&io___20);
if (iostat != 0) {
goto L100006;
}
i__2 = ni - 2;
for (i__ = 1; i__ <= i__2; ++i__) {
iostat = do_lio(&c__3, &c__1, (char *)&ic[(i__1 = i__ - 1) < 250
&& 0 <= i__1 ? i__1 : s_rnge("ic", i__1, "daft2b_", (
ftnlen)480)], (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100006;
}
}
iostat = e_rsle();
L100006:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
dafps_(&nd, &ni, dc, ic, sum);
dafbna_(&handle, sum, name__, isize);
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
io___23.ciunit = *text;
iostat = s_rsle(&io___23);
if (iostat != 0) {
goto L100007;
}
iostat = do_lio(&c__3, &c__1, (char *)&chunk, (ftnlen)sizeof(integer))
;
if (iostat != 0) {
goto L100007;
}
iostat = e_rsle();
L100007:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
while(chunk > 0) {
if (chunk > 1024) {
dafcls_(&handle);
setmsg_("Buffer size exceeded. Increase to #.", (ftnlen)36);
errint_("#", &chunk, (ftnlen)1);
sigerr_("SPICE(DAFOVERFLOW)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
} else {
io___25.ciunit = *text;
iostat = s_rsle(&io___25);
if (iostat != 0) {
goto L100008;
}
i__1 = chunk;
for (i__ = 1; i__ <= i__1; ++i__) {
iostat = do_lio(&c__5, &c__1, (char *)&buffer[(i__2 = i__
- 1) < 1024 && 0 <= i__2 ? i__2 : s_rnge("buffer",
i__2, "daft2b_", (ftnlen)533)], (ftnlen)sizeof(
doublereal));
if (iostat != 0) {
goto L100008;
}
}
iostat = e_rsle();
L100008:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTA"
"T = #.", (ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
dafada_(buffer, &chunk);
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
io___27.ciunit = *text;
iostat = s_rsle(&io___27);
if (iostat != 0) {
goto L100009;
}
iostat = do_lio(&c__3, &c__1, (char *)&chunk, (ftnlen)sizeof(
integer));
if (iostat != 0) {
goto L100009;
}
iostat = e_rsle();
L100009:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = "
"#.", (ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
io___28.ciunit = *text;
iostat = s_rsle(&io___28);
if (iostat != 0) {
goto L100010;
}
iostat = do_lio(&c__9, &c__1, name__ + 1000, isize);
if (iostat != 0) {
goto L100010;
}
iostat = e_rsle();
L100010:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
if (s_cmp(name__, name__ + 1000, isize, isize) != 0) {
dafcls_(&handle);
setmsg_("Array name mismatch: # and #.", (ftnlen)29);
errch_("#", name__, (ftnlen)1, isize);
errch_("#", name__ + 1000, (ftnlen)1, isize);
sigerr_("SPICE(DAFNONAMEMATCH)", (ftnlen)21);
chkout_("DAFT2B", (ftnlen)6);
return 0;
} else {
dafena_();
if (failed_()) {
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
io___29.ciunit = *text;
iostat = s_rsle(&io___29);
if (iostat != 0) {
goto L100011;
}
iostat = do_lio(&c__3, &c__1, (char *)&more, (ftnlen)sizeof(integer));
if (iostat != 0) {
goto L100011;
}
iostat = e_rsle();
L100011:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
}
/* The final '0' indicates that no arrays remain. The first shall */
/* be last: the internal file name brings up the rear. If it doesn't */
/* match the one at the front, complain. */
io___30.ciunit = *text;
iostat = s_rsle(&io___30);
if (iostat != 0) {
goto L100012;
}
iostat = do_lio(&c__9, &c__1, ifname + 60, (ftnlen)60);
if (iostat != 0) {
goto L100012;
}
iostat = e_rsle();
L100012:
if (iostat != 0) {
dafcls_(&handle);
setmsg_("The attempt to read from file '#' failed. IOSTAT = #.", (
ftnlen)53);
errfnm_("#", text, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(DAFREADFAIL)", (ftnlen)18);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
if (s_cmp(ifname, ifname + 60, (ftnlen)60, (ftnlen)60) != 0) {
dafcls_(&handle);
setmsg_("Internal file name mismatch: # and #", (ftnlen)36);
errch_("#", ifname, (ftnlen)1, (ftnlen)60);
errch_("#", ifname + 60, (ftnlen)1, (ftnlen)60);
sigerr_("SPICE(DAFNOIFNMATCH)", (ftnlen)20);
chkout_("DAFT2B", (ftnlen)6);
return 0;
}
/* Close the DAF file we just created. */
dafcls_(&handle);
chkout_("DAFT2B", (ftnlen)6);
return 0;
} /* daft2b_ */
/* Subroutine */ int check2_(doublereal *sfac)
{
/* Initialized data */
static doublereal sa = .3;
static integer incxs[4] = { 1,2,-2,-1 };
static integer incys[4] = { 1,-2,1,-2 };
static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
static integer ns[4] = { 0,1,2,4 };
static doublereal dx1[7] = { .6,.1,-.5,.8,.9,-.3,-.4 };
static doublereal dy1[7] = { .5,-.9,.3,.7,-.6,.2,.8 };
static doublereal dt7[16] /* was [4][4] */ = { 0.,.3,.21,.62,0.,.3,-.07,
.85,0.,.3,-.79,-.74,0.,.3,.33,1.27 };
static doublereal dt8[112] /* was [7][4][4] */ = { .5,0.,0.,0.,0.,0.,0.,
.68,0.,0.,0.,0.,0.,0.,.68,-.87,0.,0.,0.,0.,0.,.68,-.87,.15,.94,0.,
0.,0.,.5,0.,0.,0.,0.,0.,0.,.68,0.,0.,0.,0.,0.,0.,.35,-.9,.48,0.,
0.,0.,0.,.38,-.9,.57,.7,-.75,.2,.98,.5,0.,0.,0.,0.,0.,0.,.68,0.,
0.,0.,0.,0.,0.,.35,-.72,0.,0.,0.,0.,0.,.38,-.63,.15,.88,0.,0.,0.,
.5,0.,0.,0.,0.,0.,0.,.68,0.,0.,0.,0.,0.,0.,.68,-.9,.33,0.,0.,0.,
0.,.68,-.9,.33,.7,-.75,.2,1.04 };
static doublereal dt10x[112] /* was [7][4][4] */ = { .6,0.,0.,0.,
0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.5,-.9,0.,0.,0.,0.,0.,.5,-.9,.3,.7,
0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.3,.1,.5,0.,0.,
0.,0.,.8,.1,-.6,.8,.3,-.3,.5,.6,0.,0.,0.,0.,0.,0.,.5,0.,0.,0.,0.,
0.,0.,-.9,.1,.5,0.,0.,0.,0.,.7,.1,.3,.8,-.9,-.3,.5,.6,0.,0.,0.,0.,
0.,0.,.5,0.,0.,0.,0.,0.,0.,.5,.3,0.,0.,0.,0.,0.,.5,.3,-.6,.8,0.,
0.,0. };
static doublereal dt10y[112] /* was [7][4][4] */ = { .5,0.,0.,0.,
0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.6,.1,0.,0.,0.,0.,0.,.6,.1,-.5,.8,
0.,0.,0.,.5,0.,0.,0.,0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,-.5,-.9,.6,0.,
0.,0.,0.,-.4,-.9,.9,.7,-.5,.2,.6,.5,0.,0.,0.,0.,0.,0.,.6,0.,0.,0.,
0.,0.,0.,-.5,.6,0.,0.,0.,0.,0.,-.4,.9,-.5,.6,0.,0.,0.,.5,0.,0.,0.,
0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.6,-.9,.1,0.,0.,0.,0.,.6,-.9,.1,.7,
-.5,.2,.8 };
static doublereal ssize1[4] = { 0.,.3,1.6,3.2 };
static doublereal ssize2[28] /* was [14][2] */ = { 0.,0.,0.,0.,0.,
0.,0.,0.,0.,0.,0.,0.,0.,0.,1.17,1.17,1.17,1.17,1.17,1.17,1.17,
1.17,1.17,1.17,1.17,1.17,1.17,1.17 };
/* System generated locals */
integer i__1;
doublereal d__1;
/* Local variables */
integer i__, j, ki, kn, mx, my;
doublereal sx[7], sy[7], stx[7], sty[7];
integer lenx, leny;
integer ksize;
/* Fortran I/O blocks */
static cilist io___58 = { 0, 6, 0, 0, 0 };
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* .. Executable Statements .. */
for (ki = 1; ki <= 4; ++ki) {
combla_1.incx = incxs[ki - 1];
combla_1.incy = incys[ki - 1];
mx = abs(combla_1.incx);
my = abs(combla_1.incy);
for (kn = 1; kn <= 4; ++kn) {
combla_1.n = ns[kn - 1];
ksize = min(2,kn);
lenx = lens[kn + (mx << 2) - 5];
leny = lens[kn + (my << 2) - 5];
/* .. Initialize all argument arrays .. */
for (i__ = 1; i__ <= 7; ++i__) {
sx[i__ - 1] = dx1[i__ - 1];
sy[i__ - 1] = dy1[i__ - 1];
/* L20: */
}
if (combla_1.icase == 1) {
/* .. DDOT .. */
d__1 = ddot_(&combla_1.n, sx, &combla_1.incx, sy, &
combla_1.incy);
stest1_(&d__1, &dt7[kn + (ki << 2) - 5], &ssize1[kn - 1],
sfac);
} else if (combla_1.icase == 2) {
/* .. DAXPY .. */
daxpy_(&combla_1.n, &sa, sx, &combla_1.incx, sy, &
combla_1.incy);
i__1 = leny;
for (j = 1; j <= i__1; ++j) {
sty[j - 1] = dt8[j + (kn + (ki << 2)) * 7 - 36];
/* L40: */
}
stest_(&leny, sy, sty, &ssize2[ksize * 14 - 14], sfac);
} else if (combla_1.icase == 5) {
/* .. DCOPY .. */
for (i__ = 1; i__ <= 7; ++i__) {
sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36];
/* L60: */
}
dcopy_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy);
stest_(&leny, sy, sty, ssize2, &c_b34);
} else if (combla_1.icase == 6) {
/* .. DSWAP .. */
dswap_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy);
for (i__ = 1; i__ <= 7; ++i__) {
stx[i__ - 1] = dt10x[i__ + (kn + (ki << 2)) * 7 - 36];
sty[i__ - 1] = dt10y[i__ + (kn + (ki << 2)) * 7 - 36];
/* L80: */
}
stest_(&lenx, sx, stx, ssize2, &c_b34);
stest_(&leny, sy, sty, ssize2, &c_b34);
} else {
s_wsle(&io___58);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK2", (ftnlen)
28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L100: */
}
/* L120: */
}
return 0;
} /* check2_ */
/* Subroutine */ int sget37_(real *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
integer i__, j, m, n;
real s[20], t[400] /* was [20][20] */, v, le[400] /* was [20][20] */,
re[400] /* was [20][20] */, wi[20], wr[20], val[3], dum[1],
eps, sep[20], sin__[20], tol, tmp[400] /* was [20][20] */;
integer ifnd, icmp, iscl, info, lcmp[3], kmin;
real wiin[20], vmax, tnrm, wrin[20], work[1200], vmul, stmp[20];
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real sepin[20], vimin, tolin, vrmin;
integer iwork[40];
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
real witmp[20], wrtmp[20];
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real
*, integer *, real *, real *, integer *, integer *);
logical select[20];
real bignum;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *), shseqr_(char *, char *,
integer *, integer *, integer *, real *, integer *, real *, real *
, real *, integer *, real *, integer *, integer *)
, strevc_(char *, char *, logical *, integer *, real *, integer *,
real *, integer *, real *, integer *, integer *, integer *, real
*, integer *);
real septmp[20];
extern /* Subroutine */ int strsna_(char *, char *, logical *, integer *,
real *, integer *, real *, integer *, real *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *,
integer *);
real smlnum;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 0, 0, 0, 0 };
static cilist io___8 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SGET37 tests STRSNA, a routine for estimating condition numbers of */
/* eigenvalues and/or right eigenvectors of a matrix. */
/* The test matrices are read from a file with logical unit number NIN. */
/* Arguments */
/* ========== */
/* RMAX (output) REAL array, dimension (3) */
/* Value of the largest test ratio. */
/* RMAX(1) = largest ratio comparing different calls to STRSNA */
/* RMAX(2) = largest error in reciprocal condition */
/* numbers taking their conditioning into account */
/* RMAX(3) = largest error in reciprocal condition */
/* numbers not taking their conditioning into */
/* account (may be larger than RMAX(2)) */
/* LMAX (output) INTEGER array, dimension (3) */
/* LMAX(i) is example number where largest test ratio */
/* RMAX(i) is achieved. Also: */
/* If SGEHRD returns INFO nonzero on example i, LMAX(1)=i */
/* If SHSEQR returns INFO nonzero on example i, LMAX(2)=i */
/* If STRSNA returns INFO nonzero on example i, LMAX(3)=i */
/* NINFO (output) INTEGER array, dimension (3) */
/* NINFO(1) = No. of times SGEHRD returned INFO nonzero */
/* NINFO(2) = No. of times SHSEQR returned INFO nonzero */
/* NINFO(3) = No. of times STRSNA returned INFO nonzero */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* NIN (input) INTEGER */
/* Input logical unit number */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--ninfo;
--lmax;
--rmax;
/* Function Body */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* EPSIN = 2**(-24) = precision to which input data computed */
eps = dmax(eps,5.9605e-8f);
rmax[1] = 0.f;
rmax[2] = 0.f;
rmax[3] = 0.f;
lmax[1] = 0;
lmax[2] = 0;
lmax[3] = 0;
*knt = 0;
ninfo[1] = 0;
ninfo[2] = 0;
ninfo[3] = 0;
val[0] = sqrt(smlnum);
val[1] = 1.f;
val[2] = sqrt(bignum);
/* Read input data until N=0. Assume input eigenvalues are sorted */
/* lexicographically (increasing by real part, then decreasing by */
/* imaginary part) */
L10:
io___5.ciunit = *nin;
s_rsle(&io___5);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___8.ciunit = *nin;
s_rsle(&io___8);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&tmp[i__ + j * 20 - 21], (ftnlen)
sizeof(real));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___11.ciunit = *nin;
s_rsle(&io___11);
do_lio(&c__4, &c__1, (char *)&wrin[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&wiin[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&sin__[i__ - 1], (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&sepin[i__ - 1], (ftnlen)sizeof(real));
e_rsle();
/* L30: */
}
tnrm = slange_("M", &n, &n, tmp, &c__20, work);
/* Begin test */
for (iscl = 1; iscl <= 3; ++iscl) {
/* Scale input matrix */
++(*knt);
slacpy_("F", &n, &n, tmp, &c__20, t, &c__20);
vmul = val[iscl - 1];
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
sscal_(&n, &vmul, &t[i__ * 20 - 20], &c__1);
/* L40: */
}
if (tnrm == 0.f) {
vmul = 1.f;
}
/* Compute eigenvalues and eigenvectors */
i__1 = 1200 - n;
sgehrd_(&n, &c__1, &n, t, &c__20, work, &work[n], &i__1, &info);
if (info != 0) {
lmax[1] = *knt;
++ninfo[1];
goto L240;
}
i__1 = n - 2;
for (j = 1; j <= i__1; ++j) {
i__2 = n;
for (i__ = j + 2; i__ <= i__2; ++i__) {
t[i__ + j * 20 - 21] = 0.f;
/* L50: */
}
/* L60: */
}
/* Compute Schur form */
shseqr_("S", "N", &n, &c__1, &n, t, &c__20, wr, wi, dum, &c__1, work,
&c__1200, &info);
if (info != 0) {
lmax[2] = *knt;
++ninfo[2];
goto L240;
}
/* Compute eigenvectors */
strevc_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
&n, &m, work, &info);
/* Compute condition numbers */
strsna_("Both", "All", select, &n, t, &c__20, le, &c__20, re, &c__20,
s, sep, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
/* Sort eigenvalues and condition numbers lexicographically */
/* to compare with inputs */
scopy_(&n, wr, &c__1, wrtmp, &c__1);
scopy_(&n, wi, &c__1, witmp, &c__1);
scopy_(&n, s, &c__1, stmp, &c__1);
scopy_(&n, sep, &c__1, septmp, &c__1);
r__1 = 1.f / vmul;
sscal_(&n, &r__1, septmp, &c__1);
i__1 = n - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
kmin = i__;
vrmin = wrtmp[i__ - 1];
vimin = witmp[i__ - 1];
i__2 = n;
for (j = i__ + 1; j <= i__2; ++j) {
if (wrtmp[j - 1] < vrmin) {
kmin = j;
vrmin = wrtmp[j - 1];
vimin = witmp[j - 1];
}
/* L70: */
}
wrtmp[kmin - 1] = wrtmp[i__ - 1];
witmp[kmin - 1] = witmp[i__ - 1];
wrtmp[i__ - 1] = vrmin;
witmp[i__ - 1] = vimin;
vrmin = stmp[kmin - 1];
stmp[kmin - 1] = stmp[i__ - 1];
stmp[i__ - 1] = vrmin;
vrmin = septmp[kmin - 1];
septmp[kmin - 1] = septmp[i__ - 1];
septmp[i__ - 1] = vrmin;
/* L80: */
}
/* Compare condition numbers for eigenvalues */
/* taking their condition numbers into account */
/* Computing MAX */
r__1 = (real) n * 2.f * eps * tnrm;
v = dmax(r__1,smlnum);
if (tnrm == 0.f) {
v = 1.f;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (v > septmp[i__ - 1]) {
tol = 1.f;
} else {
tol = v / septmp[i__ - 1];
}
if (v > sepin[i__ - 1]) {
tolin = 1.f;
} else {
tolin = v / sepin[i__ - 1];
}
/* Computing MAX */
r__1 = tol, r__2 = smlnum / eps;
tol = dmax(r__1,r__2);
/* Computing MAX */
r__1 = tolin, r__2 = smlnum / eps;
tolin = dmax(r__1,r__2);
if (eps * (sin__[i__ - 1] - tolin) > stmp[i__ - 1] + tol) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] - tolin > stmp[i__ - 1] + tol) {
vmax = (sin__[i__ - 1] - tolin) / (stmp[i__ - 1] + tol);
} else if (sin__[i__ - 1] + tolin < eps * (stmp[i__ - 1] - tol)) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] + tolin < stmp[i__ - 1] - tol) {
vmax = (stmp[i__ - 1] - tol) / (sin__[i__ - 1] + tolin);
} else {
vmax = 1.f;
}
if (vmax > rmax[2]) {
rmax[2] = vmax;
if (ninfo[2] == 0) {
lmax[2] = *knt;
}
}
/* L90: */
}
/* Compare condition numbers for eigenvectors */
/* taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (v > septmp[i__ - 1] * stmp[i__ - 1]) {
tol = septmp[i__ - 1];
} else {
tol = v / stmp[i__ - 1];
}
if (v > sepin[i__ - 1] * sin__[i__ - 1]) {
tolin = sepin[i__ - 1];
} else {
tolin = v / sin__[i__ - 1];
}
/* Computing MAX */
r__1 = tol, r__2 = smlnum / eps;
tol = dmax(r__1,r__2);
/* Computing MAX */
r__1 = tolin, r__2 = smlnum / eps;
tolin = dmax(r__1,r__2);
if (eps * (sepin[i__ - 1] - tolin) > septmp[i__ - 1] + tol) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] - tolin > septmp[i__ - 1] + tol) {
vmax = (sepin[i__ - 1] - tolin) / (septmp[i__ - 1] + tol);
} else if (sepin[i__ - 1] + tolin < eps * (septmp[i__ - 1] - tol))
{
vmax = 1.f / eps;
} else if (sepin[i__ - 1] + tolin < septmp[i__ - 1] - tol) {
vmax = (septmp[i__ - 1] - tol) / (sepin[i__ - 1] + tolin);
} else {
vmax = 1.f;
}
if (vmax > rmax[2]) {
rmax[2] = vmax;
if (ninfo[2] == 0) {
lmax[2] = *knt;
}
}
/* L100: */
}
/* Compare condition numbers for eigenvalues */
/* without taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (sin__[i__ - 1] <= (real) (n << 1) * eps && stmp[i__ - 1] <= (
real) (n << 1) * eps) {
vmax = 1.f;
} else if (eps * sin__[i__ - 1] > stmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] > stmp[i__ - 1]) {
vmax = sin__[i__ - 1] / stmp[i__ - 1];
} else if (sin__[i__ - 1] < eps * stmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sin__[i__ - 1] < stmp[i__ - 1]) {
vmax = stmp[i__ - 1] / sin__[i__ - 1];
} else {
vmax = 1.f;
}
if (vmax > rmax[3]) {
rmax[3] = vmax;
if (ninfo[3] == 0) {
lmax[3] = *knt;
}
}
/* L110: */
}
/* Compare condition numbers for eigenvectors */
/* without taking their condition numbers into account */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (sepin[i__ - 1] <= v && septmp[i__ - 1] <= v) {
vmax = 1.f;
} else if (eps * sepin[i__ - 1] > septmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] > septmp[i__ - 1]) {
vmax = sepin[i__ - 1] / septmp[i__ - 1];
} else if (sepin[i__ - 1] < eps * septmp[i__ - 1]) {
vmax = 1.f / eps;
} else if (sepin[i__ - 1] < septmp[i__ - 1]) {
vmax = septmp[i__ - 1] / sepin[i__ - 1];
} else {
vmax = 1.f;
}
if (vmax > rmax[3]) {
rmax[3] = vmax;
if (ninfo[3] == 0) {
lmax[3] = *knt;
}
}
/* L120: */
}
/* Compute eigenvalue condition numbers only and compare */
vmax = 0.f;
dum[0] = -1.f;
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "All", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L130: */
}
/* Compute eigenvector condition numbers only and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "All", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
/* L140: */
}
/* Compute all condition numbers using SELECT and compare */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
select[i__ - 1] = TRUE_;
/* L150: */
}
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
/* L160: */
}
/* Compute eigenvalue condition numbers using SELECT and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != s[i__ - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L170: */
}
/* Compute eigenvector condition numbers using SELECT and compare */
scopy_(&n, dum, &c__0, stmp, &c__1);
scopy_(&n, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[i__ - 1]) {
vmax = 1.f / eps;
}
/* L180: */
}
if (vmax > rmax[1]) {
rmax[1] = vmax;
if (ninfo[1] == 0) {
lmax[1] = *knt;
}
}
/* Select first real and first complex eigenvalue */
if (wi[0] == 0.f) {
lcmp[0] = 1;
ifnd = 0;
i__1 = n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (ifnd == 1 || wi[i__ - 1] == 0.f) {
select[i__ - 1] = FALSE_;
} else {
ifnd = 1;
lcmp[1] = i__;
lcmp[2] = i__ + 1;
scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[20], &c__1);
scopy_(&n, &re[(i__ + 1) * 20 - 20], &c__1, &re[40], &
c__1);
scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[20], &c__1);
scopy_(&n, &le[(i__ + 1) * 20 - 20], &c__1, &le[40], &
c__1);
}
/* L190: */
}
if (ifnd == 0) {
icmp = 1;
} else {
icmp = 3;
}
} else {
lcmp[0] = 1;
lcmp[1] = 2;
ifnd = 0;
i__1 = n;
for (i__ = 3; i__ <= i__1; ++i__) {
if (ifnd == 1 || wi[i__ - 1] != 0.f) {
select[i__ - 1] = FALSE_;
} else {
lcmp[2] = i__;
ifnd = 1;
scopy_(&n, &re[i__ * 20 - 20], &c__1, &re[40], &c__1);
scopy_(&n, &le[i__ * 20 - 20], &c__1, &le[40], &c__1);
}
/* L200: */
}
if (ifnd == 0) {
icmp = 2;
} else {
icmp = 3;
}
}
/* Compute all selected condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Bothcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (septmp[i__ - 1] != sep[j - 1]) {
vmax = 1.f / eps;
}
if (stmp[i__ - 1] != s[j - 1]) {
vmax = 1.f / eps;
}
/* L210: */
}
/* Compute selected eigenvalue condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Eigcond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (stmp[i__ - 1] != s[j - 1]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
/* L220: */
}
/* Compute selected eigenvector condition numbers */
scopy_(&icmp, dum, &c__0, stmp, &c__1);
scopy_(&icmp, dum, &c__0, septmp, &c__1);
strsna_("Veccond", "Some", select, &n, t, &c__20, le, &c__20, re, &
c__20, stmp, septmp, &n, &m, work, &n, iwork, &info);
if (info != 0) {
lmax[3] = *knt;
++ninfo[3];
goto L240;
}
i__1 = icmp;
for (i__ = 1; i__ <= i__1; ++i__) {
j = lcmp[i__ - 1];
if (stmp[i__ - 1] != dum[0]) {
vmax = 1.f / eps;
}
if (septmp[i__ - 1] != sep[j - 1]) {
vmax = 1.f / eps;
}
/* L230: */
}
if (vmax > rmax[1]) {
rmax[1] = vmax;
if (ninfo[1] == 0) {
lmax[1] = *knt;
}
}
L240:
;
}
goto L10;
/* End of SGET37 */
} /* sget37_ */
/* Subroutine */ int check3_(doublereal *sfac)
{
/* Initialized data */
static integer incxs[4] = { 1,2,-2,-1 };
static integer incys[4] = { 1,-2,1,-2 };
static integer lens[8] /* was [4][2] */ = { 1,1,2,4,1,1,3,7 };
static integer ns[4] = { 0,1,2,4 };
static doublereal dx1[7] = { .6,.1,-.5,.8,.9,-.3,-.4 };
static doublereal dy1[7] = { .5,-.9,.3,.7,-.6,.2,.8 };
static doublereal sc = .8;
static doublereal ss = .6;
static doublereal dt9x[112] /* was [7][4][4] */ = { .6,0.,0.,0.,0.,0.,0.,
.78,0.,0.,0.,0.,0.,0.,.78,-.46,0.,0.,0.,0.,0.,.78,-.46,-.22,1.06,
0.,0.,0.,.6,0.,0.,0.,0.,0.,0.,.78,0.,0.,0.,0.,0.,0.,.66,.1,-.1,0.,
0.,0.,0.,.96,.1,-.76,.8,.9,-.3,-.02,.6,0.,0.,0.,0.,0.,0.,.78,0.,
0.,0.,0.,0.,0.,-.06,.1,-.1,0.,0.,0.,0.,.9,.1,-.22,.8,.18,-.3,-.02,
.6,0.,0.,0.,0.,0.,0.,.78,0.,0.,0.,0.,0.,0.,.78,.26,0.,0.,0.,0.,0.,
.78,.26,-.76,1.12,0.,0.,0. };
static doublereal dt9y[112] /* was [7][4][4] */ = { .5,0.,0.,0.,0.,0.,0.,
.04,0.,0.,0.,0.,0.,0.,.04,-.78,0.,0.,0.,0.,0.,.04,-.78,.54,.08,0.,
0.,0.,.5,0.,0.,0.,0.,0.,0.,.04,0.,0.,0.,0.,0.,0.,.7,-.9,-.12,0.,
0.,0.,0.,.64,-.9,-.3,.7,-.18,.2,.28,.5,0.,0.,0.,0.,0.,0.,.04,0.,
0.,0.,0.,0.,0.,.7,-1.08,0.,0.,0.,0.,0.,.64,-1.26,.54,.2,0.,0.,0.,
.5,0.,0.,0.,0.,0.,0.,.04,0.,0.,0.,0.,0.,0.,.04,-.9,.18,0.,0.,0.,
0.,.04,-.9,.18,.7,-.18,.2,.16 };
static doublereal ssize2[28] /* was [14][2] */ = { 0.,0.,0.,0.,0.,
0.,0.,0.,0.,0.,0.,0.,0.,0.,1.17,1.17,1.17,1.17,1.17,1.17,1.17,
1.17,1.17,1.17,1.17,1.17,1.17,1.17 };
/* Local variables */
integer i__, k, ki, kn, mx, my;
doublereal sx[7], sy[7], stx[7], sty[7];
integer lenx, leny;
doublereal mwpc[11];
integer mwpn[11];
doublereal mwps[11], mwpx[5], mwpy[5];
integer ksize;
doublereal copyx[5], copyy[5];
doublereal mwptx[55] /* was [11][5] */, mwpty[55] /* was [11][5]
*/;
integer mwpinx[11], mwpiny[11];
doublereal mwpstx[5], mwpsty[5];
/* Fortran I/O blocks */
static cilist io___82 = { 0, 6, 0, 0, 0 };
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* .. Common blocks .. */
/* .. Data statements .. */
/* .. Executable Statements .. */
for (ki = 1; ki <= 4; ++ki) {
combla_1.incx = incxs[ki - 1];
combla_1.incy = incys[ki - 1];
mx = abs(combla_1.incx);
my = abs(combla_1.incy);
for (kn = 1; kn <= 4; ++kn) {
combla_1.n = ns[kn - 1];
ksize = min(2,kn);
lenx = lens[kn + (mx << 2) - 5];
leny = lens[kn + (my << 2) - 5];
if (combla_1.icase == 4) {
/* .. DROT .. */
for (i__ = 1; i__ <= 7; ++i__) {
sx[i__ - 1] = dx1[i__ - 1];
sy[i__ - 1] = dy1[i__ - 1];
stx[i__ - 1] = dt9x[i__ + (kn + (ki << 2)) * 7 - 36];
sty[i__ - 1] = dt9y[i__ + (kn + (ki << 2)) * 7 - 36];
/* L20: */
}
drot_(&combla_1.n, sx, &combla_1.incx, sy, &combla_1.incy, &
sc, &ss);
stest_(&lenx, sx, stx, &ssize2[ksize * 14 - 14], sfac);
stest_(&leny, sy, sty, &ssize2[ksize * 14 - 14], sfac);
} else {
s_wsle(&io___82);
do_lio(&c__9, &c__1, " Shouldn't be here in CHECK3", (ftnlen)
28);
e_wsle();
s_stop("", (ftnlen)0);
}
/* L40: */
}
/* L60: */
}
mwpc[0] = 1.;
for (i__ = 2; i__ <= 11; ++i__) {
mwpc[i__ - 1] = 0.;
/* L80: */
}
mwps[0] = 0.;
for (i__ = 2; i__ <= 6; ++i__) {
mwps[i__ - 1] = 1.;
/* L100: */
}
for (i__ = 7; i__ <= 11; ++i__) {
mwps[i__ - 1] = -1.;
/* L120: */
}
mwpinx[0] = 1;
mwpinx[1] = 1;
mwpinx[2] = 1;
mwpinx[3] = -1;
mwpinx[4] = 1;
mwpinx[5] = -1;
mwpinx[6] = 1;
mwpinx[7] = 1;
mwpinx[8] = -1;
mwpinx[9] = 1;
mwpinx[10] = -1;
mwpiny[0] = 1;
mwpiny[1] = 1;
mwpiny[2] = -1;
mwpiny[3] = -1;
mwpiny[4] = 2;
mwpiny[5] = 1;
mwpiny[6] = 1;
mwpiny[7] = -1;
mwpiny[8] = -1;
mwpiny[9] = 2;
mwpiny[10] = 1;
for (i__ = 1; i__ <= 11; ++i__) {
mwpn[i__ - 1] = 5;
/* L140: */
}
mwpn[4] = 3;
mwpn[9] = 3;
for (i__ = 1; i__ <= 5; ++i__) {
mwpx[i__ - 1] = (doublereal) i__;
mwpy[i__ - 1] = (doublereal) i__;
mwptx[i__ * 11 - 11] = (doublereal) i__;
mwpty[i__ * 11 - 11] = (doublereal) i__;
mwptx[i__ * 11 - 10] = (doublereal) i__;
mwpty[i__ * 11 - 10] = (doublereal) (-i__);
mwptx[i__ * 11 - 9] = (doublereal) (6 - i__);
mwpty[i__ * 11 - 9] = (doublereal) (i__ - 6);
mwptx[i__ * 11 - 8] = (doublereal) i__;
mwpty[i__ * 11 - 8] = (doublereal) (-i__);
mwptx[i__ * 11 - 6] = (doublereal) (6 - i__);
mwpty[i__ * 11 - 6] = (doublereal) (i__ - 6);
mwptx[i__ * 11 - 5] = (doublereal) (-i__);
mwpty[i__ * 11 - 5] = (doublereal) i__;
mwptx[i__ * 11 - 4] = (doublereal) (i__ - 6);
mwpty[i__ * 11 - 4] = (doublereal) (6 - i__);
mwptx[i__ * 11 - 3] = (doublereal) (-i__);
mwpty[i__ * 11 - 3] = (doublereal) i__;
mwptx[i__ * 11 - 1] = (doublereal) (i__ - 6);
mwpty[i__ * 11 - 1] = (doublereal) (6 - i__);
/* L160: */
}
mwptx[4] = 1.;
mwptx[15] = 3.;
mwptx[26] = 5.;
mwptx[37] = 4.;
mwptx[48] = 5.;
mwpty[4] = -1.;
mwpty[15] = 2.;
mwpty[26] = -2.;
mwpty[37] = 4.;
mwpty[48] = -3.;
mwptx[9] = -1.;
mwptx[20] = -3.;
mwptx[31] = -5.;
mwptx[42] = 4.;
mwptx[53] = 5.;
mwpty[9] = 1.;
mwpty[20] = 2.;
mwpty[31] = 2.;
mwpty[42] = 4.;
mwpty[53] = 3.;
for (i__ = 1; i__ <= 11; ++i__) {
combla_1.incx = mwpinx[i__ - 1];
combla_1.incy = mwpiny[i__ - 1];
for (k = 1; k <= 5; ++k) {
copyx[k - 1] = mwpx[k - 1];
copyy[k - 1] = mwpy[k - 1];
mwpstx[k - 1] = mwptx[i__ + k * 11 - 12];
mwpsty[k - 1] = mwpty[i__ + k * 11 - 12];
/* L180: */
}
drot_(&mwpn[i__ - 1], copyx, &combla_1.incx, copyy, &combla_1.incy, &
mwpc[i__ - 1], &mwps[i__ - 1]);
stest_(&c__5, copyx, mwpstx, mwpstx, sfac);
stest_(&c__5, copyy, mwpsty, mwpsty, sfac);
/* L200: */
}
return 0;
} /* check3_ */
/* Main program */ MAIN__(void)
{
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992 */
/* Table of constant values */
static integer c__9 = 9;
static integer c__1 = 1;
static integer c__4 = 4;
/* System generated locals */
real r__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Local variables */
static real base, emin, prec, emax, rmin, rmax, t, sfmin;
extern doublereal slamch_(char *);
static real rnd, eps;
/* Fortran I/O blocks */
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___12 = { 0, 6, 0, 0, 0 };
static cilist io___13 = { 0, 6, 0, 0, 0 };
static cilist io___14 = { 0, 6, 0, 0, 0 };
static cilist io___15 = { 0, 6, 0, 0, 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, 0, 0 };
static cilist io___19 = { 0, 6, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, 0, 0 };
static cilist io___21 = { 0, 6, 0, 0, 0 };
eps = slamch_("Epsilon");
sfmin = slamch_("Safe minimum");
base = slamch_("Base");
prec = slamch_("Precision");
t = slamch_("Number of digits in mantissa");
rnd = slamch_("Rounding mode");
emin = slamch_("Minimum exponent");
rmin = slamch_("Underflow threshold");
emax = slamch_("Largest exponent");
rmax = slamch_("Overflow threshold");
s_wsle(&io___11);
do_lio(&c__9, &c__1, " Epsilon = ", 32L);
do_lio(&c__4, &c__1, (char *)&eps, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___12);
do_lio(&c__9, &c__1, " Safe minimum = ", 32L);
do_lio(&c__4, &c__1, (char *)&sfmin, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___13);
do_lio(&c__9, &c__1, " Base = ", 32L);
do_lio(&c__4, &c__1, (char *)&base, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___14);
do_lio(&c__9, &c__1, " Precision = ", 32L);
do_lio(&c__4, &c__1, (char *)&prec, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___15);
do_lio(&c__9, &c__1, " Number of digits in mantissa = ", 32L);
do_lio(&c__4, &c__1, (char *)&t, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___16);
do_lio(&c__9, &c__1, " Rounding mode = ", 32L);
do_lio(&c__4, &c__1, (char *)&rnd, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___17);
do_lio(&c__9, &c__1, " Minimum exponent = ", 32L);
do_lio(&c__4, &c__1, (char *)&emin, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___18);
do_lio(&c__9, &c__1, " Underflow threshold = ", 32L);
do_lio(&c__4, &c__1, (char *)&rmin, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___19);
do_lio(&c__9, &c__1, " Largest exponent = ", 32L);
do_lio(&c__4, &c__1, (char *)&emax, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___20);
do_lio(&c__9, &c__1, " Overflow threshold = ", 32L);
do_lio(&c__4, &c__1, (char *)&rmax, (ftnlen)sizeof(real));
e_wsle();
s_wsle(&io___21);
do_lio(&c__9, &c__1, " Reciprocal of safe minimum = ", 32L);
r__1 = 1 / sfmin;
do_lio(&c__4, &c__1, (char *)&r__1, (ftnlen)sizeof(real));
e_wsle();
return 0;
} /* MAIN__
/* Subroutine */ int dchkbk_(integer *nin, integer *nout)
{
/* Format strings */
static char fmt_9999[] = "(1x,\002.. test output of DGEBAK .. \002)";
static char fmt_9998[] = "(1x,\002value of largest test error "
" = \002,d12.3)";
static char fmt_9997[] = "(1x,\002example number where info is not zero "
" = \002,i4)";
static char fmt_9996[] = "(1x,\002example number having largest error "
" = \002,i4)";
static char fmt_9995[] = "(1x,\002number of examples where info is not 0"
" = \002,i4)";
static char fmt_9994[] = "(1x,\002total number of examples tested "
" = \002,i4)";
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void), s_wsfe(cilist *), e_wsfe(void), do_fio(integer *,
char *, ftnlen);
/* Local variables */
doublereal e[400] /* was [20][20] */;
integer i__, j, n;
doublereal x;
integer ihi;
doublereal ein[400] /* was [20][20] */;
integer ilo;
doublereal eps;
integer knt, info, lmax[2];
doublereal rmax, vmax, scale[20];
integer ninfo;
extern /* Subroutine */ int dgebak_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
extern doublereal dlamch_(char *);
doublereal safmin;
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9994, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKBK tests DGEBAK, a routine for backward transformation of */
/* the computed right or left eigenvectors if the orginal matrix */
/* was preprocessed by balance subroutine DGEBAL. */
/* Arguments */
/* ========= */
/* NIN (input) INTEGER */
/* The logical unit number for input. NIN > 0. */
/* NOUT (input) INTEGER */
/* The logical unit number for output. NOUT > 0. */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
lmax[0] = 0;
lmax[1] = 0;
ninfo = 0;
knt = 0;
rmax = 0.;
eps = dlamch_("E");
safmin = dlamch_("S");
L10:
io___7.ciunit = *nin;
s_rsle(&io___7);
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ilo, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&ihi, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
goto L60;
}
io___11.ciunit = *nin;
s_rsle(&io___11);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__5, &c__1, (char *)&scale[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___14.ciunit = *nin;
s_rsle(&io___14);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__5, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
sizeof(doublereal));
}
e_rsle();
/* L30: */
}
++knt;
dgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
x = (d__1 = e[i__ + j * 20 - 21] - ein[i__ + j * 20 - 21], abs(
d__1)) / eps;
if ((d__1 = e[i__ + j * 20 - 21], abs(d__1)) > safmin) {
x /= (d__2 = e[i__ + j * 20 - 21], abs(d__2));
}
vmax = max(vmax,x);
/* L40: */
}
/* L50: */
}
if (vmax > rmax) {
lmax[1] = knt;
rmax = vmax;
}
goto L10;
L60:
io___22.ciunit = *nout;
s_wsfe(&io___22);
e_wsfe();
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of DCHKBK */
} /* dchkbk_ */
/* Main program */ int MAIN__(void)
{
/* Format strings */
static char fmt_9994[] = "(/\002 Tests of the DOUBLE PRECISION LAPACK RF"
"P routines \002,/\002 LAPACK VERSION \002,i1,\002.\002,i1,\002"
".\002,i1,//\002 The following parameter values will be used:\002)"
;
static char fmt_9996[] = "(\002 !! Invalid input value: \002,a4,\002="
"\002,i6,\002; must be >=\002,i6)";
static char fmt_9995[] = "(\002 !! Invalid input value: \002,a4,\002="
"\002,i6,\002; must be <=\002,i6)";
static char fmt_9993[] = "(4x,a4,\002: \002,10i6,/11x,10i6)";
static char fmt_9992[] = "(/\002 Routines pass computational tests if te"
"st ratio is \002,\002less than\002,f8.2,/)";
static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
"rors\002)";
static char fmt_9991[] = "(\002 Relative machine \002,a,\002 is taken to"
" be\002,d16.6)";
static char fmt_9998[] = "(/\002 End of tests\002)";
static char fmt_9997[] = "(\002 Total time used = \002,f12.2,\002 seco"
"nds\002,/)";
/* System generated locals */
integer i__1;
doublereal d__1;
cllist cl__1;
/* Builtin functions */
integer s_rsle(cilist *), e_rsle(void), s_wsfe(cilist *), do_fio(integer *
, char *, ftnlen), e_wsfe(void), do_lio(integer *, integer *,
char *, ftnlen);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsle(cilist *), e_wsle(void), f_clos(cllist *);
/* Local variables */
doublereal workafac[2500] /* was [50][50] */, workasav[2500] /*
was [50][50] */, workbsav[800] /* was [50][16] */, workainv[
2500] /* was [50][50] */, workxact[800] /* was [50][
16] */;
integer i__;
doublereal s1, s2;
integer nn, vers_patch__, vers_major__, vers_minor__;
doublereal workarfinv[1275], eps;
integer nns, nnt, nval[12];
doublereal d_temp_dpot02__[800] /* was [50][16] */, d_temp_dpot03__[
2500] /* was [50][50] */, d_work_dpot01__[50],
d_work_dpot02__[50], d_work_dpot03__[50];
logical fatal;
integer nsval[12], ntval[9];
doublereal worka[2500] /* was [50][50] */, workb[800] /* was [50][
16] */, workx[800] /* was [50][16] */, d_work_dlatms__[150],
d_work_dlansy__[50];
extern doublereal dlamch_(char *), dsecnd_(void);
extern /* Subroutine */ int ilaver_(integer *, integer *, integer *);
doublereal thresh, workap[1275];
logical tsterr;
extern /* Subroutine */ int ddrvrf1_(integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *)
, ddrvrf2_(integer *, integer *, integer *, doublereal *, integer
*, doublereal *, doublereal *, doublereal *), ddrvrf3_(integer *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), ddrvrf4_(integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *), derrrfp_(
integer *), ddrvrfp_(integer *, integer *, integer *, integer *,
integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
doublereal workarf[1275];
/* Fortran I/O blocks */
static cilist io___3 = { 0, 5, 0, 0, 0 };
static cilist io___7 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___8 = { 0, 5, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___11 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___12 = { 0, 5, 0, 0, 0 };
static cilist io___15 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___16 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___17 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___18 = { 0, 5, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___21 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___22 = { 0, 5, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___25 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___26 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___27 = { 0, 5, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___30 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___31 = { 0, 5, 0, 0, 0 };
static cilist io___33 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___34 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___35 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___36 = { 0, 5, 0, 0, 0 };
static cilist io___38 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___39 = { 0, 5, 0, 0, 0 };
static cilist io___41 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___45 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___46 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___47 = { 0, 6, 0, 0, 0 };
static cilist io___67 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2008 */
/* Purpose */
/* ======= */
/* DCHKRFP is the main test program for the DOUBLE PRECISION linear */
/* equation routines with RFP storage format */
/* Internal Parameters */
/* =================== */
/* MAXIN INTEGER */
/* The number of different values that can be used for each of */
/* M, N, or NB */
/* MAXRHS INTEGER */
/* The maximum number of right hand sides */
/* NTYPES INTEGER */
/* NMAX INTEGER */
/* The maximum allowable value for N. */
/* NIN INTEGER */
/* The unit number for input */
/* NOUT INTEGER */
/* The unit number for output */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Executable Statements .. */
s1 = dsecnd_();
fatal = FALSE_;
/* Read a dummy line. */
s_rsle(&io___3);
e_rsle();
/* Report LAPACK version tag (e.g. LAPACK-3.2.0) */
ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
s_wsfe(&io___7);
do_fio(&c__1, (char *)&vers_major__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&vers_minor__, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&vers_patch__, (ftnlen)sizeof(integer));
e_wsfe();
/* Read the values of N */
s_rsle(&io___8);
do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
e_rsle();
if (nn < 1) {
s_wsfe(&io___10);
do_fio(&c__1, " NN ", (ftnlen)4);
do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nn = 0;
fatal = TRUE_;
} else if (nn > 12) {
s_wsfe(&io___11);
do_fio(&c__1, " NN ", (ftnlen)4);
do_fio(&c__1, (char *)&nn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nn = 0;
fatal = TRUE_;
}
s_rsle(&io___12);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nval[i__ - 1] < 0) {
s_wsfe(&io___15);
do_fio(&c__1, " M ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (nval[i__ - 1] > 50) {
s_wsfe(&io___16);
do_fio(&c__1, " M ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__50, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L10: */
}
if (nn > 0) {
s_wsfe(&io___17);
do_fio(&c__1, "N ", (ftnlen)4);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the values of NRHS */
s_rsle(&io___18);
do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
e_rsle();
if (nns < 1) {
s_wsfe(&io___20);
do_fio(&c__1, " NNS", (ftnlen)4);
do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nns = 0;
fatal = TRUE_;
} else if (nns > 12) {
s_wsfe(&io___21);
do_fio(&c__1, " NNS", (ftnlen)4);
do_fio(&c__1, (char *)&nns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nns = 0;
fatal = TRUE_;
}
s_rsle(&io___22);
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nsval[i__ - 1] < 0) {
s_wsfe(&io___24);
do_fio(&c__1, "NRHS", (ftnlen)4);
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (nsval[i__ - 1] > 16) {
s_wsfe(&io___25);
do_fio(&c__1, "NRHS", (ftnlen)4);
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__16, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L30: */
}
if (nns > 0) {
s_wsfe(&io___26);
do_fio(&c__1, "NRHS", (ftnlen)4);
i__1 = nns;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the matrix types */
s_rsle(&io___27);
do_lio(&c__3, &c__1, (char *)&nnt, (ftnlen)sizeof(integer));
e_rsle();
if (nnt < 1) {
s_wsfe(&io___29);
do_fio(&c__1, " NMA", (ftnlen)4);
do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nnt = 0;
fatal = TRUE_;
} else if (nnt > 9) {
s_wsfe(&io___30);
do_fio(&c__1, " NMA", (ftnlen)4);
do_fio(&c__1, (char *)&nnt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
e_wsfe();
nnt = 0;
fatal = TRUE_;
}
s_rsle(&io___31);
i__1 = nnt;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nnt;
for (i__ = 1; i__ <= i__1; ++i__) {
if (ntval[i__ - 1] < 0) {
s_wsfe(&io___33);
do_fio(&c__1, "TYPE", (ftnlen)4);
do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (ntval[i__ - 1] > 9) {
s_wsfe(&io___34);
do_fio(&c__1, "TYPE", (ftnlen)4);
do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__9, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L320: */
}
if (nnt > 0) {
s_wsfe(&io___35);
do_fio(&c__1, "TYPE", (ftnlen)4);
i__1 = nnt;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&ntval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read the threshold value for the test ratios. */
s_rsle(&io___36);
do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_rsle();
s_wsfe(&io___38);
do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_wsfe();
/* Read the flag that indicates whether to test the error exits. */
s_rsle(&io___39);
do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
e_rsle();
if (fatal) {
s_wsfe(&io___41);
e_wsfe();
s_stop("", (ftnlen)0);
}
if (fatal) {
s_wsfe(&io___42);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* Calculate and print the machine dependent constants. */
eps = dlamch_("Underflow threshold");
s_wsfe(&io___44);
do_fio(&c__1, "underflow", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Overflow threshold");
s_wsfe(&io___45);
do_fio(&c__1, "overflow ", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Epsilon");
s_wsfe(&io___46);
do_fio(&c__1, "precision", (ftnlen)9);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
s_wsle(&io___47);
e_wsle();
/* Test the error exit of: */
if (tsterr) {
derrrfp_(&c__6);
}
/* Test the routines: dpftrf, dpftri, dpftrs (as in DDRVPO). */
/* This also tests the routines: dtfsm, dtftri, dtfttr, dtrttf. */
ddrvrfp_(&c__6, &nn, nval, &nns, nsval, &nnt, ntval, &thresh, worka,
workasav, workafac, workainv, workb, workbsav, workxact, workx,
workarf, workarfinv, d_work_dlatms__, d_work_dpot01__,
d_temp_dpot02__, d_temp_dpot03__, d_work_dlansy__,
d_work_dpot02__, d_work_dpot03__);
/* Test the routine: dlansf */
ddrvrf1_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf,
d_work_dlansy__);
/* Test the convertion routines: */
/* dtfttp, dtpttf, dtfttr, dtrttf, dtrttp and dtpttr. */
ddrvrf2_(&c__6, &nn, nval, worka, &c__50, workarf, workap, workasav);
/* Test the routine: dtfsm */
ddrvrf3_(&c__6, &nn, nval, &thresh, worka, &c__50, workarf, workainv,
workafac, d_work_dlansy__, d_work_dpot03__, d_work_dpot01__);
/* Test the routine: dsfrk */
ddrvrf4_(&c__6, &nn, nval, &thresh, worka, workafac, &c__50, workarf,
workainv, &c__50, d_work_dlansy__);
cl__1.cerr = 0;
cl__1.cunit = 5;
cl__1.csta = 0;
f_clos(&cl__1);
s2 = dsecnd_();
s_wsfe(&io___67);
e_wsfe();
s_wsfe(&io___68);
d__1 = s2 - s1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
/* End of DCHKRFP */
return 0;
} /* MAIN__ */
/* $Procedure SUMCK ( Summarize a CK file ) */
/* Subroutine */ int sumck_(integer *handle, char *binfnm, char *lpsfnm, char
*sclfnm, logical *logfil, integer *loglun, ftnlen binfnm_len, ftnlen
lpsfnm_len, ftnlen sclfnm_len)
{
/* Initialized data */
static char menutl[20] = "CK Summary Options ";
static char menuvl[20*6] = "QUIT " "Skip "
"ENTIRE_FILE " "BY_INSTRUMENT_ID " "BY_UTC_INTERVAL "
" " "BY_SCLK_INTERVAL ";
static char menutx[40*6] = "Quit, returning to main menu. "
"Skip " "Summarize entire fil"
"e. " "Summarize by NAIF instrument ID code. "
"Summarize by UTC time interval. " "Summarize by SCLK ti"
"me interval. ";
static char menunm[1*6] = "Q" "." "F" "I" "U" "S";
/* System generated locals */
integer i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rnge(char *, integer, char *, integer), s_cmp(char *, char *,
ftnlen, ftnlen), s_wsle(cilist *), e_wsle(void), do_lio(integer *,
integer *, char *, ftnlen);
/* Local variables */
static logical done;
static char line[255];
extern /* Subroutine */ int sct2e_(integer *, doublereal *, doublereal *);
extern integer cardd_(doublereal *);
static doublereal beget;
static char segid[40];
extern /* Subroutine */ int chkin_(char *, ftnlen);
static char bsclk[32];
static doublereal endet;
static char esclk[32];
extern /* Subroutine */ int repmc_(char *, char *, char *, char *, ftnlen,
ftnlen, ftnlen, ftnlen);
static char separ[80];
static logical found;
extern /* Subroutine */ int repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen), ckgss_(char *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, ftnlen), reset_(void);
static logical error;
extern /* Subroutine */ int ckwss_(integer *, char *, integer *, integer *
, integer *, integer *, doublereal *, doublereal *, ftnlen);
extern integer rtrim_(char *, ftnlen);
extern /* Subroutine */ int utc2et_(char *, doublereal *, ftnlen),
et2utc_(doublereal *, char *, integer *, char *, ftnlen, ftnlen),
daffna_(logical *);
extern logical failed_(void);
static integer segbad;
extern /* Subroutine */ int scdecd_(integer *, doublereal *, char *,
ftnlen), dafbfs_(integer *);
static integer segead;
static doublereal begscl;
extern /* Subroutine */ int scardd_(integer *, doublereal *), scencd_(
integer *, char *, doublereal *, ftnlen);
static logical segfnd;
static doublereal endscl;
static char begutc[32];
extern /* Subroutine */ int cnfirm_(char *, logical *, ftnlen), getchr_(
char *, char *, logical *, logical *, char *, ftnlen, ftnlen,
ftnlen);
static logical haveit;
static char endutc[32];
static integer segfrm;
static doublereal segbtm, segetm;
static integer instid, segins;
static doublereal segint[8];
static logical anyseg;
extern /* Subroutine */ int getint_(char *, integer *, logical *, logical
*, char *, ftnlen, ftnlen);
static char errmsg[320], option[20], sumsep[80];
extern logical return_(void);
static char fnmout[255], sclout[255];
static integer missin;
static char lpsout[255];
static integer menuop, segrts;
static char tmpstr[80];
static integer segtyp;
static doublereal intrvl[8], intsct[8];
static logical contnu, tryagn;
extern /* Subroutine */ int ssized_(integer *, doublereal *), writln_(
char *, integer *, ftnlen), getopt_(char *, integer *, char *,
char *, integer *, ftnlen, ftnlen, ftnlen), wninsd_(doublereal *,
doublereal *, doublereal *), wnintd_(doublereal *, doublereal *,
doublereal *);
static char typout[255];
extern /* Subroutine */ int chkout_(char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___23 = { 0, 6, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, 0, 0 };
static cilist io___25 = { 0, 6, 0, 0, 0 };
static cilist io___26 = { 0, 6, 0, 0, 0 };
static cilist io___27 = { 0, 6, 0, 0, 0 };
static cilist io___28 = { 0, 6, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, 0, 0 };
static cilist io___30 = { 0, 6, 0, 0, 0 };
static cilist io___32 = { 0, 6, 0, 0, 0 };
static cilist io___33 = { 0, 6, 0, 0, 0 };
static cilist io___34 = { 0, 6, 0, 0, 0 };
static cilist io___36 = { 0, 6, 0, 0, 0 };
static cilist io___37 = { 0, 6, 0, 0, 0 };
static cilist io___38 = { 0, 6, 0, 0, 0 };
static cilist io___39 = { 0, 6, 0, 0, 0 };
static cilist io___41 = { 0, 6, 0, 0, 0 };
static cilist io___42 = { 0, 6, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, 0, 0 };
static cilist io___44 = { 0, 6, 0, 0, 0 };
static cilist io___46 = { 0, 6, 0, 0, 0 };
static cilist io___47 = { 0, 6, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, 0, 0 };
static cilist io___49 = { 0, 6, 0, 0, 0 };
static cilist io___51 = { 0, 6, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, 0, 0 };
static cilist io___53 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, 0, 0 };
static cilist io___58 = { 0, 6, 0, 0, 0 };
static cilist io___59 = { 0, 6, 0, 0, 0 };
static cilist io___60 = { 0, 6, 0, 0, 0 };
static cilist io___61 = { 0, 6, 0, 0, 0 };
static cilist io___62 = { 0, 6, 0, 0, 0 };
static cilist io___63 = { 0, 6, 0, 0, 0 };
static cilist io___65 = { 0, 6, 0, 0, 0 };
static cilist io___66 = { 0, 6, 0, 0, 0 };
static cilist io___67 = { 0, 6, 0, 0, 0 };
static cilist io___68 = { 0, 6, 0, 0, 0 };
static cilist io___70 = { 0, 6, 0, 0, 0 };
static cilist io___71 = { 0, 6, 0, 0, 0 };
static cilist io___72 = { 0, 6, 0, 0, 0 };
static cilist io___73 = { 0, 6, 0, 0, 0 };
static cilist io___75 = { 0, 6, 0, 0, 0 };
static cilist io___76 = { 0, 6, 0, 0, 0 };
static cilist io___77 = { 0, 6, 0, 0, 0 };
static cilist io___78 = { 0, 6, 0, 0, 0 };
static cilist io___80 = { 0, 6, 0, 0, 0 };
/* $ Abstract */
/* Summarize a CK file. */
/* $ Disclaimer */
/* THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/* CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/* GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/* ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/* PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/* TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/* WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/* PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/* SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/* SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */
/* IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/* BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/* LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/* INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/* REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/* REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */
/* RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/* THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/* CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/* ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */
/* $ Declarations */
/* Set the number of double precision components in an unpacked CK */
/* descriptor. */
/* Set the number of integer components in an unpacked CK descriptor. */
/* Set the size of a packed CK descriptor. */
/* Set the length of a CK segment identifier. */
/* Set the value for the lower bound of the CELL data type. */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* HANDLE I Handle of the SPK file to be summarized. */
/* LOGFIL I Write the summary to a log file and to screen? */
/* LOGLUN I Logical unit connected to the log file. */
/* NDC P Number of d.p. components in SPK descriptor. */
/* NIC P Number of integer components in SPK descriptor. */
/* NC P Size of packed SPK descriptor. */
/* IDSIZ P Length of SPK segment identifier. */
/* LBCELL P Lower bound for the SPICELIB CELL data structure. */
/* $ Detailed_Input */
/* HANDLE is the integer handle of the CK file to be summarized. */
/* LOGFIL if TRUE means that the summary will be written to */
/* a log file as well as displayed on the terminal */
/* screen. Otherwise, the summary will not be written */
/* to a log file. */
/* LOGLUN is the logical unit connected to a log file to which */
/* the summary is to be written if LOGFIL is TRUE. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* NDC is the number of double precision components in an */
/* unpacked SPK descriptor. */
/* NIC is the number of integer components in an unpacked */
/* SPK descriptor. */
/* NC is the size of a packed SPK descriptor. */
/* IDSIZ is the length of an SPK segment identifier. */
/* LBCELL is the lower bound for the SPICELIB CELL data */
/* structure. */
/* $ Exceptions */
/* None. */
/* $ Files */
/* The CK file to be summarized is referred throughout this routine */
/* by its handle. The file should already be opened for read. */
/* $ Particulars */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* M.J. Spencer (JPL) */
/* J.E. McLean (JPL) */
/* R.E. Thurman (JPL) */
/* $ Version */
/* - Beta Version 5.0.0 21-JUL-1995 (KRG) */
/* Added several arguments to the call of this subroutine and */
/* made other modifications to allow it to perform its own */
/* formatting of the summary, including filenames and separators. */
/* - Beta Version 4.0.0 11-APR-1994 (KRG) */
/* Modified this routine to make use of new routines to get and */
/* format and write CK segment summaries. */
/* Added a missing $ Index_Entries header section. */
/* Fixed a few typos in the header. */
/* The routine DISPC is now obsolete. It is no longer used. */
/* - Beta Version 3.0.0 22-MAR-1993 (KRG) */
/* 1) Changed the names of the variables TOFILE and UNIT to LOGFIL */
/* and LOGLUN, respectively. */
/* 2) Updated the program to use the menuing subroutine GETOPT */
/* which removes the need for the routine QSUMC. Redesigned */
/* the case sructure of the code to facilitate the use of the */
/* menuing routine. */
/* 3) Rearranged some of thee initializations that were performed, */
/* moved several calls to SCARDD outside the main loop, etc. */
/* 5) Performed some general cleanup as deemed necessary. */
/* - Beta Version 2.1.0 20-NOV-1991 (MJS) */
/* Checked FAILED function in main loop. */
/* - Beta Version 2.0.0 17-JUN-1991 (JEM) */
/* 1. Added the arguments TOFILE and UNIT. Previously the */
/* summary was only displayed on the terminal screen. */
/* Now, if requested by TOFILE, the summary is also */
/* written to the file connected to UNIT. */
/* 2. A user may cancel a task selected in QSUMC and */
/* select another. */
/* - SPICELIB Version 1.1.0 31-AUG-1990 (JEM) */
/* This routine was updated due to changes in the CK and */
/* SCLK design. Also, several implementation-specific */
/* parameters were moved from the header to the local */
/* parameters section. */
/* - SPICELIB Version 1.0.0, 31-JAN-1990 (RET) */
/* -& */
/* $ Index_Entries */
/* summarize the segments in a binary ck file */
/* -& */
/* $ Revisions */
/* - Beta Version 5.0.0 21-JUL-1995 (KRG) */
/* Added several arguments to the call of this subroutine and */
/* made other modifications to allow it to perform its own */
/* formatting of the summary, including filenames and separators. */
/* - Beta Version 4.0.0 11-APR-1994 (KRG) */
/* Modified this routine to make use of new routines to get and */
/* format and write CK segment summaries. */
/* Added a missing $ Index_Entries header section. */
/* Fixed a few typos in the header. */
/* The routine DISPC is now obsolete. It is no longer used. */
/* - Beta Version 3.0.0 22-MAR-1993 (KRG) */
/* 1) Changed the names of the variables TOFILE and UNIT to LOGFIL */
/* and LOGLUN, respectively. */
/* 2) Updated the program to use the menuing subroutine GETOPT */
/* which removes the need for the routine QSUMC. Redesigned */
/* the case sructure of the code to facilitate the use of the */
/* menuing routine. */
/* 3) Rearranged some of thee initializations that were performed, */
/* moved several calls to SCARDD outside the main loop, etc. */
/* 5) Performed some general cleanup as deemed necessary. */
/* - Beta Version 2.1.0 20-NOV-1991 (MJS) */
/* Checked FAILED function in main loop. In the previous version, */
/* if any time conversion produced an error, the summary would go */
/* in an endless loop. */
/* - Beta Version 2.0.0 22-MAY-1991 (JEM) */
/* 1. In addition to adding the arguments TOFILE and UNIT to */
/* the calling sequence, the following code changes were */
/* made. The two new arguments were added to the calling */
/* sequence of DISPC as well. If TOFILE is true, a */
/* description of the type of summary is written to the */
/* output file before calling DISPC to write the summary. */
/* If no segments are found, the message is written to the */
/* output file as well as the terminal screen when */
/* TOFILE is true. */
/* 2. QSUMC was changed. 'NONE' is now a possible task */
/* returned from QSUMC and means a task was selected, */
/* then cancelled. QSUMC is called repeatedly until the */
/* task returned is something other than NONE. In */
/* this way the user is able to select another task. */
/* - SPICELIB Version 1.1.0 31-AUG-1990 (JEM) */
/* This routine was updated to handle these changes to the */
/* C-kernel design: */
/* 1. Ephemeris time is no longer included in CK files. */
/* All data is associated with spacecraft clock time only. */
/* The segment descriptor no longer contains the */
/* start and stop ET. Thus, the number of double */
/* precision components (NDC) is now two instead of four. */
/* 2. Segments may now contain rate information, along with */
/* pointing data. The segment descriptor contains a flag */
/* that indicates whether or not the segment includes */
/* rate information. Thus, the number of integer */
/* components (NIC) is now six instead of five. */
/* This version of SUMCK converts encoded SCLK times to ET for */
/* comparison with input times which are converted from UTC to ET. */
/* This routine was also updated to handle these changes to the */
/* SCLK design: */
/* 1. The name of the routine that encodes spacecraft */
/* clock time was changed from ENSCLK to SCENCD, and */
/* the order of arguments in the calling sequence */
/* was changed. */
/* 2. Instrument ID codes are now negative integers to */
/* avoid conflict with other body id codes. */
/* The parameters that pertain to the CK file architecture, */
/* like the number of double precision components in the */
/* segment descriptor (NDC), were moved from the header */
/* to the local parameter section. These parameters are */
/* implementation specific. Further, the user is not invited */
/* to change them, nor are they needed in any argument */
/* declaration. Thus they do not belong in the header. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set value for a separator */
/* Set up the instrument ID code prompt. */
/* Set up the spacecraft ID code prompt. */
/* Set up the SCLK time string prompt. */
/* Set up labels for various output things. */
/* Set up the UTC time string prompt. */
/* Set the length for a line of text. */
/* Set the length for an output line. */
/* Set the length for an error message. */
/* Set the length for a UTC time string. */
/* Set the precision for the fractional part of UTC times. */
/* Set a length for the option values. */
/* Set a length for the title of a menu. */
/* Set the length of the text description of an option on a menu. */
/* The number of options available on the main menu. */
/* Parameter for the standard output unit. */
/* Local variables */
/* Save everything to keep control happy. */
/* Initial Values */
/* Define the menu title ... */
/* Define the menu option values ... */
/* Define the menu descriptive text for each option ... */
/* Define the menu option names ... */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SUMCK", (ftnlen)5);
}
/* Initialize the separator. */
s_copy(separ, "*********************************************************"
"***********************", (ftnlen)80, (ftnlen)80);
/* Initialize the segment separator. */
s_copy(sumsep, "--------------------------------------------------------"
"------------------------", (ftnlen)80, (ftnlen)80);
/* Set the sizes of the window cells that we will use if the file */
/* is to be summarized by time. */
ssized_(&c__2, intrvl);
ssized_(&c__2, segint);
ssized_(&c__2, intsct);
/* Initialize a few things before we start. */
instid = 0;
done = FALSE_;
while(! done) {
/* Initialize those things we reuse on every iteration. */
contnu = TRUE_;
writln_(" ", &c__6, (ftnlen)1);
getopt_(menutl, &c__6, menunm, menutx, &menuop, (ftnlen)20, (ftnlen)1,
(ftnlen)40);
if (failed_()) {
contnu = FALSE_;
}
if (contnu) {
/* Perform all of the setup necessary to perform the summary. */
/* This include prompting for input values required, etc. */
repmc_("Summary for CK file: #", "#", binfnm, fnmout, (ftnlen)22,
(ftnlen)1, binfnm_len, (ftnlen)255);
repmc_("Leapseconds File : #", "#", lpsfnm, lpsout, (ftnlen)22,
(ftnlen)1, lpsfnm_len, (ftnlen)255);
repmc_("SCLK File : #", "#", sclfnm, sclout, (ftnlen)22,
(ftnlen)1, sclfnm_len, (ftnlen)255);
s_copy(option, menuvl + ((i__1 = menuop - 1) < 6 && 0 <= i__1 ?
i__1 : s_rnge("menuvl", i__1, "sumck_", (ftnlen)553)) *
20, (ftnlen)20, (ftnlen)20);
if (s_cmp(option, "QUIT", (ftnlen)20, (ftnlen)4) == 0) {
contnu = FALSE_;
done = TRUE_;
} else if (s_cmp(option, "ENTIRE_FILE", (ftnlen)20, (ftnlen)11) ==
0) {
/* Summarize the entire file. */
repmc_("Summary Type : #", "#", "Entire File", typout, (
ftnlen)22, (ftnlen)1, (ftnlen)11, (ftnlen)255);
} else if (s_cmp(option, "BY_INSTRUMENT_ID", (ftnlen)20, (ftnlen)
16) == 0) {
/* Summarize for a specified body. */
/* First, we need to get the instrument ID code. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___23);
e_wsle();
s_wsle(&io___24);
do_lio(&c__9, &c__1, "Enter the desired NAIF instrument "
"code.", (ftnlen)39);
e_wsle();
s_wsle(&io___25);
e_wsle();
getint_("Instrument ID code? ", &instid, &haveit, &error,
errmsg, (ftnlen)20, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___26);
e_wsle();
s_wsle(&io___27);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___28);
e_wsle();
s_wsle(&io___29);
do_lio(&c__9, &c__1, "A NAIF instrument ID code "
"must be entered for this option.", (
ftnlen)58);
e_wsle();
}
if (! haveit || error) {
s_wsle(&io___30);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
} else {
tryagn = FALSE_;
}
}
/* Write the type of summary to the log file if we need to. */
if (contnu) {
s_copy(tmpstr, "By Instrument ID #", (ftnlen)80, (ftnlen)
18);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmi_(typout, "#", &instid, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)255);
}
} else if (s_cmp(option, "BY_UTC_INTERVAL", (ftnlen)20, (ftnlen)
15) == 0) {
/* Summarize for given UTC time interval. */
/* First, we need to get the UTC time string for the */
/* begin time. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___32);
e_wsle();
s_wsle(&io___33);
do_lio(&c__9, &c__1, "Enter the desired beginning UTC ti"
"me.", (ftnlen)37);
e_wsle();
s_wsle(&io___34);
e_wsle();
getchr_("UTC time? ", begutc, &haveit, &error, errmsg, (
ftnlen)10, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___36);
e_wsle();
s_wsle(&io___37);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___38);
e_wsle();
s_wsle(&io___39);
do_lio(&c__9, &c__1, "A beginning UTC time strin"
"g must be entered for this option.", (
ftnlen)60);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the beginning time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so that */
/* we can continue processing. Remember, we are in a */
/* menuing subroutine, and we are not allowed to exit */
/* on an error: we must go back to the menu. thus the */
/* need for a resetting of the error handler here. If */
/* we got to here, there were no errors, so as long as */
/* we maintain that status, everything will be hunky */
/* dory. We also convert the ET back into UTC to get */
/* a consistent format for display. */
if (haveit) {
utc2et_(begutc, &beget, (ftnlen)32);
et2utc_(&beget, "C", &c__3, begutc, (ftnlen)1, (
ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___41);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)20);
if (! tryagn) {
contnu = FALSE_;
}
}
}
/* Now, if we can, we need to get the UTC time string for */
/* the end time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___42);
e_wsle();
s_wsle(&io___43);
do_lio(&c__9, &c__1, "Enter the desired ending UTC t"
"ime.", (ftnlen)34);
e_wsle();
s_wsle(&io___44);
e_wsle();
getchr_("UTC time? ", endutc, &haveit, &error, errmsg,
(ftnlen)10, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___46);
e_wsle();
s_wsle(&io___47);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___48);
e_wsle();
s_wsle(&io___49);
do_lio(&c__9, &c__1, "An ending UTC time str"
"ing must be entered for this option.",
(ftnlen)58);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the ending time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed */
/* to exit on an error: we must go back to the menu. */
/* thus the need for a resetting of the error handler */
/* here. If we got to here, there were no errors, so */
/* as long as we maintain that status, everything */
/* will be hunky dory. We also convert the ET back */
/* into UTC to get a consistent format for display. */
if (haveit) {
utc2et_(endutc, &endet, (ftnlen)32);
et2utc_(&endet, "C", &c__3, endutc, (ftnlen)1, (
ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___51);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
} else {
tryagn = FALSE_;
}
}
}
/* Create an interval out of the begin and end ET times, */
/* if we can. */
if (contnu) {
scardd_(&c__0, intrvl);
wninsd_(&beget, &endet, intrvl);
if (failed_()) {
contnu = FALSE_;
}
}
/* Write the type of summary to the output file, if we can. */
if (contnu) {
s_copy(tmpstr, "By # Time Interval #", (ftnlen)80, (
ftnlen)20);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmc_(typout, "#", "UTC", typout, (ftnlen)255, (ftnlen)1,
(ftnlen)3, (ftnlen)255);
repmc_(typout, "#", "(#, #)", typout, (ftnlen)255, (
ftnlen)1, (ftnlen)6, (ftnlen)255);
repmc_(typout, "#", begutc, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)32, (ftnlen)255);
repmc_(typout, "#", endutc, typout, (ftnlen)255, (ftnlen)
1, (ftnlen)32, (ftnlen)255);
}
} else if (s_cmp(option, "BY_SCLK_INTERVAL", (ftnlen)20, (ftnlen)
16) == 0) {
/* Summarize for given SCLK time interval. */
/* First, we need to get spacecraft ID code. */
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___52);
e_wsle();
s_wsle(&io___53);
do_lio(&c__9, &c__1, "Enter the desired NAIF spacecraft "
"ID code.", (ftnlen)42);
e_wsle();
s_wsle(&io___54);
e_wsle();
getint_("Spacecraft ID code? ", &missin, &haveit, &error,
errmsg, (ftnlen)20, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___56);
e_wsle();
s_wsle(&io___57);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___58);
e_wsle();
s_wsle(&io___59);
do_lio(&c__9, &c__1, "A NAIF spacecraft ID code "
"must be entered for this option.", (
ftnlen)58);
e_wsle();
}
if (! haveit || error) {
s_wsle(&io___60);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
} else {
tryagn = FALSE_;
}
}
/* Now, we need to get the SCLK time string for the */
/* begin time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___61);
e_wsle();
s_wsle(&io___62);
do_lio(&c__9, &c__1, "Enter the desired beginning SC"
"LK time.", (ftnlen)38);
e_wsle();
s_wsle(&io___63);
e_wsle();
getchr_("SCLK time? ", bsclk, &haveit, &error, errmsg,
(ftnlen)11, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___65);
e_wsle();
s_wsle(&io___66);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___67);
e_wsle();
s_wsle(&io___68);
do_lio(&c__9, &c__1, "A beginning SCLK time "
"string must be entered for this opti"
"on.", (ftnlen)61);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the beginning time in SCLK, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed to */
/* exit on an error: we must go back to the menu. thus */
/* the need for a resetting of the error handler here. */
/* If we got to here, there were no errors, so as long */
/* as we maintain that status, everything will be */
/* hunky dory. We also convert the ET back into SCLK, */
/* and UTC to get a consistent format for display. */
if (haveit) {
scencd_(&missin, bsclk, &begscl, (ftnlen)32);
sct2e_(&missin, &begscl, &beget);
et2utc_(&beget, "C", &c__3, begutc, (ftnlen)1, (
ftnlen)32);
scdecd_(&missin, &begscl, bsclk, (ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* beginning UTC time string again. */
if (! haveit || error) {
s_wsle(&io___70);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
}
}
}
/* Now, if we can, we need to get the UTC time string for */
/* the end time. */
if (contnu) {
s_copy(errmsg, " ", (ftnlen)320, (ftnlen)1);
haveit = FALSE_;
tryagn = TRUE_;
while(tryagn) {
error = FALSE_;
s_wsle(&io___71);
e_wsle();
s_wsle(&io___72);
do_lio(&c__9, &c__1, "Enter the desired ending SCLK "
"time.", (ftnlen)35);
e_wsle();
s_wsle(&io___73);
e_wsle();
getchr_("SCLK time? ", esclk, &haveit, &error, errmsg,
(ftnlen)11, (ftnlen)32, (ftnlen)320);
if (! haveit || error) {
if (error) {
s_wsle(&io___75);
e_wsle();
s_wsle(&io___76);
do_lio(&c__9, &c__1, errmsg, rtrim_(errmsg, (
ftnlen)320));
e_wsle();
}
if (! haveit) {
s_wsle(&io___77);
e_wsle();
s_wsle(&io___78);
do_lio(&c__9, &c__1, "An ending SCLK time st"
"ring must be entered for this option."
, (ftnlen)59);
e_wsle();
}
} else {
tryagn = FALSE_;
}
/* We now have the ending time in UTC, so attempt */
/* to convert it to ET. If the conversion fails, we */
/* need to immediately reset the error handling so */
/* that we can continue processing. Remember, we are */
/* in a menuing subroutine, and we are not allowed */
/* to exit on an error: we must go back to the menu. */
/* thus the need for a resetting of the error handler */
/* here. If we got to here, there were no errors, so */
/* as long as we maintain that status, everything */
/* will be hunky dory. We also convert the ET back */
/* into UTC to get a consistent format for display. */
if (haveit) {
scencd_(&missin, esclk, &endscl, (ftnlen)32);
sct2e_(&missin, &endscl, &endet);
et2utc_(&endet, "C", &c__3, endutc, (ftnlen)1, (
ftnlen)32);
scdecd_(&missin, &endscl, esclk, (ftnlen)32);
if (failed_()) {
reset_();
error = TRUE_;
}
}
/* Check to see if they want to try and enter the */
/* ending SCLK time string again. */
if (! haveit || error) {
s_wsle(&io___80);
e_wsle();
cnfirm_("Try Again? (Yes/No) ", &tryagn, (ftnlen)
20);
if (! tryagn) {
contnu = FALSE_;
}
} else {
tryagn = FALSE_;
}
}
}
/* Create an interval out of the begin and end ET times, */
/* if we can. */
if (contnu) {
scardd_(&c__0, intrvl);
wninsd_(&beget, &endet, intrvl);
if (failed_()) {
contnu = FALSE_;
}
}
/* Write the type of summary to the output file, if we can. */
if (contnu) {
s_copy(tmpstr, "By # Time Interval #", (ftnlen)80, (
ftnlen)20);
repmc_("Summary Type : #", "#", tmpstr, typout, (
ftnlen)22, (ftnlen)1, (ftnlen)80, (ftnlen)255);
repmc_(typout, "#", "SCLK", typout, (ftnlen)255, (ftnlen)
1, (ftnlen)4, (ftnlen)255);
repmc_(typout, "#", "(#, #)", typout, (ftnlen)255, (
ftnlen)1, (ftnlen)6, (ftnlen)255);
repmc_(typout, "#", bsclk, typout, (ftnlen)255, (ftnlen)1,
(ftnlen)32, (ftnlen)255);
repmc_(typout, "#", esclk, typout, (ftnlen)255, (ftnlen)1,
(ftnlen)32, (ftnlen)255);
}
}
/* Now, if we can, search through the file from the beginning. */
/* Keep track of whether or not any segments satisfy the search */
/* criteria. */
if (contnu) {
writln_(" ", &c__6, (ftnlen)1);
writln_(separ, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
writln_(fnmout, &c__6, (ftnlen)255);
writln_(lpsout, &c__6, (ftnlen)255);
writln_(sclout, &c__6, (ftnlen)255);
writln_(typout, &c__6, (ftnlen)255);
writln_(" ", &c__6, (ftnlen)1);
if (*logfil) {
writln_(" ", loglun, (ftnlen)1);
writln_(separ, loglun, (ftnlen)80);
writln_(" ", loglun, (ftnlen)1);
writln_(fnmout, loglun, (ftnlen)255);
writln_(lpsout, loglun, (ftnlen)255);
writln_(sclout, loglun, (ftnlen)255);
writln_(typout, loglun, (ftnlen)255);
writln_(" ", loglun, (ftnlen)1);
}
anyseg = FALSE_;
dafbfs_(handle);
daffna_(&found);
while(found && contnu) {
/* On each iteration of the loop, we have not found */
/* anything initially. */
segfnd = FALSE_;
scardd_(&c__0, intsct);
scardd_(&c__0, segint);
/* Get the descriptor of the segment. */
ckgss_(segid, &segins, &segfrm, &segtyp, &segrts, &segbtm,
&segetm, &segbad, &segead, (ftnlen)40);
/* Check to see if the current segment satisfies the */
/* current search criteria. */
if (s_cmp(option, "ENTIRE_FILE", (ftnlen)20, (ftnlen)11)
== 0) {
segfnd = TRUE_;
} else if (s_cmp(option, "BY_INSTRUMENT_ID", (ftnlen)20, (
ftnlen)16) == 0) {
segfnd = instid == segins;
} else if (s_cmp(option, "BY_UTC_INTERVAL", (ftnlen)20, (
ftnlen)15) == 0) {
/* Create an interval out of the epochs in the */
/* segment. */
missin = segins / 1000;
sct2e_(&missin, &segbtm, &beget);
sct2e_(&missin, &segetm, &endet);
wninsd_(&beget, &endet, segint);
/* Intersect it with the input interval. */
wnintd_(segint, intrvl, intsct);
if (failed_()) {
reset_();
contnu = FALSE_;
} else {
segfnd = cardd_(intsct) > 0;
}
} else if (s_cmp(option, "BY_SCLK_INTERVAL", (ftnlen)20, (
ftnlen)16) == 0) {
/* Create an interval out of the epochs in the */
/* segment. */
if (missin == segins / 1000) {
sct2e_(&missin, &segbtm, &beget);
sct2e_(&missin, &segetm, &endet);
wninsd_(&beget, &endet, segint);
/* Intersect it with the input interval. */
wnintd_(segint, intrvl, intsct);
if (failed_()) {
reset_();
contnu = FALSE_;
} else {
segfnd = cardd_(intsct) > 0;
}
} else {
segfnd = FALSE_;
}
}
if (contnu && segfnd) {
anyseg = TRUE_;
/* Display the segment summary. */
writln_(sumsep, &c__6, (ftnlen)80);
if (*logfil) {
writln_(sumsep, loglun, (ftnlen)80);
}
ckwss_(&c__6, segid, &segins, &segfrm, &segtyp, &
segrts, &segbtm, &segetm, (ftnlen)40);
if (*logfil) {
ckwss_(loglun, segid, &segins, &segfrm, &segtyp, &
segrts, &segbtm, &segetm, (ftnlen)40);
}
writln_(sumsep, &c__6, (ftnlen)80);
if (*logfil) {
writln_(sumsep, loglun, (ftnlen)80);
}
}
/* Find that next segment. */
daffna_(&found);
if (failed_()) {
contnu = FALSE_;
}
}
}
/* Better say something if no segments were matching the */
/* search criteria were found. */
if (contnu && ! anyseg) {
s_copy(line, "No matching segments were found.", (ftnlen)255,
(ftnlen)32);
writln_(line, &c__6, (ftnlen)255);
if (*logfil) {
writln_(line, loglun, (ftnlen)255);
}
}
if (contnu) {
writln_(" ", &c__6, (ftnlen)1);
writln_(separ, &c__6, (ftnlen)80);
writln_(" ", &c__6, (ftnlen)1);
if (*logfil) {
writln_(" ", loglun, (ftnlen)1);
writln_(separ, loglun, (ftnlen)80);
writln_(" ", loglun, (ftnlen)1);
}
}
}
/* If anything failed, rset the error handling so that we can */
/* redisplay the menu and keep doing things. */
if (failed_()) {
reset_();
}
}
chkout_("SUMCK", (ftnlen)5);
return 0;
} /* sumck_ */
/* Subroutine */ int sdrvsx_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, real *thresh, integer *niunit,
integer *nounit, real *a, integer *lda, real *h__, real *ht, real *wr,
real *wi, real *wrt, real *wit, real *wrtmp, real *witmp, real *vs,
integer *ldvs, real *vs1, real *result, real *work, integer *lwork,
integer *iwork, logical *bwork, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9991[] = "(\002 SDRVSX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9999[] = "(/1x,a3,\002 -- Real Schur Form Decomposition "
"Expert \002,\002Driver\002,/\002 Matrix types (see SDRVSX for de"
"tails):\002)";
static char fmt_9998[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 \002,\002 5=Diagonal: geom"
"etr. spaced entries.\002,/\002 2=Identity matrix. "
" \002,\002 6=Diagona\002,\002l: clustered entries.\002,"
"/\002 3=Transposed Jordan block. \002,\002 \002,\002 "
" 7=Diagonal: large, evenly spaced.\002,/\002 \002,\0024=Diagona"
"l: evenly spaced entries. \002,\002 8=Diagonal: s\002,\002ma"
"ll, evenly spaced.\002)";
static char fmt_9997[] = "(\002 Dense, Non-Symmetric Matrices:\002,/\002"
" 9=Well-cond., ev\002,\002enly spaced eigenvals.\002,\002 14=Il"
"l-cond., geomet. spaced e\002,\002igenals.\002,/\002 10=Well-con"
"d., geom. spaced eigenvals. \002,\002 15=Ill-conditioned, cluste"
"red e.vals.\002,/\002 11=Well-cond\002,\002itioned, clustered e."
"vals. \002,\002 16=Ill-cond., random comp\002,\002lex \002,/\002"
" 12=Well-cond., random complex \002,\002 \002,\002 17=Il"
"l-cond., large rand. complx \002,/\002 13=Ill-condi\002,\002tion"
"ed, evenly spaced. \002,\002 18=Ill-cond., small rand.\002"
",\002 complx \002)";
static char fmt_9996[] = "(\002 19=Matrix with random O(1) entries. "
" \002,\002 21=Matrix \002,\002with small random entries.\002,"
"/\002 20=Matrix with large ran\002,\002dom entries. \002,/)";
static char fmt_9995[] = "(\002 Tests performed with test threshold ="
"\002,f8.2,/\002 ( A denotes A on input and T denotes A on output)"
"\002,//\002 1 = 0 if T in Schur form (no sort), \002,\002 1/ulp"
" otherwise\002,/\002 2 = | A - VS T transpose(VS) | / ( n |A| ul"
"p ) (no sort)\002,/\002 3 = | I - VS transpose(VS) | / ( n ulp )"
" (no sort) \002,/\002 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of"
" T (no sort),\002,\002 1/ulp otherwise\002,/\002 5 = 0 if T sam"
"e no matter if VS computed (no sort),\002,\002 1/ulp otherwis"
"e\002,/\002 6 = 0 if WR, WI same no matter if VS computed (no so"
"rt)\002,\002, 1/ulp otherwise\002)";
static char fmt_9994[] = "(\002 7 = 0 if T in Schur form (sort), \002"
",\002 1/ulp otherwise\002,/\002 8 = | A - VS T transpose(VS) | "
"/ ( n |A| ulp ) (sort)\002,/\002 9 = | I - VS transpose(VS) | / "
"( n ulp ) (sort) \002,/\002 10 = 0 if WR+sqrt(-1)*WI are eigenva"
"lues of T (sort),\002,\002 1/ulp otherwise\002,/\002 11 = 0 if "
"T same no matter what else computed (sort),\002,\002 1/ulp othe"
"rwise\002,/\002 12 = 0 if WR, WI same no matter what else comput"
"ed \002,\002(sort), 1/ulp otherwise\002,/\002 13 = 0 if sorting "
"succesful, 1/ulp otherwise\002,/\002 14 = 0 if RCONDE same no ma"
"tter what else computed,\002,\002 1/ulp otherwise\002,/\002 15 ="
" 0 if RCONDv same no matter what else computed,\002,\002 1/ulp o"
"therwise\002,/\002 16 = | RCONDE - RCONDE(precomputed) | / cond("
"RCONDE),\002,/\002 17 = | RCONDV - RCONDV(precomputed) | / cond("
"RCONDV),\002)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, IWK=\002,i2,\002, seed"
"=\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)="
"\002,g10.3)";
static char fmt_9992[] = "(\002 N=\002,i5,\002, input example =\002,i3"
",\002, test(\002,i2,\002)=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, h_dim1, h_offset, ht_dim1, ht_offset, vs_dim1,
vs_offset, vs1_dim1, vs1_offset, i__1, i__2, i__3, i__4;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Local variables */
integer i__, j, n, iwk;
real ulp, cond;
integer jcol;
char path[3];
integer nmax;
real unfl, ovfl;
logical badnn;
integer nfail, imode, iinfo;
real conds;
extern /* Subroutine */ int sget24_(logical *, integer *, real *, integer
*, integer *, integer *, real *, integer *, real *, real *, real *
, real *, real *, real *, real *, real *, real *, integer *, real
*, real *, real *, integer *, integer *, real *, real *, integer *
, integer *, logical *, integer *);
real anorm;
integer islct[20], nslct, jsize, nerrs, itype, jtype, ntest;
real rtulp;
extern /* Subroutine */ int slabad_(real *, real *);
real rcdein;
char adumma[1*1];
extern doublereal slamch_(char *);
integer idumma[1], ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *);
real rcdvin;
extern /* Subroutine */ int slatme_(integer *, char *, integer *, real *,
integer *, real *, real *, char *, char *, char *, char *, real *,
integer *, real *, integer *, integer *, real *, real *, integer
*, real *, integer *),
slaset_(char *, integer *, integer *, real *, real *, real *,
integer *), slatmr_(integer *, integer *, char *, integer
*, char *, real *, integer *, real *, real *, char *, char *,
real *, integer *, real *, real *, integer *, real *, char *,
integer *, integer *, integer *, real *, real *, char *, real *,
integer *, integer *, integer *);
integer ntestf;
extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
*), slatms_(integer *, integer *, char *, integer *, char
*, real *, integer *, real *, real *, integer *, integer *, char *
, real *, integer *, real *, integer *);
real ulpinv;
integer nnwork;
real rtulpi;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___32 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___48 = { 0, 0, 1, 0, 0 };
static cilist io___49 = { 0, 0, 0, 0, 0 };
static cilist io___51 = { 0, 0, 0, 0, 0 };
static cilist io___52 = { 0, 0, 0, 0, 0 };
static cilist io___53 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___54 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___55 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___56 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___57 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___58 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___59 = { 0, 0, 0, fmt_9992, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SDRVSX checks the nonsymmetric eigenvalue (Schur form) problem */
/* expert driver SGEESX. */
/* SDRVSX uses both test matrices generated randomly depending on */
/* data supplied in the calling sequence, as well as on data */
/* read from an input file and including precomputed condition */
/* numbers to which it compares the ones it computes. */
/* When SDRVSX is called, a number of matrix "sizes" ("n's") and a */
/* number of matrix "types" are specified. For each size ("n") */
/* and each type of matrix, one matrix will be generated and used */
/* to test the nonsymmetric eigenroutines. For each matrix, 15 */
/* tests will be performed: */
/* (1) 0 if T is in Schur form, 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (2) | A - VS T VS' | / ( n |A| ulp ) */
/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
/* form (no sorting of eigenvalues). */
/* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues). */
/* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (5) 0 if T(with VS) = T(without VS), */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
/* 1/ulp otherwise */
/* (no sorting of eigenvalues) */
/* (7) 0 if T is in Schur form, 1/ulp otherwise */
/* (with sorting of eigenvalues) */
/* (8) | A - VS T VS' | / ( n |A| ulp ) */
/* Here VS is the matrix of Schur eigenvectors, and T is in Schur */
/* form (with sorting of eigenvalues). */
/* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues). */
/* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare WR, WI with and */
/* without reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (11) 0 if T(with VS) = T(without VS), */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare T with and without */
/* reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS), */
/* 1/ulp otherwise */
/* If workspace sufficient, also compare VS with and without */
/* reciprocal condition numbers */
/* (with sorting of eigenvalues) */
/* (13) if sorting worked and SDIM is the number of */
/* eigenvalues which were SELECTed */
/* If workspace sufficient, also compare SDIM with and */
/* without reciprocal condition numbers */
/* (14) if RCONDE the same no matter if VS and/or RCONDV computed */
/* (15) if RCONDV the same no matter if VS and/or RCONDE computed */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A (transposed) Jordan block, with 1's on the diagonal. */
/* (4) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (5) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (7) Same as (4), but multiplied by a constant near */
/* the overflow threshold */
/* (8) Same as (4), but multiplied by a constant near */
/* the underflow threshold */
/* (9) A matrix of the form U' T U, where U is orthogonal and */
/* T has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (10) A matrix of the form U' T U, where U is orthogonal and */
/* T has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (11) A matrix of the form U' T U, where U is orthogonal and */
/* T has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal and random O(1) entries in the upper */
/* triangle. */
/* (12) A matrix of the form U' T U, where U is orthogonal and */
/* T has real or complex conjugate paired eigenvalues randomly */
/* chosen from ( ULP, 1 ) and random O(1) entries in the upper */
/* triangle. */
/* (13) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP */
/* with random signs on the diagonal and random O(1) entries */
/* in the upper triangle. */
/* (14) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has geometrically spaced entries */
/* 1, ..., ULP with random signs on the diagonal and random */
/* O(1) entries in the upper triangle. */
/* (15) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP */
/* with random signs on the diagonal and random O(1) entries */
/* in the upper triangle. */
/* (16) A matrix of the form X' T X, where X has condition */
/* SQRT( ULP ) and T has real or complex conjugate paired */
/* eigenvalues randomly chosen from ( ULP, 1 ) and random */
/* O(1) entries in the upper triangle. */
/* (17) Same as (16), but multiplied by a constant */
/* near the overflow threshold */
/* (18) Same as (16), but multiplied by a constant */
/* near the underflow threshold */
/* (19) Nonsymmetric matrix with random entries chosen from (-1,1). */
/* If N is at least 4, all entries in first two rows and last */
/* row, and first column and last two columns are zero. */
/* (20) Same as (19), but multiplied by a constant */
/* near the overflow threshold */
/* (21) Same as (19), but multiplied by a constant */
/* near the underflow threshold */
/* In addition, an input file will be read from logical unit number */
/* NIUNIT. The file contains matrices along with precomputed */
/* eigenvalues and reciprocal condition numbers for the eigenvalue */
/* average and right invariant subspace. For these matrices, in */
/* addition to tests (1) to (15) we will compute the following two */
/* tests: */
/* (16) |RCONDE - RCDEIN| / cond(RCONDE) */
/* RCONDE is the reciprocal average eigenvalue condition number */
/* computed by SGEESX and RCDEIN (the precomputed true value) */
/* is supplied as input. cond(RCONDE) is the condition number */
/* of RCONDE, and takes errors in computing RCONDE into account, */
/* so that the resulting quantity should be O(ULP). cond(RCONDE) */
/* is essentially given by norm(A)/RCONDV. */
/* (17) |RCONDV - RCDVIN| / cond(RCONDV) */
/* RCONDV is the reciprocal right invariant subspace condition */
/* number computed by SGEESX and RCDVIN (the precomputed true */
/* value) is supplied as input. cond(RCONDV) is the condition */
/* number of RCONDV, and takes errors in computing RCONDV into */
/* account, so that the resulting quantity should be O(ULP). */
/* cond(RCONDV) is essentially given by norm(A)/RCONDE. */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. NSIZES must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIUNIT will be */
/* tested. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. NTYPES must be at least */
/* zero. If it is zero, no randomly generated test matrices */
/* are tested, but and test matrices read from NIUNIT will be */
/* tested. If it is MAXTYP+1 and NSIZES is 1, then an */
/* additional type, MAXTYP+1 is defined, which is to use */
/* whatever matrix is in A. This is only useful if */
/* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) 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 SDRVSX to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NIUNIT (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns INFO not equal to 0.) */
/* A (workspace) REAL array, dimension (LDA, max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, and H. LDA must be at */
/* least 1 and at least max( NN ). */
/* H (workspace) REAL array, dimension (LDA, max(NN)) */
/* Another copy of the test matrix A, modified by SGEESX. */
/* HT (workspace) REAL array, dimension (LDA, max(NN)) */
/* Yet another copy of the test matrix A, modified by SGEESX. */
/* WR (workspace) REAL array, dimension (max(NN)) */
/* WI (workspace) REAL array, dimension (max(NN)) */
/* The real and imaginary parts of the eigenvalues of A. */
/* On exit, WR + WI*i are the eigenvalues of the matrix in A. */
/* WRT (workspace) REAL array, dimension (max(NN)) */
/* WIT (workspace) REAL array, dimension (max(NN)) */
/* Like WR, WI, these arrays contain the eigenvalues of A, */
/* but those computed when SGEESX only computes a partial */
/* eigendecomposition, i.e. not Schur vectors */
/* WRTMP (workspace) REAL array, dimension (max(NN)) */
/* WITMP (workspace) REAL array, dimension (max(NN)) */
/* More temporary storage for eigenvalues. */
/* VS (workspace) REAL array, dimension (LDVS, max(NN)) */
/* VS holds the computed Schur vectors. */
/* LDVS (input) INTEGER */
/* Leading dimension of VS. Must be at least max(1,max(NN)). */
/* VS1 (workspace) REAL array, dimension (LDVS, max(NN)) */
/* VS1 holds another copy of the computed Schur vectors. */
/* RESULT (output) REAL array, dimension (17) */
/* The values computed by the 17 tests described above. */
/* The values are currently limited to 1/ulp, to avoid overflow. */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max(3*NN(j),2*NN(j)**2) for all j. */
/* IWORK (workspace) INTEGER array, dimension (max(NN)*max(NN)) */
/* INFO (output) INTEGER */
/* If 0, successful exit. */
/* <0, input parameter -INFO is incorrect */
/* >0, SLATMR, SLATMS, SLATME or SGET24 returned an error */
/* code and INFO is its absolute value */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NMAX Largest value in NN. */
/* NERRS The number of tests which have exceeded THRESH */
/* COND, CONDS, */
/* IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTULP, RTULPI Square roots of the previous 4 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* KCONDS(j) Selectw whether CONDS is to be 1 or */
/* 1/sqrt(ulp). (0 means irrelevant.) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Arrays in Common .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--dotype;
--iseed;
ht_dim1 = *lda;
ht_offset = 1 + ht_dim1;
ht -= ht_offset;
h_dim1 = *lda;
h_offset = 1 + h_dim1;
h__ -= h_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--wr;
--wi;
--wrt;
--wit;
--wrtmp;
--witmp;
vs1_dim1 = *ldvs;
vs1_offset = 1 + vs1_dim1;
vs1 -= vs1_offset;
vs_dim1 = *ldvs;
vs_offset = 1 + vs_dim1;
vs -= vs_offset;
--result;
--work;
--iwork;
--bwork;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
s_copy(path, "Single precision", (ftnlen)1, (ftnlen)16);
s_copy(path + 1, "SX", (ftnlen)2, (ftnlen)2);
/* Check for errors */
ntestt = 0;
ntestf = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
/* 12 is the largest dimension in the input file of precomputed */
/* problems */
nmax = 12;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*ntypes < 0) {
*info = -3;
} else if (*thresh < 0.f) {
*info = -6;
} else if (*niunit <= 0) {
*info = -7;
} else if (*nounit <= 0) {
*info = -8;
} else if (*lda < 1 || *lda < nmax) {
*info = -10;
} else if (*ldvs < 1 || *ldvs < nmax) {
*info = -20;
} else /* if(complicated condition) */ {
/* Computing MAX */
/* Computing 2nd power */
i__3 = nmax;
i__1 = nmax * 3, i__2 = i__3 * i__3 << 1;
if (max(i__1,i__2) > *lwork) {
*info = -24;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDRVSX", &i__1);
return 0;
}
/* If nothing to do check on NIUNIT */
if (*nsizes == 0 || *ntypes == 0) {
goto L150;
}
/* More Important constants */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
slabad_(&unfl, &ovfl);
ulp = slamch_("Precision");
ulpinv = 1.f / ulp;
rtulp = sqrt(ulp);
rtulpi = 1.f / rtulp;
/* Loop over sizes, types */
nerrs = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
if (*nsizes != 1) {
mtypes = min(21,*ntypes);
} else {
mtypes = min(22,*ntypes);
}
i__2 = mtypes;
for (jtype = 1; jtype <= i__2; ++jtype) {
if (! dotype[jtype]) {
goto L130;
}
/* Save ISEED in case of an error. */
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L20: */
}
/* Compute "A" */
/* Control parameters: */
/* KMAGN KCONDS KMODE KTYPE */
/* =1 O(1) 1 clustered 1 zero */
/* =2 large large clustered 2 identity */
/* =3 small exponential Jordan */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log symmetric, w/ eigenvalues */
/* =6 random general, w/ eigenvalues */
/* =7 random diagonal */
/* =8 random symmetric */
/* =9 random general */
/* =10 random triangular */
if (mtypes > 21) {
goto L90;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L30;
case 2: goto L40;
case 3: goto L50;
}
L30:
anorm = 1.f;
goto L60;
L40:
anorm = ovfl * ulp;
goto L60;
L50:
anorm = unfl * ulpinv;
goto L60;
L60:
slaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
iinfo = 0;
cond = ulpinv;
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
/* L70: */
}
} else if (itype == 3) {
/* Jordan Block */
i__3 = n;
for (jcol = 1; jcol <= i__3; ++jcol) {
a[jcol + jcol * a_dim1] = anorm;
if (jcol > 1) {
a[jcol + (jcol - 1) * a_dim1] = 1.f;
}
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &c__0, &c__0, "N", &a[a_offset], lda, &work[n
+ 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
slatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &cond,
&anorm, &n, &n, "N", &a[a_offset], lda, &work[n + 1],
&iinfo);
} else if (itype == 6) {
/* General, eigenvalues specified */
if (kconds[jtype - 1] == 1) {
conds = 1.f;
} else if (kconds[jtype - 1] == 2) {
conds = rtulpi;
} else {
conds = 0.f;
}
*(unsigned char *)&adumma[0] = ' ';
slatme_(&n, "S", &iseed[1], &work[1], &imode, &cond, &c_b32,
adumma, "T", "T", "T", &work[n + 1], &c__4, &conds, &
n, &n, &anorm, &a[a_offset], lda, &work[(n << 1) + 1],
&iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &c__0, &
c__0, &c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[
1], &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else if (itype == 9) {
/* General, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &n, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
if (n >= 4) {
slaset_("Full", &c__2, &n, &c_b18, &c_b18, &a[a_offset],
lda);
i__3 = n - 3;
slaset_("Full", &i__3, &c__1, &c_b18, &c_b18, &a[a_dim1 +
3], lda);
i__3 = n - 3;
slaset_("Full", &i__3, &c__2, &c_b18, &c_b18, &a[(n - 1) *
a_dim1 + 3], lda);
slaset_("Full", &c__1, &n, &c_b18, &c_b18, &a[n + a_dim1],
lda);
}
} else if (itype == 10) {
/* Triangular, random eigenvalues */
slatmr_(&n, &n, "S", &iseed[1], "N", &work[1], &c__6, &c_b32,
&c_b32, "T", "N", &work[n + 1], &c__1, &c_b32, &work[(
n << 1) + 1], &c__1, &c_b32, "N", idumma, &n, &c__0, &
c_b18, &anorm, "NO", &a[a_offset], lda, &iwork[1], &
iinfo);
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___32.ciunit = *nounit;
s_wsfe(&io___32);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer));
e_wsfe();
*info = abs(iinfo);
return 0;
}
L90:
/* Test for minimal and generous workspace */
for (iwk = 1; iwk <= 2; ++iwk) {
if (iwk == 1) {
nnwork = n * 3;
} else {
/* Computing MAX */
i__3 = n * 3, i__4 = (n << 1) * n;
nnwork = max(i__3,i__4);
}
nnwork = max(nnwork,1);
sget24_(&c_false, &jtype, thresh, ioldsd, nounit, &n, &a[
a_offset], lda, &h__[h_offset], &ht[ht_offset], &wr[1]
, &wi[1], &wrt[1], &wit[1], &wrtmp[1], &witmp[1], &vs[
vs_offset], ldvs, &vs1[vs1_offset], &rcdein, &rcdvin,
&nslct, islct, &result[1], &work[1], &nnwork, &iwork[
1], &bwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 15; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L100: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
e_wsfe();
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
io___46.ciunit = *nounit;
s_wsfe(&io___46);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 15; ++j) {
if (result[j] >= *thresh) {
io___47.ciunit = *nounit;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&iwk, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real)
);
e_wsfe();
}
/* L110: */
}
nerrs += nfail;
ntestt += ntest;
/* L120: */
}
L130:
;
}
/* L140: */
}
L150:
/* Read in data from file to check accuracy of condition estimation */
/* Read input data until N=0 */
jtype = 0;
L160:
io___48.ciunit = *niunit;
i__1 = s_rsle(&io___48);
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = do_lio(&c__3, &c__1, (char *)&nslct, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L200;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L200;
}
if (n == 0) {
goto L200;
}
++jtype;
iseed[1] = jtype;
if (nslct > 0) {
io___49.ciunit = *niunit;
s_rsle(&io___49);
i__1 = nslct;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&islct[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___51.ciunit = *niunit;
s_rsle(&io___51);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__4, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
real));
}
e_rsle();
/* L170: */
}
io___52.ciunit = *niunit;
s_rsle(&io___52);
do_lio(&c__4, &c__1, (char *)&rcdein, (ftnlen)sizeof(real));
do_lio(&c__4, &c__1, (char *)&rcdvin, (ftnlen)sizeof(real));
e_rsle();
sget24_(&c_true, &c__22, thresh, &iseed[1], nounit, &n, &a[a_offset], lda,
&h__[h_offset], &ht[ht_offset], &wr[1], &wi[1], &wrt[1], &wit[1],
&wrtmp[1], &witmp[1], &vs[vs_offset], ldvs, &vs1[vs1_offset], &
rcdein, &rcdvin, &nslct, islct, &result[1], &work[1], lwork, &
iwork[1], &bwork[1], info);
/* Check for RESULT(j) > THRESH */
ntest = 0;
nfail = 0;
for (j = 1; j <= 17; ++j) {
if (result[j] >= 0.f) {
++ntest;
}
if (result[j] >= *thresh) {
++nfail;
}
/* L180: */
}
if (nfail > 0) {
++ntestf;
}
if (ntestf == 1) {
io___53.ciunit = *nounit;
s_wsfe(&io___53);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___54.ciunit = *nounit;
s_wsfe(&io___54);
e_wsfe();
io___55.ciunit = *nounit;
s_wsfe(&io___55);
e_wsfe();
io___56.ciunit = *nounit;
s_wsfe(&io___56);
e_wsfe();
io___57.ciunit = *nounit;
s_wsfe(&io___57);
do_fio(&c__1, (char *)&(*thresh), (ftnlen)sizeof(real));
e_wsfe();
io___58.ciunit = *nounit;
s_wsfe(&io___58);
e_wsfe();
ntestf = 2;
}
for (j = 1; j <= 17; ++j) {
if (result[j] >= *thresh) {
io___59.ciunit = *nounit;
s_wsfe(&io___59);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
e_wsfe();
}
/* L190: */
}
nerrs += nfail;
ntestt += ntest;
goto L160;
L200:
/* Summary */
slasum_(path, nounit, &nerrs, &ntestt);
return 0;
/* End of SDRVSX */
} /* sdrvsx_ */
/* Subroutine */ int cdrgvx_(integer *nsize, real *thresh, integer *nin,
integer *nout, complex *a, integer *lda, complex *b, complex *ai,
complex *bi, complex *alpha, complex *beta, complex *vl, complex *vr,
integer *ilo, integer *ihi, real *lscale, real *rscale, real *s, real
*stru, real *dif, real *diftru, complex *work, integer *lwork, real *
rwork, integer *iwork, integer *liwork, real *result, logical *bwork,
integer *info)
{
/* Format strings */
static char fmt_9999[] = "(\002 CDRGVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002)\002)";
static char fmt_9998[] = "(\002 CDRGVX: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, IWA=\002,i5,\002, IWB=\002,i5,\002, IWX=\002,i5,\002, I"
"WY=\002,i5)";
static char fmt_9997[] = "(/1x,a3,\002 -- Complex Expert Eigenvalue/vect"
"or\002,\002 problem driver\002)";
static char fmt_9995[] = "(\002 Matrix types: \002,/)";
static char fmt_9994[] = "(\002 TYPE 1: Da is diagonal, Db is identity,"
" \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) \002,/"
"\002 YH and X are left and right eigenvectors. \002,/)";
static char fmt_9993[] = "(\002 TYPE 2: Da is quasi-diagonal, Db is iden"
"tity, \002,/\002 A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1)"
" \002,/\002 YH and X are left and right eigenvectors. \002,/)"
;
static char fmt_9992[] = "(/\002 Tests performed: \002,/4x,\002 a is al"
"pha, b is beta, l is a left eigenvector, \002,/4x,\002 r is a ri"
"ght eigenvector and \002,a,\002 means \002,a,\002.\002,/\002 1 ="
" max | ( b A - a B )\002,a,\002 l | / const.\002,/\002 2 = max |"
" ( b A - a B ) r | / const.\002,/\002 3 = max ( Sest/Stru, Stru/"
"Sest ) \002,\002 over all eigenvalues\002,/\002 4 = max( DIFest/"
"DIFtru, DIFtru/DIFest ) \002,\002 over the 1st and 5th eigenvect"
"ors\002,/)";
static char fmt_9991[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
"ult \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9990[] = "(\002 Type=\002,i2,\002,\002,\002 IWA=\002,i2"
",\002, IWB=\002,i2,\002, IWX=\002,i2,\002, IWY=\002,i2,\002, res"
"ult \002,i2,\002 is\002,1p,e10.3)";
static char fmt_9987[] = "(\002 CDRGVX: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, Input example #\002,i2,\002"
")\002)";
static char fmt_9986[] = "(\002 CDRGVX: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, Input Examp"
"le #\002,i2,\002)\002)";
static char fmt_9996[] = "(\002Input Example\002)";
static char fmt_9989[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,0p,f8.2)";
static char fmt_9988[] = "(\002 Input example #\002,i2,\002, matrix orde"
"r=\002,i4,\002,\002,\002 result \002,i2,\002 is\002,1p,e10.3)";
/* System generated locals */
integer a_dim1, a_offset, ai_dim1, ai_offset, b_dim1, b_offset, bi_dim1,
bi_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, i__2;
real r__1, r__2, r__3, r__4;
complex q__1;
/* Local variables */
integer i__, j, n, iwa, iwb;
real ulp;
integer iwx, iwy, nmax;
extern /* Subroutine */ int cget52_(logical *, integer *, complex *,
integer *, complex *, integer *, complex *, integer *, complex *,
complex *, complex *, real *, real *);
integer linfo;
real anorm, bnorm;
integer nerrs;
extern /* Subroutine */ int clatm6_(integer *, integer *, complex *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, complex *, complex *, real *, real *);
real ratio1, ratio2, thrsh2;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *), xerbla_(char *,
integer *);
real abnorm;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *), cggevx_(char *, char *, char *, char *,
integer *, complex *, integer *, complex *, integer *, complex *,
complex *, complex *, integer *, complex *, integer *, integer *,
integer *, real *, real *, real *, real *, real *, real *,
complex *, integer *, real *, integer *, logical *, integer *);
complex weight[5];
integer minwrk, maxwrk, iptype;
real ulpinv;
integer nptknt, ntestt;
/* Fortran I/O blocks */
static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___22 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___23 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___30 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___31 = { 0, 0, 0, fmt_9993, 0 };
static cilist io___32 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9991, 0 };
static cilist io___34 = { 0, 0, 0, fmt_9990, 0 };
static cilist io___35 = { 0, 0, 1, 0, 0 };
static cilist io___36 = { 0, 0, 0, 0, 0 };
static cilist io___37 = { 0, 0, 0, 0, 0 };
static cilist io___38 = { 0, 0, 0, 0, 0 };
static cilist io___39 = { 0, 0, 0, 0, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9987, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9986, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9992, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9989, 0 };
static cilist io___47 = { 0, 0, 0, fmt_9988, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CDRGVX checks the nonsymmetric generalized eigenvalue problem */
/* expert driver CGGEVX. */
/* CGGEVX computes the generalized eigenvalues, (optionally) the left */
/* and/or right eigenvectors, (optionally) computes a balancing */
/* transformation to improve the conditioning, and (optionally) */
/* reciprocal condition numbers for the eigenvalues and eigenvectors. */
/* When CDRGVX is called with NSIZE > 0, two types of test matrix pairs */
/* are generated by the subroutine SLATM6 and test the driver CGGEVX. */
/* The test matrices have the known exact condition numbers for */
/* eigenvalues. For the condition numbers of the eigenvectors */
/* corresponding the first and last eigenvalues are also know */
/* ``exactly'' (see CLATM6). */
/* For each matrix pair, the following tests will be performed and */
/* compared with the threshhold THRESH. */
/* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of */
/* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) ) */
/* where l**H is the conjugate tranpose of l. */
/* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of */
/* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) ) */
/* (3) The condition number S(i) of eigenvalues computed by CGGEVX */
/* differs less than a factor THRESH from the exact S(i) (see */
/* CLATM6). */
/* (4) DIF(i) computed by CTGSNA differs less than a factor 10*THRESH */
/* from the exact value (for the 1st and 5th vectors only). */
/* Test Matrices */
/* ============= */
/* Two kinds of test matrix pairs */
/* (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
/* are used in the tests: */
/* 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 */
/* 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 from */
/* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }. */
/* Arguments */
/* ========= */
/* NSIZE (input) INTEGER */
/* The number of sizes of matrices to use. NSIZE must be at */
/* least zero. If it is zero, no randomly generated matrices */
/* are tested, but any test matrices read from NIN will be */
/* tested. If it is not zero, then N = 5. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NIN (input) INTEGER */
/* The FORTRAN unit number for reading in the data file of */
/* problems to solve. */
/* NOUT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (workspace) COMPLEX array, dimension (LDA, NSIZE) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, A contains the last matrix actually used. */
/* LDA (input) INTEGER */
/* The leading dimension of A, B, AI, BI, Ao, and Bo. */
/* It must be at least 1 and at least NSIZE. */
/* B (workspace) COMPLEX array, dimension (LDA, NSIZE) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. On exit, B contains the last matrix actually used. */
/* AI (workspace) COMPLEX array, dimension (LDA, NSIZE) */
/* Copy of A, modified by CGGEVX. */
/* BI (workspace) COMPLEX array, dimension (LDA, NSIZE) */
/* Copy of B, modified by CGGEVX. */
/* ALPHA (workspace) COMPLEX array, dimension (NSIZE) */
/* BETA (workspace) COMPLEX array, dimension (NSIZE) */
/* On exit, ALPHA/BETA are the eigenvalues. */
/* VL (workspace) COMPLEX array, dimension (LDA, NSIZE) */
/* VL holds the left eigenvectors computed by CGGEVX. */
/* VR (workspace) COMPLEX array, dimension (LDA, NSIZE) */
/* VR holds the right eigenvectors computed by CGGEVX. */
/* ILO (output/workspace) INTEGER */
/* IHI (output/workspace) INTEGER */
/* LSCALE (output/workspace) REAL array, dimension (N) */
/* RSCALE (output/workspace) REAL array, dimension (N) */
/* S (output/workspace) REAL array, dimension (N) */
/* STRU (output/workspace) REAL array, dimension (N) */
/* DIF (output/workspace) REAL array, dimension (N) */
/* DIFTRU (output/workspace) REAL array, dimension (N) */
/* WORK (workspace) COMPLEX array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* Leading dimension of WORK. LWORK >= 2*N*N + 2*N */
/* RWORK (workspace) REAL array, dimension (6*N) */
/* IWORK (workspace) INTEGER array, dimension (LIWORK) */
/* LIWORK (input) INTEGER */
/* Leading dimension of IWORK. LIWORK >= N+2. */
/* RESULT (output/workspace) REAL array, dimension (4) */
/* BWORK (workspace) LOGICAL array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: A routine returned an error code. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
/* Parameter adjustments */
vr_dim1 = *lda;
vr_offset = 1 + vr_dim1;
vr -= vr_offset;
vl_dim1 = *lda;
vl_offset = 1 + vl_dim1;
vl -= vl_offset;
bi_dim1 = *lda;
bi_offset = 1 + bi_dim1;
bi -= bi_offset;
ai_dim1 = *lda;
ai_offset = 1 + ai_dim1;
ai -= ai_offset;
b_dim1 = *lda;
b_offset = 1 + b_dim1;
b -= b_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--alpha;
--beta;
--lscale;
--rscale;
--s;
--stru;
--dif;
--diftru;
--work;
--rwork;
--iwork;
--result;
--bwork;
/* Function Body */
*info = 0;
nmax = 5;
if (*nsize < 0) {
*info = -1;
} else if (*thresh < 0.f) {
*info = -2;
} else if (*nin <= 0) {
*info = -3;
} else if (*nout <= 0) {
*info = -4;
} else if (*lda < 1 || *lda < nmax) {
*info = -6;
} else if (*liwork < nmax + 2) {
*info = -26;
}
/* Compute workspace */
/* (Note: Comments in the code beginning "Workspace:" describe the */
/* minimal amount of workspace needed at that point in the code, */
/* as well as the preferred amount for good performance. */
/* NB refers to the optimal block size for the immediately */
/* following subroutine, as returned by ILAENV.) */
minwrk = 1;
if (*info == 0 && *lwork >= 1) {
minwrk = (nmax << 1) * (nmax + 1);
maxwrk = nmax * (ilaenv_(&c__1, "CGEQRF", " ", &nmax, &c__1, &nmax, &
c__0) + 1);
/* Computing MAX */
i__1 = maxwrk, i__2 = (nmax << 1) * (nmax + 1);
maxwrk = max(i__1,i__2);
work[1].r = (real) maxwrk, work[1].i = 0.f;
}
if (*lwork < minwrk) {
*info = -23;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CDRGVX", &i__1);
return 0;
}
n = 5;
ulp = slamch_("P");
ulpinv = 1.f / ulp;
thrsh2 = *thresh * 10.f;
nerrs = 0;
nptknt = 0;
ntestt = 0;
if (*nsize == 0) {
goto L90;
}
/* Parameters used for generating test matrices. */
r__1 = sqrt(sqrt(ulp));
q__1.r = r__1, q__1.i = 0.f;
weight[0].r = q__1.r, weight[0].i = q__1.i;
weight[1].r = .1f, weight[1].i = 0.f;
weight[2].r = 1.f, weight[2].i = 0.f;
c_div(&q__1, &c_b11, &weight[1]);
weight[3].r = q__1.r, weight[3].i = q__1.i;
c_div(&q__1, &c_b11, weight);
weight[4].r = q__1.r, weight[4].i = q__1.i;
for (iptype = 1; iptype <= 2; ++iptype) {
for (iwa = 1; iwa <= 5; ++iwa) {
for (iwb = 1; iwb <= 5; ++iwb) {
for (iwx = 1; iwx <= 5; ++iwx) {
for (iwy = 1; iwy <= 5; ++iwy) {
/* generated a pair of test matrix */
clatm6_(&iptype, &c__5, &a[a_offset], lda, &b[
b_offset], &vr[vr_offset], lda, &vl[vl_offset]
, lda, &weight[iwa - 1], &weight[iwb - 1], &
weight[iwx - 1], &weight[iwy - 1], &stru[1], &
diftru[1]);
/* Compute eigenvalues/eigenvectors of (A, B). */
/* Compute eigenvalue/eigenvector condition numbers */
/* using computed eigenvectors. */
clacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset]
, lda);
clacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset]
, lda);
cggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &
bi[bi_offset], lda, &alpha[1], &beta[1], &vl[
vl_offset], lda, &vr[vr_offset], lda, ilo,
ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &
s[1], &dif[1], &work[1], lwork, &rwork[1], &
iwork[1], &bwork[1], &linfo);
if (linfo != 0) {
io___20.ciunit = *nout;
s_wsfe(&io___20);
do_fio(&c__1, "CGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
goto L30;
}
/* Compute the norm(A, B) */
clacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1],
&n);
clacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n *
n + 1], &n);
i__1 = n << 1;
abnorm = clange_("Fro", &n, &i__1, &work[1], &n, &
rwork[1]);
/* Tests (1) and (2) */
result[1] = 0.f;
cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset],
lda, &vl[vl_offset], lda, &alpha[1], &beta[1],
&work[1], &rwork[1], &result[1]);
if (result[2] > *thresh) {
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
}
result[2] = 0.f;
cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset],
lda, &vr[vr_offset], lda, &alpha[1], &beta[1]
, &work[1], &rwork[1], &result[2]);
if (result[3] > *thresh) {
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(
real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&iptype, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)sizeof(
integer));
e_wsfe();
}
/* Test (3) */
result[3] = 0.f;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] == 0.f) {
if (stru[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else if (stru[i__] == 0.f) {
if (s[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else {
/* Computing MAX */
r__3 = (r__1 = stru[i__] / s[i__], dabs(r__1))
, r__4 = (r__2 = s[i__] / stru[i__],
dabs(r__2));
rwork[i__] = dmax(r__3,r__4);
/* Computing MAX */
r__1 = result[3], r__2 = rwork[i__];
result[3] = dmax(r__1,r__2);
}
/* L10: */
}
/* Test (4) */
result[4] = 0.f;
if (dif[1] == 0.f) {
if (diftru[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[1] == 0.f) {
if (dif[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (dif[5] == 0.f) {
if (diftru[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[5] == 0.f) {
if (dif[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else {
/* Computing MAX */
r__3 = (r__1 = diftru[1] / dif[1], dabs(r__1)),
r__4 = (r__2 = dif[1] / diftru[1], dabs(
r__2));
ratio1 = dmax(r__3,r__4);
/* Computing MAX */
r__3 = (r__1 = diftru[5] / dif[5], dabs(r__1)),
r__4 = (r__2 = dif[5] / diftru[5], dabs(
r__2));
ratio2 = dmax(r__3,r__4);
result[4] = dmax(ratio1,ratio2);
}
ntestt += 4;
/* Print out tests which fail. */
for (j = 1; j <= 4; ++j) {
if (result[j] >= thrsh2 && j >= 4 || result[j] >=
*thresh && j <= 3) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___28.ciunit = *nout;
s_wsfe(&io___28);
do_fio(&c__1, "CXV", (ftnlen)3);
e_wsfe();
/* Print out messages for built-in examples */
/* Matrix types */
io___29.ciunit = *nout;
s_wsfe(&io___29);
e_wsfe();
io___30.ciunit = *nout;
s_wsfe(&io___30);
e_wsfe();
io___31.ciunit = *nout;
s_wsfe(&io___31);
e_wsfe();
/* Tests performed */
io___32.ciunit = *nout;
s_wsfe(&io___32);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
do_fio(&c__1, "'", (ftnlen)1);
e_wsfe();
}
++nerrs;
if (result[j] < 1e4f) {
io___33.ciunit = *nout;
s_wsfe(&io___33);
do_fio(&c__1, (char *)&iptype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)
sizeof(real));
e_wsfe();
} else {
io___34.ciunit = *nout;
s_wsfe(&io___34);
do_fio(&c__1, (char *)&iptype, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwa, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwb, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwx, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&iwy, (ftnlen)
sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)
sizeof(real));
e_wsfe();
}
}
/* L20: */
}
L30:
/* L40: */
;
}
/* L50: */
}
/* L60: */
}
/* L70: */
}
/* L80: */
}
goto L150;
L90:
/* Read in data from file to check accuracy of condition estimation */
/* Read input data until N=0 */
io___35.ciunit = *nin;
i__1 = s_rsle(&io___35);
if (i__1 != 0) {
goto L150;
}
i__1 = do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L150;
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L150;
}
if (n == 0) {
goto L150;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___36.ciunit = *nin;
s_rsle(&io___36);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
complex));
}
e_rsle();
/* L100: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___37.ciunit = *nin;
s_rsle(&io___37);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&b[i__ + j * b_dim1], (ftnlen)sizeof(
complex));
}
e_rsle();
/* L110: */
}
io___38.ciunit = *nin;
s_rsle(&io___38);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__4, &c__1, (char *)&stru[i__], (ftnlen)sizeof(real));
}
e_rsle();
io___39.ciunit = *nin;
s_rsle(&io___39);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__4, &c__1, (char *)&diftru[i__], (ftnlen)sizeof(real));
}
e_rsle();
++nptknt;
/* Compute eigenvalues/eigenvectors of (A, B). */
/* Compute eigenvalue/eigenvector condition numbers */
/* using computed eigenvectors. */
clacpy_("F", &n, &n, &a[a_offset], lda, &ai[ai_offset], lda);
clacpy_("F", &n, &n, &b[b_offset], lda, &bi[bi_offset], lda);
cggevx_("N", "V", "V", "B", &n, &ai[ai_offset], lda, &bi[bi_offset], lda,
&alpha[1], &beta[1], &vl[vl_offset], lda, &vr[vr_offset], lda,
ilo, ihi, &lscale[1], &rscale[1], &anorm, &bnorm, &s[1], &dif[1],
&work[1], lwork, &rwork[1], &iwork[1], &bwork[1], &linfo);
if (linfo != 0) {
io___40.ciunit = *nout;
s_wsfe(&io___40);
do_fio(&c__1, "CGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&linfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
goto L140;
}
/* Compute the norm(A, B) */
clacpy_("Full", &n, &n, &ai[ai_offset], lda, &work[1], &n);
clacpy_("Full", &n, &n, &bi[bi_offset], lda, &work[n * n + 1], &n);
i__1 = n << 1;
abnorm = clange_("Fro", &n, &i__1, &work[1], &n, &rwork[1]);
/* Tests (1) and (2) */
result[1] = 0.f;
cget52_(&c_true, &n, &a[a_offset], lda, &b[b_offset], lda, &vl[vl_offset],
lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[1]);
if (result[2] > *thresh) {
io___41.ciunit = *nout;
s_wsfe(&io___41);
do_fio(&c__1, "Left", (ftnlen)4);
do_fio(&c__1, "CGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[2], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
result[2] = 0.f;
cget52_(&c_false, &n, &a[a_offset], lda, &b[b_offset], lda, &vr[vr_offset]
, lda, &alpha[1], &beta[1], &work[1], &rwork[1], &result[2]);
if (result[3] > *thresh) {
io___42.ciunit = *nout;
s_wsfe(&io___42);
do_fio(&c__1, "Right", (ftnlen)5);
do_fio(&c__1, "CGGEVX", (ftnlen)6);
do_fio(&c__1, (char *)&result[3], (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
e_wsfe();
}
/* Test (3) */
result[3] = 0.f;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] == 0.f) {
if (stru[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else if (stru[i__] == 0.f) {
if (s[i__] > abnorm * ulp) {
result[3] = ulpinv;
}
} else {
/* Computing MAX */
r__3 = (r__1 = stru[i__] / s[i__], dabs(r__1)), r__4 = (r__2 = s[
i__] / stru[i__], dabs(r__2));
rwork[i__] = dmax(r__3,r__4);
/* Computing MAX */
r__1 = result[3], r__2 = rwork[i__];
result[3] = dmax(r__1,r__2);
}
/* L120: */
}
/* Test (4) */
result[4] = 0.f;
if (dif[1] == 0.f) {
if (diftru[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[1] == 0.f) {
if (dif[1] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (dif[5] == 0.f) {
if (diftru[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else if (diftru[5] == 0.f) {
if (dif[5] > abnorm * ulp) {
result[4] = ulpinv;
}
} else {
/* Computing MAX */
r__3 = (r__1 = diftru[1] / dif[1], dabs(r__1)), r__4 = (r__2 = dif[1]
/ diftru[1], dabs(r__2));
ratio1 = dmax(r__3,r__4);
/* Computing MAX */
r__3 = (r__1 = diftru[5] / dif[5], dabs(r__1)), r__4 = (r__2 = dif[5]
/ diftru[5], dabs(r__2));
ratio2 = dmax(r__3,r__4);
result[4] = dmax(ratio1,ratio2);
}
ntestt += 4;
/* Print out tests which fail. */
for (j = 1; j <= 4; ++j) {
if (result[j] >= thrsh2) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___43.ciunit = *nout;
s_wsfe(&io___43);
do_fio(&c__1, "CXV", (ftnlen)3);
e_wsfe();
/* Print out messages for built-in examples */
/* Matrix types */
io___44.ciunit = *nout;
s_wsfe(&io___44);
e_wsfe();
/* Tests performed */
io___45.ciunit = *nout;
s_wsfe(&io___45);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
do_fio(&c__1, "'", (ftnlen)1);
e_wsfe();
}
++nerrs;
if (result[j] < 1e4f) {
io___46.ciunit = *nout;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
e_wsfe();
} else {
io___47.ciunit = *nout;
s_wsfe(&io___47);
do_fio(&c__1, (char *)&nptknt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[j], (ftnlen)sizeof(real));
e_wsfe();
}
}
/* L130: */
}
L140:
goto L90;
L150:
/* Summary */
alasvm_("CXV", nout, &nerrs, &ntestt, &c__0);
work[1].r = (real) maxwrk, work[1].i = 0.f;
return 0;
/* End of CDRGVX */
} /* cdrgvx_ */
/* Subroutine */ int newdriv2_(integer *iparm, doublereal *rparm, integer *nx,
integer *ny, integer *nz, doublereal *u, integer *iz, doublereal *w1,
doublereal *w2, integer *ipc, doublereal *rpc, doublereal *pc,
doublereal *ac, doublereal *cc, doublereal *fc, doublereal *xf,
doublereal *yf, doublereal *zf, doublereal *gxcf, doublereal *gycf,
doublereal *gzcf, doublereal *a1cf, doublereal *a2cf, doublereal *
a3cf, doublereal *ccf, doublereal *fcf, doublereal *tcf)
{
/* Format strings */
static char fmt_100[] = "(\002 ];\002,4(\002 \002,a7,\002=\002,1pe9.3"
",\002;\002))";
/* System generated locals */
doublereal d__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void), s_wsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_wsfe(void);
/* Local variables */
extern /* Subroutine */ int buildalg_(integer *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *), buildops_(integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, doublereal
*, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *),
buildstr_(integer *, integer *, integer *, integer *, integer *);
static integer nlev_real__;
static doublereal bf, oh;
static integer nu1, nu2, ido, iok, mode, ilev, nlev, iinfo, mgkey, itmax,
ipkey, iters, istop;
extern /* Subroutine */ int tstop_(doublereal *, doublereal *, doublereal
*);
static doublereal omegal;
static integer mgdisc;
static doublereal omegan;
static integer mgcoar;
extern doublereal epsmac_(integer *);
extern /* Subroutine */ int fbound_(integer *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *)
;
static integer ibound;
static doublereal epsiln;
static integer mgprol, mgsmoo, ierror, mgsolv;
static doublereal errtol;
extern /* Subroutine */ int newton_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
static doublereal tsolve;
extern /* Subroutine */ int tstart_(doublereal *, doublereal *), prtstp_(
integer *, integer *, doublereal *, doublereal *, doublereal *),
fbound00_(integer *, integer *, integer *, doublereal *),
fnewton_(integer *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *
, integer *, integer *, integer *, integer *, integer *, integer *
, integer *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *);
static doublereal tsetupc, tsetupf;
/* Fortran I/O blocks */
static cilist io___57 = { 0, 6, 0, 0, 0 };
static cilist io___59 = { 0, 6, 0, 0, 0 };
static cilist io___62 = { 0, 6, 0, 0, 0 };
static cilist io___68 = { 0, 6, 0, 0, 0 };
static cilist io___70 = { 0, 6, 0, 0, 0 };
static cilist io___71 = { 0, 6, 0, fmt_100, 0 };
/* * ********************************************************************* */
/* * purpose: */
/* * */
/* * this routine uses a newton's method, combined with a linear */
/* * multigrid iteration, to solve the following three-dimensional, */
/* * 2nd order elliptic partial differential equation: */
/* * */
/* * lu = f, u in omega */
/* * u = g, u on boundary of omega */
/* * where */
/* * */
/* * omega = [xmin,xmax]x[ymin,ymax]x[zmin,zmax] */
/* * */
/* * the multigrid code requires the operator in the form: */
/* * */
/* * - \nabla \cdot (a \nabla u) + c(u) = f */
/* * */
/* * with */
/* * */
/* * a(x,y,z),f(x,y,z), scalar functions (possibly discontinuous) */
/* * on omega. (discontinuities must be along fine grid lines). */
/* * boundary function g(x,y,z) is smooth on boundary of omega. */
/* * */
/* * the function c(u) is a possibly nonlinear function of the */
/* * unknown u, and varies (possibly discontinuously) with the */
/* * spatial position also. */
/* * */
/* * user inputs: */
/* * */
/* * the user must provide the coefficients of the differential */
/* * operator, some initial parameter settings in an integer and a */
/* * real parameter array, and various work arrays. */
/* * */
/* * author: michael holst */
/* * ********************************************************************* */
/* * */
/* * *** input parameters *** */
/* * */
/* * *** misc variables *** */
/* * */
/* * *** decode the iparm array *** */
/* Parameter adjustments */
--tcf;
--fcf;
--ccf;
--a3cf;
--a2cf;
--a1cf;
--gzcf;
--gycf;
--gxcf;
--zf;
--yf;
--xf;
--fc;
--cc;
--ac;
--pc;
--rpc;
--ipc;
--w2;
--w1;
--iz;
--u;
--rparm;
--iparm;
/* Function Body */
nlev = iparm[6];
nu1 = iparm[7];
nu2 = iparm[8];
mgkey = iparm[9];
itmax = iparm[10];
istop = iparm[11];
iinfo = iparm[12];
ipkey = iparm[14];
mgprol = iparm[17];
mgcoar = iparm[18];
mgdisc = iparm[19];
mgsmoo = iparm[20];
mgsolv = iparm[21];
errtol = rparm[1];
omegal = rparm[9];
omegan = rparm[10];
/* * */
/* * *** intitialize the iteration timer *** */
prtstp_(&c__0, &c_n99, &c_b23, &c_b23, &c_b23);
/* * */
/* * *** build the multigrid data structure in iz *** */
buildstr_(nx, ny, nz, &nlev, &iz[1]);
/* * */
/* * *** start timer *** */
tstart_(&bf, &oh);
/* * */
/* * *** build op and rhs on fine grid *** */
ido = 0;
buildops_(nx, ny, nz, &nlev, &ipkey, &iinfo, &ido, &iz[1], &mgprol, &
mgcoar, &mgsolv, &mgdisc, &ipc[1], &rpc[1], &pc[1], &ac[1], &cc[1]
, &fc[1], &xf[1], &yf[1], &zf[1], &gxcf[1], &gycf[1], &gzcf[1], &
a1cf[1], &a2cf[1], &a3cf[1], &ccf[1], &fcf[1], &tcf[1]);
/* * */
/* * *** stop timer *** */
tstop_(&bf, &oh, &tsetupf);
s_wsle(&io___57);
do_lio(&c__9, &c__1, "% NEWDRIV2: fine problem setup time: ", (ftnlen)37);
do_lio(&c__5, &c__1, (char *)&tsetupf, (ftnlen)sizeof(doublereal));
e_wsle();
/* * */
/* * *** start timer *** */
tstart_(&bf, &oh);
/* * */
/* * *** build op and rhs on all coarse grids *** */
ido = 1;
buildops_(nx, ny, nz, &nlev, &ipkey, &iinfo, &ido, &iz[1], &mgprol, &
mgcoar, &mgsolv, &mgdisc, &ipc[1], &rpc[1], &pc[1], &ac[1], &cc[1]
, &fc[1], &xf[1], &yf[1], &zf[1], &gxcf[1], &gycf[1], &gzcf[1], &
a1cf[1], &a2cf[1], &a3cf[1], &ccf[1], &fcf[1], &tcf[1]);
/* * */
/* * *** stop timer *** */
tstop_(&bf, &oh, &tsetupc);
s_wsle(&io___59);
do_lio(&c__9, &c__1, "% NEWDRIV2: coarse problem setup time: ", (ftnlen)
39);
do_lio(&c__5, &c__1, (char *)&tsetupc, (ftnlen)sizeof(doublereal));
e_wsle();
/* * */
/* * ****************************************************************** */
/* * *** this overwrites the rhs array provided by pde specification */
/* * ****** compute an algebraically produced rhs for the given tcf *** */
mode = 1;
if (istop == 4 || istop == 5) {
buildalg_(nx, ny, nz, &mode, &nlev, &iz[1], &ipc[1], &rpc[1], &ac[1],
&cc[1], &ccf[1], &tcf[1], &fc[1], &fcf[1]);
}
/* * ****************************************************************** */
/* * */
/* * *** determine machine epsilon *** */
epsiln = epsmac_(&c__0);
/* * */
/* * *** impose zero dirichlet boundary conditions (now in source fcn) *** */
fbound00_(nx, ny, nz, &u[1]);
/* * */
/* * *** MATLAB *** */
s_wsle(&io___62);
do_lio(&c__9, &c__1, " new = [ ", (ftnlen)9);
e_wsle();
/* * */
/* * *** start timer *** */
tstart_(&bf, &oh);
/* * */
/* * *** call specified multigrid method *** */
nlev_real__ = nlev;
iok = 1;
ilev = 1;
if (mgkey == 0) {
newton_(nx, ny, nz, &u[1], &iz[1], &ccf[1], &fcf[1], &w1[1], &w2[1], &
istop, &itmax, &iters, &ierror, &nlev, &ilev, &nlev_real__, &
mgsolv, &iok, &iinfo, &epsiln, &errtol, &omegan, &nu1, &nu2, &
mgsmoo, &a1cf[1], &a2cf[1], &a3cf[1], &ipc[1], &rpc[1], &pc[1]
, &ac[1], &cc[1], &fc[1], &tcf[1]);
} else if (mgkey == 1) {
fnewton_(nx, ny, nz, &u[1], &iz[1], &ccf[1], &fcf[1], &w1[1], &w2[1],
&istop, &itmax, &iters, &ierror, &nlev, &ilev, &nlev_real__, &
mgsolv, &iok, &iinfo, &epsiln, &errtol, &omegan, &nu1, &nu2, &
mgsmoo, &a1cf[1], &a2cf[1], &a3cf[1], &ipc[1], &rpc[1], &pc[1]
, &ac[1], &cc[1], &fc[1], &tcf[1]);
} else {
s_wsle(&io___68);
do_lio(&c__9, &c__1, "% NEWDRIV2: bad mgkey given ", (ftnlen)28);
e_wsle();
}
/* * */
/* * *** stop timer *** */
tstop_(&bf, &oh, &tsolve);
s_wsle(&io___70);
do_lio(&c__9, &c__1, "% NEWDRIV2: solve time: ", (ftnlen)24);
do_lio(&c__5, &c__1, (char *)&tsolve, (ftnlen)sizeof(doublereal));
e_wsle();
/* * */
/* * *** MATLAB *** */
s_wsfe(&io___71);
do_fio(&c__1, "new_sf", (ftnlen)6);
do_fio(&c__1, (char *)&tsetupf, (ftnlen)sizeof(doublereal));
do_fio(&c__1, "new_sc", (ftnlen)6);
do_fio(&c__1, (char *)&tsetupc, (ftnlen)sizeof(doublereal));
do_fio(&c__1, "new_st", (ftnlen)6);
d__1 = tsetupf + tsetupc;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, "new_so", (ftnlen)6);
do_fio(&c__1, (char *)&tsolve, (ftnlen)sizeof(doublereal));
e_wsfe();
/* * */
/* * *** restore boundary conditions *** */
ibound = 1;
fbound_(&ibound, nx, ny, nz, &u[1], &gxcf[1], &gycf[1], &gzcf[1]);
/* * */
/* * *** return and end *** */
return 0;
} /* newdriv2_ */
/* Subroutine */ int inital_()
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_rsle(), do_lio(), e_rsle();
double atan(), sin(), cos();
/* Local variables */
static integer i__, j;
/* Fortran I/O blocks */
static cilist io___17 = { 0, 5, 0, 0, 0 };
static cilist io___18 = { 0, 5, 0, 0, 0 };
static cilist io___19 = { 0, 5, 0, 0, 0 };
static cilist io___20 = { 0, 5, 0, 0, 0 };
static cilist io___21 = { 0, 5, 0, 0, 0 };
static cilist io___22 = { 0, 5, 0, 0, 0 };
static cilist io___23 = { 0, 5, 0, 0, 0 };
static cilist io___24 = { 0, 5, 0, 0, 0 };
static cilist io___25 = { 0, 5, 0, 0, 0 };
/* INITIALIZE CONSTANTS AND ARRAYS */
/* R. K. SATO 4/7/86 */
/* NOTE BELOW THAT TWO DELTA T (TDT) IS SET TO DT ON THE FIRST */
/* CYCLE AFTER WHICH IT IS RESET TO DT+DT. */
/* The following code was in SWM256, however, it was replaced by */
/* READ statements to avoid calculations to be done during */
/* compile time. */
/* DT = 20. */
/* DX = .25E5 */
/* DY = .25E5 */
/* A = 1.E6 */
/* ALPHA = .001 */
/* ITMAX = 1200 */
/* MPRINT = 1200 */
/* M = N1 - 1 */
/* N = N2 - 1 */
s_rsle(&io___17);
do_lio(&c__5, &c__1, (char *)&cons_1.dt, (ftnlen)sizeof(doublereal));
e_rsle();
s_rsle(&io___18);
do_lio(&c__5, &c__1, (char *)&cons_1.dx, (ftnlen)sizeof(doublereal));
e_rsle();
s_rsle(&io___19);
do_lio(&c__5, &c__1, (char *)&cons_1.dy, (ftnlen)sizeof(doublereal));
e_rsle();
s_rsle(&io___20);
do_lio(&c__5, &c__1, (char *)&cons_1.a, (ftnlen)sizeof(doublereal));
e_rsle();
s_rsle(&io___21);
do_lio(&c__5, &c__1, (char *)&cons_1.alpha, (ftnlen)sizeof(doublereal));
e_rsle();
s_rsle(&io___22);
do_lio(&c__3, &c__1, (char *)&cons_1.itmax, (ftnlen)sizeof(integer));
e_rsle();
s_rsle(&io___23);
do_lio(&c__3, &c__1, (char *)&cons_1.mprint, (ftnlen)sizeof(integer));
e_rsle();
s_rsle(&io___24);
do_lio(&c__3, &c__1, (char *)&cons_1.m, (ftnlen)sizeof(integer));
e_rsle();
s_rsle(&io___25);
do_lio(&c__3, &c__1, (char *)&cons_1.n, (ftnlen)sizeof(integer));
e_rsle();
cons_1.tdt = cons_1.dt;
cons_1.mp1 = cons_1.m + 1;
cons_1.np1 = cons_1.n + 1;
cons_1.el = cons_1.n * cons_1.dx;
cons_1.pi = atan(1.) * 4.;
cons_1.tpi = cons_1.pi + cons_1.pi;
cons_1.di = cons_1.tpi / cons_1.m;
cons_1.dj = cons_1.tpi / cons_1.n;
cons_1.pcf = cons_1.pi * cons_1.pi * cons_1.a * cons_1.a / (cons_1.el *
cons_1.el);
/* INITIAL VALUES OF THE STREAM FUNCTION AND P */
i__1 = cons_1.np1;
for (j = 1; j <= i__1; ++j) {
i__2 = cons_1.mp1;
for (i__ = 1; i__ <= i__2; ++i__) {
_BLNK__1.psi[i__ + j * 1335 - 1336] = cons_1.a * sin((i__ - .5) *
cons_1.di) * sin((j - .5) * cons_1.dj);
_BLNK__1.p[i__ + j * 1335 - 1336] = cons_1.pcf * (cos((i__ - 1) *
2. * cons_1.di) + cos((j - 1) * 2. * cons_1.dj)) + 5e4;
/* L50: */
}
}
/* INITIALIZE VELOCITIES */
i__2 = cons_1.n;
#pragma omp parallel for
for (j = 1; j <= i__2; ++j) {
i__1 = cons_1.m;
for (i__ = 1; i__ <= i__1; ++i__) {
_BLNK__1.u[i__ + 1 + j * 1335 - 1336] = -(_BLNK__1.psi[i__ + 1 + (
j + 1) * 1335 - 1336] - _BLNK__1.psi[i__ + 1 + j * 1335 -
1336]) / cons_1.dy;
_BLNK__1.v[i__ + (j + 1) * 1335 - 1336] = (_BLNK__1.psi[i__ + 1 +
(j + 1) * 1335 - 1336] - _BLNK__1.psi[i__ + (j + 1) *
1335 - 1336]) / cons_1.dx;
/* L60: */
}
}
/* PERIODIC CONTINUATION */
i__1 = cons_1.n;
#pragma omp parallel for
for (j = 1; j <= i__1; ++j) {
_BLNK__1.u[j * 1335 - 1335] = _BLNK__1.u[cons_1.m + 1 + j * 1335 -
1336];
_BLNK__1.v[cons_1.m + 1 + (j + 1) * 1335 - 1336] = _BLNK__1.v[(j + 1)
* 1335 - 1335];
/* L70: */
}
i__1 = cons_1.m;
for (i__ = 1; i__ <= i__1; ++i__) {
_BLNK__1.u[i__ + 1 + (cons_1.n + 1) * 1335 - 1336] = _BLNK__1.u[i__];
_BLNK__1.v[i__ - 1] = _BLNK__1.v[i__ + (cons_1.n + 1) * 1335 - 1336];
/* L75: */
}
_BLNK__1.u[(cons_1.n + 1) * 1335 - 1335] = _BLNK__1.u[cons_1.m];
_BLNK__1.v[cons_1.m] = _BLNK__1.v[(cons_1.n + 1) * 1335 - 1335];
i__1 = cons_1.np1;
for (j = 1; j <= i__1; ++j) {
i__2 = cons_1.mp1;
for (i__ = 1; i__ <= i__2; ++i__) {
_BLNK__1.uold[i__ + j * 1335 - 1336] = _BLNK__1.u[i__ + j * 1335
- 1336];
_BLNK__1.vold[i__ + j * 1335 - 1336] = _BLNK__1.v[i__ + j * 1335
- 1336];
_BLNK__1.pold[i__ + j * 1335 - 1336] = _BLNK__1.p[i__ + j * 1335
- 1336];
/* L86: */
}
}
/* END OF INITIALIZATION */
return 0;
} /* inital_ */
/* Subroutine */ int cget35_(real *rmax, integer *lmax, integer *ninfo,
integer *knt, integer *nin)
{
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
complex q__1;
/* Local variables */
complex a[100] /* was [10][10] */, b[100] /* was [10][10] */,
c__[100] /* was [10][10] */;
integer i__, j, m, n;
real vm1[3], vm2[3], dum[1], eps, res, res1;
integer imla, imlb, imlc, info;
complex csav[100] /* was [10][10] */;
integer isgn;
complex atmp[100] /* was [10][10] */, btmp[100] /* was [10][10] */,
ctmp[100] /* was [10][10] */;
real tnrm;
complex rmul;
real xnrm;
integer imlad;
real scale;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
char trana[1], tranb[1];
extern /* Subroutine */ int slabad_(real *, real *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
integer itrana, itranb;
real bignum, smlnum;
extern /* Subroutine */ int ctrsyl_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, real *, integer *);
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, 0, 0 };
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGET35 tests CTRSYL, a routine for solving the Sylvester matrix */
/* equation */
/* op(A)*X + ISGN*X*op(B) = scale*C, */
/* A and B are assumed to be in Schur canonical form, op() represents an */
/* optional transpose, and ISGN can be -1 or +1. Scale is an output */
/* less than or equal to 1, chosen to avoid overflow in X. */
/* The test code verifies that the following residual is order 1: */
/* norm(op(A)*X + ISGN*X*op(B) - scale*C) / */
/* (EPS*max(norm(A),norm(B))*norm(X)) */
/* Arguments */
/* ========== */
/* RMAX (output) REAL */
/* Value of the largest test ratio. */
/* LMAX (output) INTEGER */
/* Example number where largest test ratio achieved. */
/* NINFO (output) INTEGER */
/* Number of examples where INFO is nonzero. */
/* KNT (output) INTEGER */
/* Total number of examples tested. */
/* NIN (input) INTEGER */
/* Input logical unit number. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Get machine parameters */
eps = slamch_("P");
smlnum = slamch_("S") / eps;
bignum = 1.f / smlnum;
slabad_(&smlnum, &bignum);
/* Set up test case parameters */
vm1[0] = sqrt(smlnum);
vm1[1] = 1.f;
vm1[2] = 1e6f;
vm2[0] = 1.f;
vm2[1] = eps * 2.f + 1.f;
vm2[2] = 2.f;
*knt = 0;
*ninfo = 0;
*lmax = 0;
*rmax = 0.f;
/* Begin test loop */
L10:
io___6.ciunit = *nin;
s_rsle(&io___6);
do_lio(&c__3, &c__1, (char *)&m, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&n, (ftnlen)sizeof(integer));
e_rsle();
if (n == 0) {
return 0;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
io___10.ciunit = *nin;
s_rsle(&io___10);
i__2 = m;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&atmp[i__ + j * 10 - 11], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = *nin;
s_rsle(&io___13);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&btmp[i__ + j * 10 - 11], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L30: */
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = *nin;
s_rsle(&io___15);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__6, &c__1, (char *)&ctmp[i__ + j * 10 - 11], (ftnlen)
sizeof(complex));
}
e_rsle();
/* L40: */
}
for (imla = 1; imla <= 3; ++imla) {
for (imlad = 1; imlad <= 3; ++imlad) {
for (imlb = 1; imlb <= 3; ++imlb) {
for (imlc = 1; imlc <= 3; ++imlc) {
for (itrana = 1; itrana <= 2; ++itrana) {
for (itranb = 1; itranb <= 2; ++itranb) {
for (isgn = -1; isgn <= 1; isgn += 2) {
if (itrana == 1) {
*(unsigned char *)trana = 'N';
}
if (itrana == 2) {
*(unsigned char *)trana = 'C';
}
if (itranb == 1) {
*(unsigned char *)tranb = 'N';
}
if (itranb == 2) {
*(unsigned char *)tranb = 'C';
}
tnrm = 0.f;
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = m;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 10 - 11;
i__4 = i__ + j * 10 - 11;
i__5 = imla - 1;
q__1.r = vm1[i__5] * atmp[i__4].r,
q__1.i = vm1[i__5] * atmp[
i__4].i;
a[i__3].r = q__1.r, a[i__3].i =
q__1.i;
/* Computing MAX */
r__1 = tnrm, r__2 = c_abs(&a[i__ + j *
10 - 11]);
tnrm = dmax(r__1,r__2);
/* L50: */
}
i__2 = i__ + i__ * 10 - 11;
i__3 = i__ + i__ * 10 - 11;
i__4 = imlad - 1;
q__1.r = vm2[i__4] * a[i__3].r, q__1.i =
vm2[i__4] * a[i__3].i;
a[i__2].r = q__1.r, a[i__2].i = q__1.i;
/* Computing MAX */
r__1 = tnrm, r__2 = c_abs(&a[i__ + i__ *
10 - 11]);
tnrm = dmax(r__1,r__2);
/* L60: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 10 - 11;
i__4 = i__ + j * 10 - 11;
i__5 = imlb - 1;
q__1.r = vm1[i__5] * btmp[i__4].r,
q__1.i = vm1[i__5] * btmp[
i__4].i;
b[i__3].r = q__1.r, b[i__3].i =
q__1.i;
/* Computing MAX */
r__1 = tnrm, r__2 = c_abs(&b[i__ + j *
10 - 11]);
tnrm = dmax(r__1,r__2);
/* L70: */
}
/* L80: */
}
if (tnrm == 0.f) {
tnrm = 1.f;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 10 - 11;
i__4 = i__ + j * 10 - 11;
i__5 = imlc - 1;
q__1.r = vm1[i__5] * ctmp[i__4].r,
q__1.i = vm1[i__5] * ctmp[
i__4].i;
c__[i__3].r = q__1.r, c__[i__3].i =
q__1.i;
i__3 = i__ + j * 10 - 11;
i__4 = i__ + j * 10 - 11;
csav[i__3].r = c__[i__4].r, csav[i__3]
.i = c__[i__4].i;
/* L90: */
}
/* L100: */
}
++(*knt);
ctrsyl_(trana, tranb, &isgn, &m, &n, a, &
c__10, b, &c__10, c__, &c__10, &scale,
&info);
if (info != 0) {
++(*ninfo);
}
xnrm = clange_("M", &m, &n, c__, &c__10, dum);
rmul.r = 1.f, rmul.i = 0.f;
if (xnrm > 1.f && tnrm > 1.f) {
if (xnrm > bignum / tnrm) {
r__1 = dmax(xnrm,tnrm);
rmul.r = r__1, rmul.i = 0.f;
c_div(&q__1, &c_b43, &rmul);
rmul.r = q__1.r, rmul.i = q__1.i;
}
}
r__1 = -scale;
q__1.r = r__1 * rmul.r, q__1.i = r__1 *
rmul.i;
cgemm_(trana, "N", &m, &n, &m, &rmul, a, &
c__10, c__, &c__10, &q__1, csav, &
c__10);
r__1 = (real) isgn;
q__1.r = r__1 * rmul.r, q__1.i = r__1 *
rmul.i;
cgemm_("N", tranb, &m, &n, &n, &q__1, c__, &
c__10, b, &c__10, &c_b43, csav, &
c__10);
res1 = clange_("M", &m, &n, csav, &c__10, dum);
/* Computing MAX */
r__1 = smlnum, r__2 = smlnum * xnrm, r__1 =
max(r__1,r__2), r__2 = c_abs(&rmul) *
tnrm * eps * xnrm;
res = res1 / dmax(r__1,r__2);
if (res > *rmax) {
*lmax = *knt;
*rmax = res;
}
/* L110: */
}
/* L120: */
}
/* L130: */
}
/* L140: */
}
/* L150: */
}
/* L160: */
}
/* L170: */
}
goto L10;
/* End of CGET35 */
} /* cget35_ */
/* *** */
/* Main program */ void swim(void)
{
/* Format strings */
static char fmt_390[] = "(\002 NUMBER OF POINTS IN THE X DIRECTION\002,i\
8/\002 NUMBER OF POINTS IN THE Y DIRECTION\002,i8/\002 GRID SPACING IN THE X\
DIRECTION \002,f8.0/\002 GRID SPACING IN THE Y DIRECTION \002,f8.0\
/\002 TIME STEP \002,f8.0/\002 TIME FILTER PARAMETE\
R \002,f8.3/\002 NUMBER OF ITERATIONS \002,i8)";
static char fmt_350[] = "(/\002 CYCLE NUMBER\002,i5,\002 MODEL TIME IN \
HOURS\002,f6.2)";
static char fmt_360[] = "(/\002 DIAGONAL ELEMENTS OF U \002,//(8e15.7))";
static char fmt_366[] = "(/,\002 Pcheck = \002,e12.4,/,\002 Ucheck = \
\002,e12.4,/,\002 Vcheck = \002,e12.4,/)";
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
olist o__1;
/* Builtin functions */
integer s_wsle(), do_lio(), e_wsle(), f_open(), s_wsfe(), do_fio(),
e_wsfe();
/* Subroutine */ int s_stop();
/* Local variables */
static integer i__;
static doublereal time;
extern /* Subroutine */ int calc1_(), calc2_(), calc3_();
static integer mnmin;
static doublereal ptime;
extern /* Subroutine */ int calc3z_();
static integer icheck, jcheck;
static doublereal pcheck, ucheck, vcheck;
static integer ncycle;
extern /* Subroutine */ int inital_();
/* Fortran I/O blocks */
static cilist io___1 = { 0, 6, 0, 0, 0 };
static cilist io___2 = { 0, 6, 0, 0, 0 };
static cilist io___3 = { 0, 6, 0, fmt_390, 0 };
static cilist io___8 = { 0, 7, 0, fmt_350, 0 };
static cilist io___9 = { 0, 7, 0, fmt_360, 0 };
static cilist io___16 = { 0, 6, 0, fmt_366, 0 };
/* BENCHMARK WEATHER PREDICTION PROGRAM FOR COMPARING THE */
/* PREFORMANCE OF CURRENT SUPERCOMPUTERS. THE MODEL IS */
/* BASED OF THE PAPER - THE DYNAMICS OF FINITE-DIFFERENCE */
/* MODELS OF THE SHALLOW-WATER EQUATIONS, BY ROBERT SADOURNY */
/* J. ATM. SCIENCES, VOL 32, NO 4, APRIL 1975. */
/* CODE BY PAUL N. SWARZTRAUBER, NATIONAL CENTER FOR */
/* ATMOSPHERIC RESEARCH, BOULDER, CO, OCTOBER 1984. */
/* MODIFIED BY R. K. SATO, NCAR, APRIL 7, 1986 FOR MULTITASKING. */
/* MODIFIED FOR SPEC to run longer: ITMAX inCremented from 120 to */
/* 1200 - J.Lo 7/19/90 */
/* Modified by Bodo Parady for the SPECpar suite. Various */
/* compilation sizes added. Iterations reduced to orginal */
/* problem, but size increased 4x in each dimension. */
/* Further modified by Reinhold Weicker (Siemens Nixdorf) for the */
/* SPEC CFP95 suite: */
/* Changed back to the form with PARAMETER statements for */
/* N1 and N2, set N1 = N2 = 1335. */
/* The execution time is determined by these values and the */
/* variable ITMAX (number of iterations) read from the input file. */
/* Execution time is linear in ITMAX. */
/* PARAMETER (N1=1061, N2=1061) */
s_wsle(&io___1);
do_lio(&c__9, &c__1, " SPEC benchmark 171.swim", (ftnlen)24);
e_wsle();
s_wsle(&io___2);
do_lio(&c__9, &c__1, " ", (ftnlen)1);
e_wsle();
o__1.oerr = 0;
o__1.ounit = 7;
o__1.ofnmlen = 5;
o__1.ofnm = "SWIM7";
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
/* REQUEST PROCESSORS FOR MICROTASKING */
/* SPEC removed CMIC$ GETCPUS 4 */
/* INITIALIZE CONSTANTS AND ARRAYS */
inital_();
/* PRINT INITIAL VALUES */
s_wsfe(&io___3);
do_fio(&c__1, (char *)&cons_1.n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&cons_1.m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&cons_1.dx, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&cons_1.dy, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&cons_1.dt, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&cons_1.alpha, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&cons_1.itmax, (ftnlen)sizeof(integer));
e_wsfe();
mnmin = min(cons_1.m,cons_1.n);
/* initial data writes removed for SPEC */
/* WRITE(6,391) (POLD(I,I),I=1,MNMIN) */
/* 391 FORMAT(/' INITIAL DIAGONAL ELEMENTS OF P ', //(8E15.7)) */
/* WRITE(6,392) (UOLD(I,I),I=1,MNMIN) */
/* 392 FORMAT(/' INITIAL DIAGONAL ELEMENTS OF U ', //(8E15.7)) */
/* WRITE(6,393) (VOLD(I,I),I=1,MNMIN) */
/* 393 FORMAT(/' INITIAL DIAGONAL ELEMENTS OF V ', //(8E15.7)) */
/* DETERMINE OVERHEAD OF TIMING CALLS */
/* 6/22/95 for SPEC: JWR: Initialization of TIME */
time = 0.;
ncycle = 0;
L90:
++ncycle;
/* COMPUTE CAPITAL U, CAPITAL V, Z AND H */
calc1_();
/* COMPUTE NEW VALUES U,V AND P */
calc2_();
time += cons_1.dt;
if (ncycle % cons_1.mprint != 0) {
goto L370;
}
ptime = time / (float)3600.;
/* *** modified for SPEC results verification */
/* *** We want to ensure that all calculations were done */
/* *** so we "use" all of the computed results. */
/* *** */
/* *** Since all of the comparisons of the individual diagnal terms */
/* *** often differ in the smaller values, the check we have selected */
/* *** is to add the absolute values of all terms and print these results */
s_wsfe(&io___8);
do_fio(&c__1, (char *)&ncycle, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ptime, (ftnlen)sizeof(doublereal));
e_wsfe();
s_wsfe(&io___9);
i__1 = mnmin;
for (i__ = 1; i__ <= i__1; i__ += 10) {
do_fio(&c__1, (char *)&_BLNK__1.unew[i__ + i__ * 1335 - 1336], (
ftnlen)sizeof(doublereal));
}
e_wsfe();
/* *** */
pcheck = 0.;
ucheck = 0.;
vcheck = 0.;
i__1 = mnmin;
for (icheck = 1; icheck <= i__1; ++icheck) {
i__2 = mnmin;
for (jcheck = 1; jcheck <= i__2; ++jcheck) {
pcheck += (d__1 = _BLNK__1.pnew[icheck + jcheck * 1335 - 1336],
abs(d__1));
ucheck += (d__1 = _BLNK__1.unew[icheck + jcheck * 1335 - 1336],
abs(d__1));
vcheck += (d__1 = _BLNK__1.vnew[icheck + jcheck * 1335 - 1336],
abs(d__1));
/* L4500: */
}
_BLNK__1.unew[icheck + icheck * 1335 - 1336] *= icheck % 100 / (float)
100.;
/* L3500: */
}
/* *** */
/* *** */
s_wsfe(&io___16);
do_fio(&c__1, (char *)&pcheck, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ucheck, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&vcheck, (ftnlen)sizeof(doublereal));
e_wsfe();
L370:
/* TEST FOR END OF RUN */
if (ncycle >= cons_1.itmax) {
s_stop("", (ftnlen)0);
}
/* TIME SMOOTHING AND UPDATE FOR NEXT CYCLE */
if (ncycle <= 1) {
calc3z_();
} else {
calc3_();
}
goto L90;
} /* MAIN__ */
/* Subroutine */ int initsv_(integer *indeps)
{
/* Initialized data */
static doublereal rvdw[53] = { 1.08,1.,1.8,999.,999.,1.53,1.48,1.36,1.3,
999.,2.3,999.,2.05,2.1,1.75,1.7,1.65,999.,2.8,2.75,999.,999.,999.,
999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,1.8,999.,
999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,999.,
999.,999.,999.,2.05 };
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer i_indx(char *, char *, ftnlen, ftnlen), i_dnnt(doublereal *);
double log(doublereal);
integer pow_ii(integer *, integer *);
/* Local variables */
static integer i__, n;
static doublereal x;
static integer i4;
static doublereal x0, z3, z4;
#define iw ((integer *)&chanel_1 + 5)
static integer iat;
static doublereal epsi, avdw;
extern doublereal reada_(char *, integer *, ftnlen);
static doublereal delsc, disex;
#define dirsm ((doublereal *)&solv_1 + 1325)
static doublereal rsolv;
static integer indels, indise;
extern /* Subroutine */ int dvfill_(integer *, doublereal *);
#define dirsmh ((doublereal *)&solv_1 + 4571)
static integer maxnps, inrsol;
static doublereal usevdw[53];
/* Fortran I/O blocks */
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
for (i__ = 1; i__ <= 53; ++i__) {
/* L10: */
usevdw[i__ - 1] = rvdw[i__ - 1];
}
epsi = reada_(keywrd_1.keywrd, indeps, (ftnlen)241);
solv_1.fepsi = (epsi - 1.) / (epsi + .5);
solvps_1.nps = 0;
*iw = 6;
solv_1.nden = molkst_1.norbs * 3 - (molkst_1.numat << 1);
maxnps = sqrt(324000.25099999999f) - solv_1.nden - .5f;
maxnps = min(maxnps,400);
/* WRITE(IW,*) 'MAXIMUM NUMBER OF SEGMENTS ALLOWED:',MAXNPS */
if (solv_1.nden * (solv_1.nden + 1) / 2 > 162000) {
io___10.ciunit = *iw;
s_wsle(&io___10);
do_lio(&c__9, &c__1, "PARAMETER LENABC IS TOO SMALL FOR THIS SYSTEM",
(ftnlen)45);
e_wsle();
s_stop("PARAMETER LENABC IS TOO SMALL FOR THIS SYSTEM", (ftnlen)45);
}
rsolv = 1.;
inrsol = i_indx(keywrd_1.keywrd, "RSOLV=", (ftnlen)241, (ftnlen)6);
if (inrsol != 0) {
rsolv = reada_(keywrd_1.keywrd, &inrsol, (ftnlen)241);
}
if (rsolv < 0.f) {
s_stop(" RSOLV MUST NOT BE NEGATIVE", (ftnlen)27);
}
delsc = rsolv;
indels = i_indx(keywrd_1.keywrd, "DELSC=", (ftnlen)241, (ftnlen)6);
if (indels != 0) {
delsc = reada_(keywrd_1.keywrd, &indels, (ftnlen)241);
}
if (delsc < .1) {
io___15.ciunit = *iw;
s_wsle(&io___15);
do_lio(&c__9, &c__1, " DELSC TOO SMALL: SET TO 0.1", (ftnlen)28);
e_wsle();
}
if (delsc > rsolv + .5) {
s_stop(" DELSC UNREASONABLY LARGE", (ftnlen)25);
}
solv_1.rds = max(delsc,.1);
disex = 2.;
indise = i_indx(keywrd_1.keywrd, "DISEX=", (ftnlen)241, (ftnlen)6);
if (indise != 0) {
disex = reada_(keywrd_1.keywrd, &indise, (ftnlen)241);
}
i__1 = molkst_1.numat;
for (i__ = 1; i__ <= i__1; ++i__) {
iat = molkst_1.nat[i__ - 1];
if (iat > 53) {
s_stop("MISSING VAN DER WAALS RADIUS", (ftnlen)28);
} else {
avdw = usevdw[iat - 1];
if (avdw > 10.) {
s_stop("MISSING VAN DER WAALS RADIUS", (ftnlen)28);
}
}
solv_1.srad[i__ - 1] = avdw + rsolv;
/* L20: */
}
solv_1.nspa = 60;
if (i_indx(keywrd_1.keywrd, "NSPA=", (ftnlen)241, (ftnlen)5) != 0) {
i__1 = i_indx(keywrd_1.keywrd, "NSPA", (ftnlen)241, (ftnlen)4);
d__1 = reada_(keywrd_1.keywrd, &i__1, (ftnlen)241);
solv_1.nspa = i_dnnt(&d__1);
}
x0 = log(solv_1.nspa * .1 - .199999);
z3 = log(3.);
z4 = log(4.);
i4 = (integer) (x0 / z4);
solvps_1.nps2 = 0;
i__1 = i4;
for (i__ = 0; i__ <= i__1; ++i__) {
x = x0 - i__ * z4;
i__2 = (integer) (x / z3);
n = pow_ii(&c__3, &i__2) * pow_ii(&c__4, &i__);
/* L7: */
if (n > solvps_1.nps2) {
solvps_1.nps2 = n;
}
}
solvps_1.nps = solvps_1.nps2 / 3;
if (solvps_1.nps2 % 3 != 0) {
solvps_1.nps = solvps_1.nps2 / 4;
}
solvps_1.nps2 = solvps_1.nps2 * 10 + 2;
/* Computing MAX */
i__1 = 12, i__2 = solvps_1.nps * 10 + 2;
solvps_1.nps = max(i__1,i__2);
dvfill_(&solvps_1.nps2, dirsm);
dvfill_(&solvps_1.nps, dirsmh);
solvps_1.nps = -solvps_1.nps;
/* Computing 2nd power */
d__1 = (rsolv + 1.5 - solv_1.rds) * 4 * disex;
solv_1.disex2 = d__1 * d__1 / solv_1.nspa;
dvfill_(&c__1082, dirvec_1.dirvec);
return 0;
} /* initsv_ */
/* Subroutine */ int deri1_(doublereal *c__, integer *norbs, doublereal *
coord, integer *number, doublereal *work, doublereal *grad,
doublereal *f, integer *minear, doublereal *fd, doublereal *wmat,
doublereal *hmat, doublereal *fmat)
{
/* Initialized data */
static integer icalcn = 0;
/* System generated locals */
integer c_dim1, c_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4,
i__5, i__6, i__7, i__8;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), s_wsle(cilist *), do_lio(
integer *, integer *, char *, ftnlen), e_wsle(void), s_wsfe(
cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, j, k, l, n1, n2, ll;
static doublereal gse;
extern doublereal dot_(doublereal *, doublereal *, integer *);
extern /* Subroutine */ int mxm_(doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
static integer nend, nati, lcut, loop, natx;
static doublereal step;
static integer iprt;
extern /* Subroutine */ int mtxm_(doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), mecid_(doublereal *,
doublereal *, doublereal *, doublereal *), mecih_(doublereal *,
doublereal *, integer *, integer *);
static logical debug;
extern /* Subroutine */ int timer_(char *, ftnlen);
static integer ninit;
extern /* Subroutine */ int scopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dfock2_(doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
integer *, integer *), dijkl1_(doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *);
static doublereal enucl2;
extern /* Subroutine */ int dhcore_(doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, doublereal *);
extern doublereal helect_(integer *, doublereal *, doublereal *,
doublereal *);
static integer linear;
extern /* Subroutine */ int supdot_(doublereal *, doublereal *,
doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___13 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, "(' * * * GRADIENT COMPONENT NUMBER',"
"I4)", 0 };
static cilist io___24 = { 0, 0, 0, "(' NON-RELAXED C.I-ACTIVE FOCK EIGEN"
"VALUES ', 'DERIVATIVES (E.V.)')", 0 };
static cilist io___25 = { 0, 0, 0, "(8F10.4)", 0 };
static cilist io___26 = { 0, 0, 0, "(' NON-RELAXED 2-ELECTRONS DERIVATIV"
"ES (E.V.)'/ ' I J K L d<I(1)J(1)|K(2)L(2)>')",
0 };
static cilist io___28 = { 0, 0, 0, "(4I5,F20.10)", 0 };
static cilist io___29 = { 0, 0, 0, "(' NON-RELAXED GRADIENT COMPONENT',F"
"10.4, ' KCAL/MOLE')", 0 };
/* COMDECK SIZES */
/* *********************************************************************** */
/* THIS FILE CONTAINS ALL THE ARRAY SIZES FOR USE IN MOPAC. */
/* THERE ARE ONLY 5 PARAMETERS THAT THE PROGRAMMER NEED SET: */
/* MAXHEV = MAXIMUM NUMBER OF HEAVY ATOMS (HEAVY: NON-HYDROGEN ATOMS) */
/* MAXLIT = MAXIMUM NUMBER OF HYDROGEN ATOMS. */
/* MAXTIM = DEFAULT TIME FOR A JOB. (SECONDS) */
/* MAXDMP = DEFAULT TIME FOR AUTOMATIC RESTART FILE GENERATION (SECS) */
/* ISYBYL = 1 IF MOPAC IS TO BE USED IN THE SYBYL PACKAGE, =0 OTHERWISE */
/* SEE ALSO NMECI, NPULAY AND MESP AT THE END OF THIS FILE */
/* *********************************************************************** */
/* THE FOLLOWING CODE DOES NOT NEED TO BE ALTERED BY THE PROGRAMMER */
/* *********************************************************************** */
/* ALL OTHER PARAMETERS ARE DERIVED FUNCTIONS OF THESE TWO PARAMETERS */
/* NAME DEFINITION */
/* NUMATM MAXIMUM NUMBER OF ATOMS ALLOWED. */
/* MAXORB MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXPAR MAXIMUM NUMBER OF PARAMETERS FOR OPTIMISATION. */
/* N2ELEC MAXIMUM NUMBER OF TWO ELECTRON INTEGRALS ALLOWED. */
/* MPACK AREA OF LOWER HALF TRIANGLE OF DENSITY MATRIX. */
/* MORB2 SQUARE OF THE MAXIMUM NUMBER OF ORBITALS ALLOWED. */
/* MAXHES AREA OF HESSIAN MATRIX */
/* MAXALL LARGER THAN MAXORB OR MAXPAR. */
/* *********************************************************************** */
/* *********************************************************************** */
/* DECK MOPAC */
/* ******************************************************************** */
/* DERI1 COMPUTE THE NON-RELAXED DERIVATIVE OF THE NON-VARIATIONALLY */
/* OPTIMIZED WAVEFUNCTION ENERGY WITH RESPECT TO ONE CARTESIAN */
/* COORDINATE AT A TIME */
/* AND */
/* COMPUTE THE NON-RELAXED FOCK MATRIX DERIVATIVE IN M.O BASIS AS */
/* REQUIRED IN THE RELAXATION SECTION (ROUTINE 'DERI2'). */
/* INPUT */
/* C(NORBS,NORBS) : M.O. COEFFICIENTS. */
/* COORD : CARTESIAN COORDINATES ARRAY. */
/* NUMBER : LOCATION OF THE REQUIRED VARIABLE IN COORD. */
/* WORK : WORK ARRAY OF SIZE N*N. */
/* WMAT : WORK ARRAYS FOR d<PQ|RS> (2-CENTERS A.O) */
/* OUTPUT */
/* C,COORD,NUMBER : NOT MODIFIED. */
/* GRAD : DERIVATIVE OF THE HEAT OF FORMATION WITH RESPECT TO */
/* COORD(NUMBER), WITHOUT RELAXATION CORRECTION. */
/* F(MINEAR) : NON-RELAXED FOCK MATRIX DERIVATIVE WITH RESPECT TO */
/* COORD(NUMBER), EXPRESSED IN M.O BASIS, SCALED AND */
/* PACKED, OFF-DIAGONAL BLOCKS ONLY. */
/* FD : IDEM BUT UNSCALED, DIAGONAL BLOCKS, C.I-ACTIVE ONLY. */
/* *********************************************************************** */
/* Parameter adjustments */
work_dim1 = *norbs;
work_offset = 1 + work_dim1 * 1;
work -= work_offset;
c_dim1 = *norbs;
c_offset = 1 + c_dim1 * 1;
c__ -= c_offset;
--coord;
--f;
--fd;
--wmat;
--hmat;
--fmat;
/* Function Body */
if (icalcn != numcal_1.numcal) {
debug = i_indx(keywrd_1.keywrd, "DERI1", (ftnlen)241, (ftnlen)5) != 0;
iprt = 6;
linear = *norbs * (*norbs + 1) / 2;
icalcn = numcal_1.numcal;
}
if (debug) {
timer_("BEFORE DERI1", (ftnlen)12);
}
step = .001;
/* 2 POINTS FINITE DIFFERENCE TO GET THE INTEGRAL DERIVATIVES */
/* ---------------------------------------------------------- */
/* STORED IN HMAT AND WMAT, WITHOUT DIVIDING BY THE STEP SIZE. */
nati = (*number - 1) / 3 + 1;
natx = *number - (nati - 1) * 3;
dhcore_(&coord[1], &hmat[1], &wmat[1], &enucl2, &nati, &natx, &step);
/* HMAT HOLDS THE ONE-ELECTRON DERIVATIVES OF ATOM NATI FOR DIRECTION */
/* NATX W.R.T. ALL OTHER ATOMS */
/* WMAT HOLDS THE TWO-ELECTRON DERIVATIVES OF ATOM NATI FOR DIRECTION */
/* NATX W.R.T. ALL OTHER ATOMS */
step = .5 / step;
/* NON-RELAXED FOCK MATRIX DERIVATIVE IN A.O BASIS. */
/* ------------------------------------------------ */
/* STORED IN FMAT, DIVIDED BY STEP. */
scopy_(&linear, &hmat[1], &c__1, &fmat[1], &c__1);
dfock2_(&fmat[1], densty_1.p, densty_1.pa, &wmat[1], &molkst_1.numat,
molkst_1.nfirst, molkst_1.nmidle, molkst_1.nlast, &nati);
/* FMAT HOLDS THE ONE PLUS TWO - ELECTRON DERIVATIVES OF ATOM NATI FOR */
/* DIRECTION NATX W.R.T. ALL OTHER ATOMS */
/* DERIVATIVE OF THE SCF-ONLY ENERGY (I.E BEFORE C.I CORRECTION) */
*grad = (helect_(norbs, densty_1.p, &hmat[1], &fmat[1]) + enucl2) * step;
/* TAKE STEP INTO ACCOUNT IN FMAT */
i__1 = linear;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L10: */
fmat[i__] *= step;
}
/* RIGHT-HAND SIDE SUPER-VECTOR F = C' FMAT C USED IN RELAXATION */
/* ----------------------------------------------------------- */
/* STORED IN NON-STANDARD PACKED FORM IN F(MINEAR) AND FD. */
/* THE SUPERVECTOR IS THE NON-RELAXED FOCK MATRIX DERIVATIVE IN */
/* M.O BASIS: F(IJ)= ( (C' * FOCK * C)(I,J) ) WITH I.GT.J . */
/* F IS SCALED AND PACKED IN SUPERVECTOR FORM WITH */
/* THE CONSECUTIVE FOLLOWING OFF-DIAGONAL BLOCKS: */
/* 1) OPEN-CLOSED I.E. F(IJ)=F(I,J) WITH I OPEN & J CLOSED */
/* AND I RUNNING FASTER THAN J, */
/* 2) VIRTUAL-CLOSED SAME RULE OF ORDERING, */
/* 3) VIRTUAL-OPEN SAME RULE OF ORDERING. */
/* FD IS PACKED OVER THE C.I-ACTIVE M.O WITH */
/* THE CONSECUTIVE DIAGONAL BLOCKS: */
/* 1) CLOSED-CLOSED IN CANONICAL ORDER, WITHOUT THE */
/* DIAGONAL ELEMENTS, */
/* 2) OPEN-OPEN SAME RULE OF ORDERING, */
/* 3) VIRTUAL-VIRTUAL SAME RULE OF ORDERING. */
/* PART 1 : WORK(N,N) = FMAT(N,N) * C(N,N) */
i__1 = *norbs;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
supdot_(&work[i__ * work_dim1 + 1], &fmat[1], &c__[i__ * c_dim1 + 1],
norbs, &c__1);
}
/* PART 2 : F(IJ) = (C' * WORK)(I,J) ... OFF-DIAGONAL BLOCKS. */
l = 1;
if (cibits_1.nbo[1] != 0 && cibits_1.nbo[0] != 0) {
/* OPEN-CLOSED */
mtxm_(&c__[(cibits_1.nbo[0] + 1) * c_dim1 + 1], &cibits_1.nbo[1], &
work[work_offset], norbs, &f[l], cibits_1.nbo);
l += cibits_1.nbo[1] * cibits_1.nbo[0];
}
if (cibits_1.nbo[2] != 0 && cibits_1.nbo[0] != 0) {
/* VIRTUAL-CLOSED */
mtxm_(&c__[(molkst_1.nopen + 1) * c_dim1 + 1], &cibits_1.nbo[2], &
work[work_offset], norbs, &f[l], cibits_1.nbo);
l += cibits_1.nbo[2] * cibits_1.nbo[0];
}
if (cibits_1.nbo[2] != 0 && cibits_1.nbo[1] != 0) {
/* VIRTUAL-OPEN */
mtxm_(&c__[(molkst_1.nopen + 1) * c_dim1 + 1], &cibits_1.nbo[2], &
work[(cibits_1.nbo[0] + 1) * work_dim1 + 1], norbs, &f[l], &
cibits_1.nbo[1]);
}
/* SCALE F ACCORDING TO THE DIAGONAL METRIC TENSOR 'SCALAR '. */
i__1 = *minear;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L30: */
f[i__] *= fokmat_1.scalar[i__ - 1];
}
if (debug) {
s_wsle(&io___11);
do_lio(&c__9, &c__1, " F IN DERI1", (ftnlen)11);
e_wsle();
j = min(20,*minear);
s_wsfe(&io___13);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&f[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
}
/* PART 3 : SUPER-VECTOR FD, C.I-ACTIVE DIAGONAL BLOCKS, UNSCALED. */
l = 1;
nend = 0;
for (loop = 1; loop <= 3; ++loop) {
ninit = nend + 1;
nend += cibits_1.nbo[loop - 1];
/* Computing MAX */
i__1 = ninit, i__2 = cibits_1.nelec + 1;
n1 = max(i__1,i__2);
/* Computing MIN */
i__1 = nend, i__2 = cibits_1.nelec + cibits_1.nmos;
n2 = min(i__1,i__2);
if (n2 < n1) {
goto L50;
}
i__1 = n2;
for (i__ = n1; i__ <= i__1; ++i__) {
if (i__ > ninit) {
i__2 = i__ - ninit;
mxm_(&c__[i__ * c_dim1 + 1], &c__1, &work[ninit * work_dim1 +
1], norbs, &fd[l], &i__2);
l = l + i__ - ninit;
}
/* L40: */
}
L50:
;
}
/* NON-RELAXED C.I CORRECTION TO THE ENERGY DERIVATIVE. */
/* ---------------------------------------------------- */
/* C.I-ACTIVE FOCK EIGENVALUES DERIVATIVES, STORED IN FD(CONTINUED). */
lcut = l;
i__1 = cibits_1.nelec + cibits_1.nmos;
for (i__ = cibits_1.nelec + 1; i__ <= i__1; ++i__) {
fd[l] = dot_(&c__[i__ * c_dim1 + 1], &work[i__ * work_dim1 + 1],
norbs);
/* L60: */
++l;
}
/* C.I-ACTIVE 2-ELECTRONS INTEGRALS DERIVATIVES. STORED IN XY. */
/* FMAT IS USED HERE AS SCRATCH SPACE */
dijkl1_(&c__[(cibits_1.nelec + 1) * c_dim1 + 1], norbs, &nati, &wmat[1], &
fmat[1], &hmat[1], &fmat[1]);
i__1 = cibits_1.nmos;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = cibits_1.nmos;
for (j = 1; j <= i__2; ++j) {
i__3 = cibits_1.nmos;
for (k = 1; k <= i__3; ++k) {
i__4 = cibits_1.nmos;
for (l = 1; l <= i__4; ++l) {
/* L70: */
xyijkl_1.xy[i__ + (j + (k + (l << 3) << 3) << 3) - 585] *=
step;
}
}
}
}
/* BUILD THE C.I MATRIX DERIVATIVE, STORED IN WMAT. */
mecid_(&fd[lcut - cibits_1.nelec], &gse, vector_1.eigb, &work[work_offset]
);
if (debug) {
s_wsle(&io___22);
do_lio(&c__9, &c__1, " GSE:", (ftnlen)5);
do_lio(&c__5, &c__1, (char *)&gse, (ftnlen)sizeof(doublereal));
e_wsle();
/* # WRITE(6,*)' EIGB:',(EIGB(I),I=1,10) */
/* # WRITE(6,*)' WORK:',(WORK(I,1),I=1,10) */
}
mecih_(&work[work_offset], &wmat[1], &cibits_1.nmos, &cibits_1.lab);
/* NON-RELAXED C.I CONTRIBUTION TO THE ENERGY DERIVATIVE. */
supdot_(&work[work_offset], &wmat[1], civect_1.conf, &cibits_1.lab, &c__1)
;
*grad = (*grad + dot_(civect_1.conf, &work[work_offset], &cibits_1.lab)) *
23.061;
if (debug) {
io___23.ciunit = iprt;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&(*number), (ftnlen)sizeof(integer));
e_wsfe();
io___24.ciunit = iprt;
s_wsfe(&io___24);
e_wsfe();
io___25.ciunit = iprt;
s_wsfe(&io___25);
i__4 = cibits_1.nmos;
for (i__ = 1; i__ <= i__4; ++i__) {
do_fio(&c__1, (char *)&fd[lcut - 1 + i__], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
io___26.ciunit = iprt;
s_wsfe(&io___26);
e_wsfe();
i__4 = cibits_1.nmos;
for (i__ = 1; i__ <= i__4; ++i__) {
i__3 = i__;
for (j = 1; j <= i__3; ++j) {
i__2 = i__;
for (k = 1; k <= i__2; ++k) {
ll = k;
if (k == i__) {
ll = j;
}
i__1 = ll;
for (l = 1; l <= i__1; ++l) {
/* L80: */
io___28.ciunit = iprt;
s_wsfe(&io___28);
i__5 = cibits_1.nelec + i__;
do_fio(&c__1, (char *)&i__5, (ftnlen)sizeof(integer));
i__6 = cibits_1.nelec + j;
do_fio(&c__1, (char *)&i__6, (ftnlen)sizeof(integer));
i__7 = cibits_1.nelec + k;
do_fio(&c__1, (char *)&i__7, (ftnlen)sizeof(integer));
i__8 = cibits_1.nelec + l;
do_fio(&c__1, (char *)&i__8, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&xyijkl_1.xy[i__ + (j + (k + (l
<< 3) << 3) << 3) - 585], (ftnlen)sizeof(
doublereal));
e_wsfe();
}
}
}
}
io___29.ciunit = iprt;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&(*grad), (ftnlen)sizeof(doublereal));
e_wsfe();
timer_("AFTER DERI1", (ftnlen)11);
}
return 0;
} /* deri1_ */
