integer e_wsfe(Void)
{
#ifdef ALWAYS_FLUSH
int n;
n = en_fio();
f__fmtbuf=NULL;
if (!n && fflush(f__cf))
err(f__elist->cierr, errno, "write end");
return n;
#else
return(e_rsfe());
#endif
}
/* Subroutine */ int gettxt_()
{
/* System generated locals */
integer i__1;
char ch__1[80];
olist o__1;
alist al__1;
/* Builtin functions */
/* Subroutine */ int s_copy();
integer s_rsfe(), do_fio(), e_rsfe(), i_indx(), f_open(), f_rew(), s_wsfe(
), e_wsfe(), s_cmp();
/* Subroutine */ int s_stop();
/* Local variables */
static integer i__, j;
static char filen[50], ch[1];
static integer is[3];
extern /* Character */ VOID getnam_();
extern /* Subroutine */ int upcase_();
static char oldkey[80], ch2[1];
/* Fortran I/O blocks */
static cilist io___2 = { 1, 5, 1, "(A)", 0 };
static cilist io___7 = { 1, 4, 1, "(A)", 0 };
static cilist io___8 = { 1, 4, 1, "(A)", 0 };
static cilist io___9 = { 1, 5, 1, "(A)", 0 };
static cilist io___10 = { 1, 5, 1, "(A)", 0 };
static cilist io___11 = { 1, 4, 1, "(A)", 0 };
static cilist io___12 = { 1, 5, 1, "(A)", 0 };
static cilist io___13 = { 1, 5, 1, "(A)", 0 };
static cilist io___14 = { 1, 5, 1, "(A)", 0 };
static cilist io___15 = { 1, 4, 1, "(A)", 0 };
static cilist io___16 = { 1, 5, 1, "(A)", 0 };
static cilist io___17 = { 1, 5, 1, "(A)", 0 };
static cilist io___18 = { 1, 5, 1, "(A)", 0 };
static cilist io___19 = { 1, 5, 1, "(A)", 0 };
static cilist io___20 = { 0, 6, 0, "(A)", 0 };
static cilist io___23 = { 0, 6, 0, "(A,I2,A)", 0 };
static cilist io___24 = { 0, 6, 0, "(A)", 0 };
static cilist io___25 = { 0, 6, 0, "(A)", 0 };
is[0] = 161;
is[1] = 81;
is[2] = 1;
s_copy(keywrd_1.keywrd, " ", (ftnlen)241, (ftnlen)1);
s_copy(titles_1.koment, " NULL ", (ftnlen)81, (ftnlen)10);
s_copy(titles_1.title, " NULL ", (ftnlen)81, (ftnlen)10);
i__1 = s_rsfe(&io___2);
if (i__1 != 0) {
goto L100001;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd, (ftnlen)80);
if (i__1 != 0) {
goto L100001;
}
i__1 = e_rsfe();
L100001:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
s_copy(oldkey, keywrd_1.keywrd, (ftnlen)80, (ftnlen)241);
upcase_(keywrd_1.keywrd, (ftnlen)80);
if (i_indx(keywrd_1.keywrd, "SETUP", (ftnlen)241, (ftnlen)5) != 0) {
i__ = i_indx(keywrd_1.keywrd, "SETUP=", (ftnlen)241, (ftnlen)6);
if (i__ != 0) {
j = i_indx(keywrd_1.keywrd + (i__ - 1), " ", 241 - (i__ - 1), (
ftnlen)1);
i__1 = i__ + 5;
s_copy(filen, oldkey + i__1, (ftnlen)50, i__ + j - 1 - i__1);
} else {
s_copy(filen, "SETUP", (ftnlen)50, (ftnlen)5);
}
o__1.oerr = 0;
o__1.ounit = 4;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, filen, (ftnlen)50);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 4;
f_rew(&al__1);
i__1 = s_rsfe(&io___7);
if (i__1 != 0) {
goto L40;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 80, (ftnlen)80);
if (i__1 != 0) {
goto L40;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L40;
}
upcase_(keywrd_1.keywrd + 80, (ftnlen)80);
i__1 = s_rsfe(&io___8);
if (i__1 != 0) {
goto L10;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L10;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L10;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
L10:
i__1 = s_rsfe(&io___9);
if (i__1 != 0) {
goto L100002;
}
i__1 = do_fio(&c__1, titles_1.koment, (ftnlen)81);
if (i__1 != 0) {
goto L100002;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100002;
}
i__1 = e_rsfe();
L100002:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
} else if (i_indx(keywrd_1.keywrd, " +", (ftnlen)80, (ftnlen)2) != 0) {
/* READ SECOND KEYWORD LINE */
i__1 = s_rsfe(&io___10);
if (i__1 != 0) {
goto L100003;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 80, (ftnlen)80);
if (i__1 != 0) {
goto L100003;
}
i__1 = e_rsfe();
L100003:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
s_copy(oldkey, keywrd_1.keywrd + 80, (ftnlen)80, (ftnlen)80);
upcase_(keywrd_1.keywrd + 80, (ftnlen)80);
if (i_indx(keywrd_1.keywrd + 80, "SETUP", (ftnlen)80, (ftnlen)5) != 0)
{
i__ = i_indx(keywrd_1.keywrd, "SETUP=", (ftnlen)241, (ftnlen)6);
if (i__ != 0) {
j = i_indx(keywrd_1.keywrd + (i__ - 1), " ", 241 - (i__ - 1),
(ftnlen)1);
i__1 = i__ - 75;
s_copy(filen, oldkey + i__1, (ftnlen)50, i__ + j - 80 - i__1);
} else {
s_copy(filen, "SETUP", (ftnlen)50, (ftnlen)5);
}
o__1.oerr = 0;
o__1.ounit = 4;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, filen, (ftnlen)50);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 4;
f_rew(&al__1);
i__1 = s_rsfe(&io___11);
if (i__1 != 0) {
goto L20;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L20;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L20;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
L20:
;
} else if (i_indx(keywrd_1.keywrd + 80, " +", (ftnlen)80, (ftnlen)2)
!= 0) {
/* READ THIRD KEYWORD LINE */
i__1 = s_rsfe(&io___12);
if (i__1 != 0) {
goto L100004;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L100004;
}
i__1 = e_rsfe();
L100004:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
}
/* READ TITLE LINE */
i__1 = s_rsfe(&io___13);
if (i__1 != 0) {
goto L100005;
}
i__1 = do_fio(&c__1, titles_1.koment, (ftnlen)81);
if (i__1 != 0) {
goto L100005;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100005;
}
i__1 = e_rsfe();
L100005:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
} else if (i_indx(keywrd_1.keywrd, "&", (ftnlen)80, (ftnlen)1) != 0) {
i__1 = s_rsfe(&io___14);
if (i__1 != 0) {
goto L100006;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 80, (ftnlen)80);
if (i__1 != 0) {
goto L100006;
}
i__1 = e_rsfe();
L100006:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
s_copy(oldkey, keywrd_1.keywrd + 80, (ftnlen)80, (ftnlen)80);
upcase_(keywrd_1.keywrd + 80, (ftnlen)80);
if (i_indx(keywrd_1.keywrd + 80, "SETUP", (ftnlen)80, (ftnlen)5) != 0)
{
i__ = i_indx(keywrd_1.keywrd, "SETUP=", (ftnlen)241, (ftnlen)6);
if (i__ != 0) {
j = i_indx(keywrd_1.keywrd + (i__ - 1), " ", 241 - (i__ - 1),
(ftnlen)1);
i__1 = i__ - 75;
s_copy(filen, oldkey + i__1, (ftnlen)50, i__ + j - 80 - i__1);
/* write(*,*)' <'//FILEN//'>' */
/* stop */
} else {
s_copy(filen, "SETUP", (ftnlen)50, (ftnlen)5);
}
o__1.oerr = 0;
o__1.ounit = 4;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, filen, (ftnlen)50);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "UNKNOWN";
o__1.oacc = 0;
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 4;
f_rew(&al__1);
i__1 = s_rsfe(&io___15);
if (i__1 != 0) {
goto L30;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L30;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L30;
}
upcase_(keywrd_1.keywrd + 160, (ftnlen)80);
i__1 = s_rsfe(&io___16);
if (i__1 != 0) {
goto L100007;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100007;
}
i__1 = e_rsfe();
L100007:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
L30:
;
} else if (i_indx(keywrd_1.keywrd + 80, "&", (ftnlen)80, (ftnlen)1) !=
0) {
i__1 = s_rsfe(&io___17);
if (i__1 != 0) {
goto L100008;
}
i__1 = do_fio(&c__1, keywrd_1.keywrd + 160, (ftnlen)80);
if (i__1 != 0) {
goto L100008;
}
i__1 = e_rsfe();
L100008:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
} else {
i__1 = s_rsfe(&io___18);
if (i__1 != 0) {
goto L100009;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100009;
}
i__1 = e_rsfe();
L100009:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
}
} else {
i__1 = s_rsfe(&io___19);
if (i__1 != 0) {
goto L100010;
}
i__1 = do_fio(&c__1, titles_1.koment, (ftnlen)81);
if (i__1 != 0) {
goto L100010;
}
i__1 = do_fio(&c__1, titles_1.title, (ftnlen)81);
if (i__1 != 0) {
goto L100010;
}
i__1 = e_rsfe();
L100010:
if (i__1 < 0) {
goto L100;
}
if (i__1 > 0) {
goto L90;
}
}
goto L50;
L40:
s_wsfe(&io___20);
do_fio(&c__1, " SETUP FILE MISSING OR CORRUPT", (ftnlen)30);
e_wsfe();
L50:
for (j = 1; j <= 3; ++j) {
i__1 = is[j - 1] - 1;
if (s_cmp(keywrd_1.keywrd + i__1, " ", is[j - 1] - i__1, (ftnlen)1) !=
0) {
i__1 = is[j - 1] - 1;
s_copy(ch, keywrd_1.keywrd + i__1, (ftnlen)1, is[j - 1] - i__1);
i__1 = is[j - 1] - 1;
s_copy(keywrd_1.keywrd + i__1, " ", is[j - 1] - i__1, (ftnlen)1);
for (i__ = is[j - 1] + 1; i__ <= 239; ++i__) {
*(unsigned char *)ch2 = *(unsigned char *)&keywrd_1.keywrd[
i__ - 1];
*(unsigned char *)&keywrd_1.keywrd[i__ - 1] = *(unsigned char
*)ch;
*(unsigned char *)ch = *(unsigned char *)ch2;
i__1 = i__;
if (s_cmp(keywrd_1.keywrd + i__1, " ", i__ + 2 - i__1, (
ftnlen)2) == 0) {
i__1 = i__;
s_copy(keywrd_1.keywrd + i__1, ch, i__ + 1 - i__1, (
ftnlen)1);
goto L70;
}
/* L60: */
}
s_wsfe(&io___23);
do_fio(&c__1, " LINE", (ftnlen)5);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
do_fio(&c__1, " OF KEYWORDS DOES NOT HAVE ENOUGH", (ftnlen)33);
e_wsfe();
s_wsfe(&io___24);
do_fio(&c__1, " SPACES FOR PARSING. PLEASE CORRECT LINE.", (
ftnlen)42);
e_wsfe();
s_stop("", (ftnlen)0);
L70:
;
}
/* L80: */
}
return 0;
L90:
s_wsfe(&io___25);
do_fio(&c__1, " ERROR IN READ OF FIRST THREE LINES", (ftnlen)35);
e_wsfe();
L100:
s_stop("", (ftnlen)0);
} /* gettxt_ */
/* $Procedure GETFAT ( Get file architecture and type ) */
/* Subroutine */ int getfat_(char *file, char *arch, char *kertyp, ftnlen
file_len, ftnlen arch_len, ftnlen kertyp_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
inlist ioin__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen), f_inqu(inlist *), s_rnge(
char *, integer, char *, integer), f_open(olist *), s_rdue(cilist
*), do_uio(integer *, char *, ftnlen), e_rdue(void), f_clos(
cllist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_rsfe(void);
/* Local variables */
integer unit;
extern /* Subroutine */ int zzddhfnh_(char *, integer *, logical *,
ftnlen), zzddhgsd_(char *, integer *, char *, ftnlen, ftnlen),
zzddhnfo_(integer *, char *, integer *, integer *, integer *,
logical *, ftnlen), zzddhhlu_(integer *, char *, logical *,
integer *, ftnlen);
integer i__;
extern integer cardi_(integer *);
char fname[255];
extern /* Subroutine */ int chkin_(char *, ftnlen), ucase_(char *, char *,
ftnlen, ftnlen);
integer which;
extern /* Subroutine */ int errch_(char *, char *, ftnlen, ftnlen);
logical found, exist;
extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen),
idw2at_(char *, char *, char *, ftnlen, ftnlen, ftnlen);
integer handle;
extern /* Subroutine */ int dafcls_(integer *);
char filarc[32];
extern /* Subroutine */ int dashof_(integer *);
integer intbff;
logical opened;
extern /* Subroutine */ int dafopr_(char *, integer *, ftnlen);
integer intarc;
extern /* Subroutine */ int dashlu_(integer *, integer *);
char idword[12];
integer intamn, number;
logical diropn, notdas;
extern /* Subroutine */ int sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), getlun_(integer *), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen), ssizei_(
integer *, integer *), nextwd_(char *, char *, char *, ftnlen,
ftnlen, ftnlen);
char tmpwrd[12];
extern logical return_(void);
integer myunit, handles[106];
extern /* Subroutine */ int zzckspk_(integer *, char *, ftnlen);
/* Fortran I/O blocks */
static cilist io___19 = { 1, 0, 1, 0, 1 };
/* $ Abstract */
/* Determine the architecture and type of SPICE kernels. */
/* $ 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 */
/* None. */
/* $ Keywords */
/* KERNEL */
/* UTILITY */
/* $ Declarations */
/* $ Abstract */
/* Parameter declarations for the DAF/DAS handle manager. */
/* $ 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, DAS */
/* $ Keywords */
/* PRIVATE */
/* $ Particulars */
/* This include file contains parameters defining limits and */
/* integer codes that are utilized in the DAF/DAS handle manager */
/* routines. */
/* $ Restrictions */
/* None. */
/* $ Author_and_Institution */
/* F.S. Turner (JPL) */
/* $ Literature_References */
/* None. */
/* $ Version */
/* - SPICELIB Version 2.5.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 2.4.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 2.3.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 2.2.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 2.1.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 2.0.0, 12-APR-2012 (BVS) */
/* Increased FTSIZE (from 1000 to 5000). */
/* - SPICELIB Version 1.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 1.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 1.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 1.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 1.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 1.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 1.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 1.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 1.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 1.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 1.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 1.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 1.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 1.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 1.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 1.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 1.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 1.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 1.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 1.0.1, 17-JUL-2002 */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 1.0.0, 07-NOV-2001 */
/* -& */
/* Unit and file table size parameters. */
/* FTSIZE is the maximum number of files (DAS and DAF) that a */
/* user may have open simultaneously. */
/* RSVUNT is the number of units protected from being locked */
/* to a particular handle by ZZDDHHLU. */
/* SCRUNT is the number of units protected for use by scratch */
/* files. */
/* UTSIZE is the maximum number of logical units this manager */
/* will utilize at one time. */
/* Access method enumeration. These parameters are used to */
/* identify which access method is associated with a particular */
/* handle. They need to be synchronized with the STRAMH array */
/* defined in ZZDDHGSD in the following fashion: */
/* STRAMH ( READ ) = 'READ' */
/* STRAMH ( WRITE ) = 'WRITE' */
/* STRAMH ( SCRTCH ) = 'SCRATCH' */
/* STRAMH ( NEW ) = 'NEW' */
/* These values are used in the file table variable FTAMH. */
/* Binary file format enumeration. These parameters are used to */
/* identify which binary file format is associated with a */
/* particular handle. They need to be synchronized with the STRBFF */
/* array defined in ZZDDHGSD in the following fashion: */
/* STRBFF ( BIGI3E ) = 'BIG-IEEE' */
/* STRBFF ( LTLI3E ) = 'LTL-IEEE' */
/* STRBFF ( VAXGFL ) = 'VAX-GFLT' */
/* STRBFF ( VAXDFL ) = 'VAX-DFLT' */
/* These values are used in the file table variable FTBFF. */
/* Some random string lengths... more documentation required. */
/* For now this will have to suffice. */
/* Architecture enumeration. These parameters are used to identify */
/* which file architecture is associated with a particular handle. */
/* They need to be synchronized with the STRARC array defined in */
/* ZZDDHGSD in the following fashion: */
/* STRARC ( DAF ) = 'DAF' */
/* STRARC ( DAS ) = 'DAS' */
/* These values will be used in the file table variable FTARC. */
/* For the following environments, record length is measured in */
/* characters (bytes) with eight characters per double precision */
/* number. */
/* Environment: Sun, Sun FORTRAN */
/* Source: Sun Fortran Programmer's Guide */
/* Environment: PC, MS FORTRAN */
/* Source: Microsoft Fortran Optimizing Compiler User's Guide */
/* Environment: Macintosh, Language Systems FORTRAN */
/* Source: Language Systems FORTRAN Reference Manual, */
/* Version 1.2, page 12-7 */
/* Environment: PC/Linux, g77 */
/* Source: Determined by experiment. */
/* Environment: PC, Lahey F77 EM/32 Version 4.0 */
/* Source: Lahey F77 EM/32 Language Reference Manual, */
/* page 144 */
/* Environment: HP-UX 9000/750, FORTRAN/9000 Series 700 computers */
/* Source: FORTRAN/9000 Reference-Series 700 Computers, */
/* page 5-110 */
/* Environment: NeXT Mach OS (Black Hardware), */
/* Absoft Fortran Version 3.2 */
/* Source: NAIF Program */
/* The following parameter defines the size of a string used */
/* to store a filenames on this target platform. */
/* The following parameter controls the size of the character record */
/* buffer used to read data from non-native files. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- -------------------------------------------------- */
/* FILE I The name of a file to be examined. */
/* ARCH O The architecture of the kernel file. */
/* KERTYP O The type of the kernel file. */
/* $ Detailed_Input */
/* FILE is the name of a SPICE kernel file whose architecture */
/* and type are desired. */
/* $ Detailed_Output */
/* ARCH is the file architecture of the SPICE kernel file */
/* specified be FILE. If the architecture cannot be */
/* determined or is not recognized the value '?' is */
/* returned. */
/* Architectures currently recognized are: */
/* DAF - The file is based on the DAF architecture. */
/* DAS - The file is based on the DAS architecture. */
/* XFR - The file is in a SPICE transfer file format. */
/* DEC - The file is an old SPICE decimal text file. */
/* ASC -- An ASCII text file. */
/* KPL -- Kernel Pool File (i.e., a text kernel) */
/* TXT -- An ASCII text file. */
/* TE1 -- Text E-Kernel type 1. */
/* ? - The architecture could not be determined. */
/* This variable must be at least 3 characters long. */
/* KERTYP is the type of the SPICE kernel file. If the type */
/* can not be determined the value '?' is returned. */
/* Kernel file types may be any sequence of at most four */
/* printing characters. NAIF has reserved for its use */
/* types which contain all upper case letters. */
/* A file type of 'PRE' means that the file is a */
/* pre-release file. */
/* This variable may be at most 4 characters long. */
/* $ Parameters */
/* RECL is the record length of a binary kernel file. Each */
/* record must be large enough to hold 128 double */
/* precision numbers. The units in which the record */
/* length must be specified vary from environment to */
/* environment. For example, VAX Fortran requires */
/* record lengths to be specified in longwords, */
/* where two longwords equal one double precision */
/* number. */
/* $ Exceptions */
/* 1) If the filename specified is blank, then the error */
/* SPICE(BLANKFILENAME) is signaled. */
/* 2) If any inquire on the filename specified by FILE fails for */
/* some reason, the error SPICE(INQUIREERROR) is signaled. */
/* 3) If the file specified by FILE does not exist, the error */
/* SPICE(FILENOTFOUND) is signaled. */
/* 4) If the file specified by FILE is already open but not through */
/* SPICE interfaces, the error SPICE(EXTERNALOPEN) is signaled. */
/* 5) If an attempt to open the file specified by FILE fails when */
/* this routine requires that it succeed, the error */
/* SPICE(FILEOPENFAILED) is signaled. */
/* 6) If an attempt to read the file specified by FILE fails when */
/* this routine requires that it succeed, the error */
/* SPICE(FILEREADFAILED) is signaled. */
/* 7) Routines in the call tree of this routine may trap and */
/* signal errors. */
/* 8) If the ID word in a DAF based kernel is NAIF/DAF, then the */
/* algorithm GETFAT uses to distinguish between CK and SPK */
/* kernels may result in an indeterminate KERTYP if the SPK or */
/* CK files have invalid first segments. */
/* $ Files */
/* The SPICE kernel file specified by FILE is examined by this */
/* routine to determine its architecture and type. If the file */
/* named by FILE is not connected to a logical unit or loaded */
/* in the handle manager, this routine will OPEN and CLOSE it. */
/* $ Particulars */
/* This subroutine is a support utility routine that determines the */
/* architecture and type of a SPICE kernel file. */
/* $ Examples */
/* Suppose you wish to write a single routine for loading binary */
/* kernels. You can use this routine to determine the type of the */
/* file and then pass the file to the appropriate low level file */
/* loader to handle the actual loading of the file. */
/* CALL GETFAT ( FILE, ARCH, KERTYP ) */
/* IF ( KERTYP .EQ. 'SPK' ) THEN */
/* CALL SPKLEF ( FILE, HANDLE ) */
/* ELSE IF ( KERTYP .EQ. 'CK' ) THEN */
/* CALL CKLPF ( FILE, HANDLE ) */
/* ELSE IF ( KERTYP .EQ. 'EK' ) THEN */
/* CALL EKLEF ( FILE, HANDLE ) */
/* ELSE */
/* WRITE (*,*) 'The file could not be identified as a known' */
/* WRITE (*,*) 'kernel type. Did you load the wrong file' */
/* WRITE (*,*) 'by mistake?' */
/* END IF */
/* $ Restrictions */
/* 1) In order to properly determine the type of DAF based binary */
/* kernels, the routine requires that their first segments and */
/* the meta data necessary to address them are valid. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* H.A. Neilan (JPL) */
/* W.L. Taber (JPL) */
/* F.S. Turner (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* - SPICELIB Version 4.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 4.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 4.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 4.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 4.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 4.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 4.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 4.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 4.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 4.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 4.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 4.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 4.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 4.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 4.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 4.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 4.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 4.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 4.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 4.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 4.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 4.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 4.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 4.0.2, 24-APR-2003 (EDW) */
/* Added MAC-OSX-F77 to the list of platforms */
/* that require READONLY to read write protected */
/* kernels. */
/* - SPICELIB Version 4.0.1, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 4.0.0, 22-AUG-2001 (WLT) (FST) (EDW) */
/* Added code so that the architecture and type of open binary */
/* SPICE kernels can be determined. */
/* Added exception for MACPPC_C (CodeWarrior Mac classic). */
/* Reduced RECL value to 12 to prevent expression of */
/* the fseek bug. */
/* - SPICELIB Version 3.2.0, 06-DEC-1999 (WLT) */
/* The heuristics for distinguishing between CK and SPK have */
/* been enhanced so that the routine is no longer requires */
/* that TICKS in C-kernels be positive or integral. */
/* - SPICELIB Version 3.1.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 3.1.3, 22-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 3.1.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 3.1.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitly given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 3.1.0, 11-FEB-1999 (FST) */
/* Added an integrality check to Test 3. If LASTDP is not */
/* an integral value, then GETFAT simply returns KERTYP = '?', */
/* since it is of an indeterminate type. */
/* - SPICELIB Version 3.0.0, 07-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 19-DEC-1995 (KRG) */
/* Added several new features to the subroutine: */
/* - Error handling has been enhanced. */
/* - Several new file architectures have been added. */
/* Removed the mention of 1000 characters as a candidate for the */
/* record length of a file. */
/* Added the exception for a blank filename to the header. The */
/* error is signalled, but it was not listed in the header. */
/* Added IOSTAT values to the appropriate error messages. */
/* Non-printing characters are replaced with blanks in the ID */
/* word when it is read. This deals with the case where a */
/* platform allows a text file to be opened as an unformatted */
/* file and the ID word does not completely fill 8 characters. */
/* - SPICELIB Version 1.4.0, 5-JAN-1995 (HAN) */
/* Removed ENV11 since it is now the same as ENV2. */
/* Removed ENV10 since it is the same as the VAX environment. */
/* - SPICELIB Version 1.3.0, 30-AUG-1994 (HAN) */
/* Added two new environments, DEC Alpha/OpenVMS and */
/* Sun/Solaris, to the source master file. */
/* - SPICELIB Version 1.2.0, 25-MAR-1994 (HAN) */
/* Added two new environments, DEC Alpha/OpenVMS and */
/* Sun/Solaris, to the source master file. */
/* - SPICELIB Version 1.1.0, 25-MAR-1994 (HAN) */
/* Modified master source code file to use READONLY on platforms */
/* that support it. Also, changed some local declaration comment */
/* lines to match the standard NAIF template. */
/* - SPICELIB Version 1.0.0, 24-JUL-1993 (WLT) (HAN) (KRG) */
/* -& */
/* $ Index_Entries */
/* determine the architecture and type of a kernel file */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 4.0.0, 22-AUG-2001 (WLT) (FST) */
/* Added code so that the architecture and type of open binary */
/* SPICE kernels can be determined. This uses the new DAF/DAS */
/* handle manager as well as examination of handles of open DAS */
/* files. Currently the handle manager deals only with DAF */
/* files. This routine should be updated again when the DAS */
/* system is integrated with the handle manager. */
/* Some slight changes were required to support ZZDDHFNH on */
/* the VAX environment. This resulted in the addition of */
/* the logical USEFNH that is set to true in most */
/* environments, and never used again other than to allow */
/* the invocation of the ZZDDHFNH module. */
/* - SPICELIB Version 2.0.0, 19-DEC-1995 (KRG) */
/* Added several new features to the subroutine: */
/* - Error handling has been enhanced. */
/* - Several new file architectures have been added. */
/* Removed the mention of 1000 characters as a candidate for the */
/* record length of a file. It seems unlikely that we will */
/* encounter an environment where 1000 characters of storage is */
/* larger than the storage necessary for 128 double precision */
/* numbers; typically there are 8 characters per double precision */
/* number, yeilding 1024 characters. */
/* Added the exception for a blank filename to the header. The */
/* error is signalled, but it was not listed in the header. */
/* Added IOSTAT values to the appropriate error messages. */
/* Non-printing characters are replaced with blanks in the ID */
/* word when it is read. This deals with the case where a */
/* platform allows a text file to be opened as an unformatted */
/* file and the ID word does not completely fill 8 characters. */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Set the length of a SPICE kernel file ID word. */
/* Set minimum and maximum values for the range of ASCII printing */
/* characters. */
/* Local Variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("GETFAT", (ftnlen)6);
}
/* Initialize the temporary storage variables that we use. */
s_copy(idword, " ", (ftnlen)12, (ftnlen)1);
/* If the filename we have is blank, signal an error and return. */
if (s_cmp(file, " ", file_len, (ftnlen)1) == 0) {
setmsg_("The file name is blank.", (ftnlen)23);
sigerr_("SPICE(BLANKFILENAME)", (ftnlen)20);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* See if this is a binary file that is currently open */
/* within the SPICE binary file management subsystem. At */
/* the moment, as far as we know, the file is not opened. */
opened = FALSE_;
zzddhfnh_(file, &handle, &found, file_len);
if (found) {
/* If the file was recognized, we need to get the unit number */
/* associated with it. */
zzddhnfo_(&handle, fname, &intarc, &intbff, &intamn, &found, (ftnlen)
255);
/* Translate the architecture ID to a string and retrieve the */
/* logical unit to use with this file. */
zzddhgsd_("ARCH", &intarc, filarc, (ftnlen)4, (ftnlen)32);
zzddhhlu_(&handle, filarc, &c_false, &number, (ftnlen)32);
opened = TRUE_;
} else {
/* We'll do a bit of inquiring before we try opening anything. */
ioin__1.inerr = 1;
ioin__1.infilen = file_len;
ioin__1.infile = file;
ioin__1.inex = ∃
ioin__1.inopen = &opened;
ioin__1.innum = 0;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
/* Not too likely, but if the INQUIRE statement fails... */
if (iostat != 0) {
setmsg_("IOSTAT error in INQUIRE statement. IOSTAT = #.", (ftnlen)
46);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREERROR)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Note: the following two tests MUST be performed in the order */
/* in which they appear, since in some environments files that do */
/* not exist are considered to be open. */
if (! exist) {
setmsg_("The kernel file '#' does not exist.", (ftnlen)35);
errch_("#", file, (ftnlen)1, file_len);
sigerr_("SPICE(FILENOTFOUND)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* If the file is already open, it may be a DAS file. */
if (opened) {
/* At the moment, the handle manager doesn't manage DAS */
/* handles. As a result we need to treat the case of an open */
/* DAS separately. When the Handle Manager is hooked in with */
/* DAS as well as DAF, we should remove the block below. */
/* =================================================== */
/* DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS */
/* vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv */
/* This file may or may not be a DAS file. Until we */
/* have determined otherwise, we assume it is not */
/* a DAS file. */
notdas = TRUE_;
ioin__1.inerr = 1;
ioin__1.infilen = file_len;
ioin__1.infile = file;
ioin__1.inex = 0;
ioin__1.inopen = 0;
ioin__1.innum = &unit;
ioin__1.innamed = 0;
ioin__1.inname = 0;
ioin__1.inacc = 0;
ioin__1.inseq = 0;
ioin__1.indir = 0;
ioin__1.infmt = 0;
ioin__1.inform = 0;
ioin__1.inunf = 0;
ioin__1.inrecl = 0;
ioin__1.innrec = 0;
ioin__1.inblank = 0;
iostat = f_inqu(&ioin__1);
if (iostat != 0) {
setmsg_("IOSTAT error in INQUIRE statement. IOSTAT = #.", (
ftnlen)46);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(INQUIREERROR)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Get the set of handles of open DAS files. We will */
/* translate each of these handles to the associated */
/* logical unit. If the tranlation matches the result */
/* of the inquire, this must be a DAS file and we */
/* can proceed to determine the type. */
ssizei_(&c__100, handles);
dashof_(handles);
which = cardi_(handles);
while(which > 0) {
dashlu_(&handles[(i__1 = which + 5) < 106 && 0 <= i__1 ? i__1
: s_rnge("handles", i__1, "getfat_", (ftnlen)654)], &
myunit);
if (unit == myunit) {
number = myunit;
which = 0;
notdas = FALSE_;
} else {
--which;
}
}
/* If we reach this point and do not have a DAS, there */
/* is no point in going on. The user has opened this */
/* file outside the SPICE system. We shall not attempt */
/* to determine its type. */
if (notdas) {
setmsg_("The file '#' is already open.", (ftnlen)29);
errch_("#", file, (ftnlen)1, file_len);
sigerr_("SPICE(EXTERNALOPEN)", (ftnlen)19);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ */
/* DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS DAS */
/* =================================================== */
}
}
/* Open the file with a record length of RECL (the length of the */
/* DAF and DAS records). We assume, for now, that opening the file as */
/* a direct access file will work. */
diropn = TRUE_;
/* If the file is not already open (probably the case that */
/* happens most frequently) we try opening it for direct access */
/* and see if we can locate the idword. */
if (! opened) {
getlun_(&number);
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = file_len;
o__1.ofnm = file;
o__1.orl = 1024;
o__1.osta = "OLD";
o__1.oacc = "DIRECT";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* If we had trouble opening the file, try opening it as a */
/* sequential file. */
if (iostat != 0) {
diropn = FALSE_;
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = file_len;
o__1.ofnm = file;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* If we still have problems opening the file, we don't have a */
/* clue about the file architecture and type. */
if (iostat != 0) {
s_copy(arch, "?", arch_len, (ftnlen)1);
s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
setmsg_("Attempt to open the file '#' failed. IOSTAT = #.", (
ftnlen)48);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
}
}
/* We opened the file successfully, so let's try to read from the */
/* file. We need to be sure to use the correct form of the read */
/* statement, depending on whether the file was opened with direct */
/* acces or sequential access. */
if (diropn) {
io___19.ciunit = number;
iostat = s_rdue(&io___19);
if (iostat != 0) {
goto L100001;
}
iostat = do_uio(&c__1, tmpwrd, (ftnlen)12);
if (iostat != 0) {
goto L100001;
}
iostat = e_rdue();
L100001:
/* If we couldn't read from the file as a direct access file with */
/* a fixed record length, then try to open the file as a */
/* sequential file and read from it. */
if (iostat != 0) {
if (opened) {
/* Something has gone wrong here. The file was opened */
/* as either a DAF or DAS prior to the call to GETFAT. */
/* We retrieved the unit number maintained by the */
/* underlying binary file management system, but we */
/* were unable to read the file as direct access. */
/* There's nothing we can do but abandon our quest to */
/* determine the type of the file. */
setmsg_("The file '#' is opened as a binary SPICE kernel. B"
"ut it cannot be read using a direct access read. The"
" value of IOSTAT returned by the attempted READ is #"
". ", (ftnlen)157);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* If we reach this point, the file was opened locally */
/* as a direct access file. We could not read it that */
/* way, so we'll try using a sequential read. However, */
/* we first need to close the file and then reopen it */
/* for sequential reading. */
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
o__1.oerr = 1;
o__1.ounit = number;
o__1.ofnmlen = file_len;
o__1.ofnm = file;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = 0;
o__1.oblnk = 0;
iostat = f_open(&o__1);
/* If we could not open the file, we don't have a clue about */
/* the file architecture and type. */
if (iostat != 0) {
s_copy(arch, "?", arch_len, (ftnlen)1);
s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
setmsg_("Attempt to open the file '#' failed. IOSTAT = #.", (
ftnlen)48);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Try to read from the file. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = number;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, tmpwrd, (ftnlen)12);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
;
}
} else {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = number;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, tmpwrd, (ftnlen)12);
if (iostat != 0) {
goto L100003;
}
iostat = e_rsfe();
L100003:
;
}
/* If we had an error while reading, we don't recognize this file. */
if (iostat != 0) {
s_copy(arch, "?", arch_len, (ftnlen)1);
s_copy(kertyp, "?", kertyp_len, (ftnlen)1);
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Attempt to read from file '#' failed. IOSTAT = #.", (ftnlen)
49);
errch_("#", file, (ftnlen)1, file_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("GETFAT", (ftnlen)6);
return 0;
}
/* Close the file (if we opened it here), as we do not need it */
/* to be open any more. */
if (! opened) {
cl__1.cerr = 0;
cl__1.cunit = number;
cl__1.csta = 0;
f_clos(&cl__1);
}
/* At this point, we have a candidate for an ID word. To avoid */
/* difficulties with Fortran I/O and other things, we will now */
/* replace any non printing ASCII characters with blanks. */
for (i__ = 1; i__ <= 12; ++i__) {
if (*(unsigned char *)&tmpwrd[i__ - 1] < 32 || *(unsigned char *)&
tmpwrd[i__ - 1] > 126) {
*(unsigned char *)&tmpwrd[i__ - 1] = ' ';
}
}
/* Identify the architecture and type, if we can. */
ljust_(tmpwrd, tmpwrd, (ftnlen)12, (ftnlen)12);
ucase_(tmpwrd, tmpwrd, (ftnlen)12, (ftnlen)12);
nextwd_(tmpwrd, idword, tmpwrd, (ftnlen)12, (ftnlen)12, (ftnlen)12);
if (s_cmp(idword, "DAFETF", (ftnlen)12, (ftnlen)6) == 0) {
/* We have a DAF encoded transfer file. */
s_copy(arch, "XFR", arch_len, (ftnlen)3);
s_copy(kertyp, "DAF", kertyp_len, (ftnlen)3);
} else if (s_cmp(idword, "DASETF", (ftnlen)12, (ftnlen)6) == 0) {
/* We have a DAS encoded transfer file. */
s_copy(arch, "XFR", arch_len, (ftnlen)3);
s_copy(kertyp, "DAS", kertyp_len, (ftnlen)3);
} else if (s_cmp(idword, "'NAIF/DAF'", (ftnlen)10, (ftnlen)10) == 0) {
/* We have an old DAF decimal text file. */
s_copy(arch, "DEC", arch_len, (ftnlen)3);
s_copy(kertyp, "DAF", kertyp_len, (ftnlen)3);
} else if (s_cmp(idword, "NAIF/DAS", (ftnlen)8, (ftnlen)8) == 0) {
/* We have a pre release DAS binary file. */
s_copy(arch, "DAS", arch_len, (ftnlen)3);
s_copy(kertyp, "PRE", kertyp_len, (ftnlen)3);
} else {
/* Get the architecture and type from the ID word, if we can. */
idw2at_(idword, arch, kertyp, (ftnlen)8, arch_len, kertyp_len);
}
/* If the architecture is DAF and the type is unknown, '?', then we */
/* have either an SPK file, a CK file, or something we don't */
/* understand. Let's check it out. */
if (s_cmp(arch, "DAF", arch_len, (ftnlen)3) == 0 && s_cmp(kertyp, "?",
kertyp_len, (ftnlen)1) == 0) {
/* We have a DAF file and we do not know what the type is. This */
/* situation can occur for older SPK and CK files, before the ID */
/* word was used to store type information. */
/* We use Bill's (WLT'S) magic heuristics to determine the type */
/* of the file. */
/* Open the file and pass the handle to the private routine */
/* that deals with the dirty work. */
dafopr_(file, &handle, file_len);
zzckspk_(&handle, kertyp, kertyp_len);
dafcls_(&handle);
}
chkout_("GETFAT", (ftnlen)6);
return 0;
} /* getfat_ */
/* Subroutine */ int deriv_(doublereal *geo, doublereal *grad)
{
/* Initialized data */
static integer icalcn = 0;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
char ch__1[80];
olist o__1;
alist al__1;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen), f_open(olist *), f_rew(
alist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_rsfe(void), s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
double pow_di(doublereal *, integer *), sqrt(doublereal);
integer s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer i__, j;
static logical ci;
static integer ii, ij, il, jl, kl, ll, kk;
static logical aic;
extern doublereal dot_(doublereal *, doublereal *, integer *);
static logical int__;
extern /* Subroutine */ int mxm_(doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *);
static doublereal sum;
static logical scf1;
static char line[80];
static integer ncol;
static doublereal xjuc[3], step;
static logical slow;
static integer icapa;
static logical halfe, debug;
extern /* Subroutine */ int dcart_(doublereal *, doublereal *);
static integer iline;
static logical geook;
static doublereal grlim;
static integer ilowa;
static doublereal gnorm;
extern /* Subroutine */ int geout_(integer *);
static integer ilowz;
static doublereal change[3], aidref[360];
static integer idelta;
extern /* Character */ VOID getnam_(char *, ftnlen, char *, ftnlen);
static logical precis, noanci, aifrst;
extern /* Subroutine */ int dernvo_(doublereal *, doublereal *), jcarin_(
doublereal *, doublereal *, doublereal *, logical *, doublereal *,
integer *), gmetry_(doublereal *, doublereal *), deritr_(
doublereal *, doublereal *), symtry_(void);
/* Fortran I/O blocks */
static cilist io___14 = { 0, 5, 0, "(A)", 0 };
static cilist io___17 = { 1, 5, 1, "(A)", 0 };
static cilist io___19 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___20 = { 0, 6, 0, "(A)", 0 };
static cilist io___21 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___22 = { 0, 6, 0, "(A)", 0 };
static cilist io___23 = { 0, 6, 0, "(6F12.6)", 0 };
static cilist io___25 = { 1, 5, 1, 0, 0 };
static cilist io___26 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___27 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___28 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___29 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___31 = { 0, 6, 0, "(/,A,/)", 0 };
static cilist io___32 = { 0, 6, 0, "(5F12.6)", 0 };
static cilist io___37 = { 0, 6, 0, "(' GEO AT START OF DERIV')", 0 };
static cilist io___38 = { 0, 6, 0, "(F19.5,2F12.5)", 0 };
static cilist io___42 = { 0, 6, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, "(//,3(A,/),I3,A)", 0 };
static cilist io___55 = { 0, 6, 0, "(//,A)", 0 };
static cilist io___56 = { 0, 6, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, "(' GRADIENTS')", 0 };
static cilist io___58 = { 0, 6, 0, "(10F8.3)", 0 };
static cilist io___59 = { 0, 6, 0, "(' ERROR FUNCTION')", 0 };
static cilist io___60 = { 0, 6, 0, "(10F8.3)", 0 };
static cilist io___61 = { 0, 6, 0, "(' COSINE OF SEARCH DIRECTION =',F30"
".6)", 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 */
/* *********************************************************************** */
/* DERIV CALCULATES THE DERIVATIVES OF THE ENERGY WITH RESPECT TO THE */
/* INTERNAL COORDINATES. THIS IS DONE BY FINITE DIFFERENCES. */
/* THE MAIN ARRAYS IN DERIV ARE: */
/* LOC INTEGER ARRAY, LOC(1,I) CONTAINS THE ADDRESS OF THE ATOM */
/* INTERNAL COORDINATE LOC(2,I) IS TO BE USED IN THE */
/* DERIVATIVE CALCULATION. */
/* GEO ARRAY \GEO\ HOLDS THE INTERNAL COORDINATES. */
/* GRAD ON EXIT, CONTAINS THE DERIVATIVES */
/* *********************************************************************** */
/* Parameter adjustments */
--grad;
geo -= 4;
/* Function Body */
if (icalcn != numcal_1.numcal) {
aifrst = i_indx(keywrd_1.keywrd, "RESTART", (ftnlen)241, (ftnlen)7) ==
0;
debug = i_indx(keywrd_1.keywrd, "DERIV", (ftnlen)241, (ftnlen)5) != 0;
precis = i_indx(keywrd_1.keywrd, "PREC", (ftnlen)241, (ftnlen)4) != 0;
int__ = i_indx(keywrd_1.keywrd, " XYZ", (ftnlen)241, (ftnlen)4) == 0;
geook = i_indx(keywrd_1.keywrd, "GEO-OK", (ftnlen)241, (ftnlen)6) !=
0;
ci = i_indx(keywrd_1.keywrd, "C.I.", (ftnlen)241, (ftnlen)4) != 0;
scf1 = i_indx(keywrd_1.keywrd, "1SCF", (ftnlen)241, (ftnlen)4) != 0;
aic = i_indx(keywrd_1.keywrd, "AIDER", (ftnlen)241, (ftnlen)5) != 0;
icapa = 'A';
ilowa = 'a';
ilowz = 'z';
if (aic && aifrst) {
o__1.oerr = 0;
o__1.ounit = 5;
o__1.ofnmlen = 80;
getnam_(ch__1, (ftnlen)80, "FOR005", (ftnlen)6);
o__1.ofnm = ch__1;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = "ZERO";
f_open(&o__1);
al__1.aerr = 0;
al__1.aunit = 5;
f_rew(&al__1);
/* ISOK IS SET FALSE: ONLY ONE SYSTEM ALLOWED */
okmany_1.isok = FALSE_;
for (i__ = 1; i__ <= 3; ++i__) {
/* L10: */
s_rsfe(&io___14);
do_fio(&c__1, line, (ftnlen)80);
e_rsfe();
}
for (j = 1; j <= 1000; ++j) {
i__1 = s_rsfe(&io___17);
if (i__1 != 0) {
goto L40;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L40;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L40;
}
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
iline = *(unsigned char *)&line[i__ - 1];
if (iline >= ilowa && iline <= ilowz) {
*(unsigned char *)&line[i__ - 1] = (char) (iline +
icapa - ilowa);
}
/* L20: */
}
/* *********************************************************************** */
/* L30: */
if (i_indx(line, "AIDER", (ftnlen)80, (ftnlen)5) != 0) {
goto L60;
}
}
L40:
s_wsfe(&io___19);
do_fio(&c__1, " KEYWORD \"AIDER\" SPECIFIED, BUT NOT", (ftnlen)35)
;
e_wsfe();
s_wsfe(&io___20);
do_fio(&c__1, " PRESENT AFTER Z-MATRIX. JOB STOPPED", (ftnlen)37)
;
e_wsfe();
s_stop("", (ftnlen)0);
L50:
s_wsfe(&io___21);
do_fio(&c__1, " FAULT IN READ OF AB INITIO DERIVATIVES", (ftnlen)
40);
e_wsfe();
s_wsfe(&io___22);
do_fio(&c__1, " DERIVATIVES READ IN ARE AS FOLLOWS", (ftnlen)36);
e_wsfe();
s_wsfe(&io___23);
i__1 = i__;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&aidref[j - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
s_stop("", (ftnlen)0);
L60:
if (geokst_1.natoms > 2) {
j = geokst_1.natoms * 3 - 6;
} else {
j = 1;
}
i__1 = s_rsle(&io___25);
if (i__1 != 0) {
goto L50;
}
i__2 = j;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = do_lio(&c__5, &c__1, (char *)&aidref[i__ - 1], (ftnlen)
sizeof(doublereal));
if (i__1 != 0) {
goto L50;
}
}
i__1 = e_rsle();
if (i__1 != 0) {
goto L50;
}
s_wsfe(&io___26);
do_fio(&c__1, " AB-INITIO DERIVATIVES IN KCAL/MOL/(ANGSTROM OR R"
"ADIAN)", (ftnlen)55);
e_wsfe();
s_wsfe(&io___27);
i__1 = j;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&aidref[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
if (geovar_1.loc[(i__ << 1) - 2] > 3) {
j = geovar_1.loc[(i__ << 1) - 2] * 3 + geovar_1.loc[(i__
<< 1) - 1] - 9;
} else if (geovar_1.loc[(i__ << 1) - 2] == 3) {
j = geovar_1.loc[(i__ << 1) - 1] + 1;
} else {
j = 1;
}
/* L70: */
aidref[i__ - 1] = aidref[j - 1];
}
s_wsfe(&io___28);
do_fio(&c__1, " AB-INITIO DERIVATIVES FOR VARIABLES", (ftnlen)36);
e_wsfe();
s_wsfe(&io___29);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&aidref[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
if (geosym_1.ndep != 0) {
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
sum = aidref[i__ - 1];
i__2 = geosym_1.ndep;
for (j = 1; j <= i__2; ++j) {
if (geovar_1.loc[(i__ << 1) - 2] == geosym_1.locpar[j
- 1] && (geovar_1.loc[(i__ << 1) - 1] ==
geosym_1.idepfn[j - 1] || geovar_1.loc[(i__ <<
1) - 1] == 3 && geosym_1.idepfn[j - 1] == 14)
) {
aidref[i__ - 1] += sum;
}
/* L80: */
}
/* L90: */
}
s_wsfe(&io___31);
do_fio(&c__1, " AB-INITIO DERIVATIVES AFTER SYMMETRY WEIGHTI"
"NG", (ftnlen)47);
e_wsfe();
s_wsfe(&io___32);
i__1 = geovar_1.nvar;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&aidref[j - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
}
icalcn = numcal_1.numcal;
if (i_indx(keywrd_1.keywrd, "RESTART", (ftnlen)241, (ftnlen)7) == 0) {
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L100: */
errfn_1.errfn[i__ - 1] = 0.;
}
}
grlim = .01;
if (precis) {
grlim = 1e-4;
}
halfe = molkst_1.nopen > molkst_1.nclose && molkst_1.fract != 2. &&
molkst_1.fract != 0. || ci;
idelta = -7;
/* IDELTA IS A MACHINE-PRECISION DEPENDANT INTEGER */
change[0] = pow_di(&c_b70, &idelta);
change[1] = pow_di(&c_b70, &idelta);
change[2] = pow_di(&c_b70, &idelta);
/* CHANGE(I) IS THE STEP SIZE USED IN CALCULATING THE DERIVATIVES. */
/* FOR "CARTESIAN" DERIVATIVES, CALCULATED USING DCART,AN */
/* INFINITESIMAL STEP, HERE 0.000001, IS ACCEPTABLE. IN THE */
/* HALF-ELECTRON METHOD A QUITE LARGE STEP IS NEEDED AS FULL SCF */
/* CALCULATIONS ARE NEEDED, AND THE DIFFERENCE BETWEEN THE TOTAL */
/* ENERGIES IS USED. THE STEP CANNOT BE VERY LARGE, AS THE SECOND */
/* DERIVITIVE IN FLEPO IS CALCULATED FROM THE DIFFERENCES OF TWO */
/* FIRST DERIVATIVES. CHANGE(1) IS FOR CHANGE IN BOND LENGTH, */
/* (2) FOR ANGLE, AND (3) FOR DIHEDRAL. */
}
if (geovar_1.nvar == 0) {
return 0;
}
if (debug) {
s_wsfe(&io___37);
e_wsfe();
s_wsfe(&io___38);
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
do_fio(&c__1, (char *)&geo[j + i__ * 3], (ftnlen)sizeof(
doublereal));
}
}
e_wsfe();
}
gnorm = 0.;
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
genral_1.gold[i__ - 1] = grad[i__];
genral_1.xparam[i__ - 1] = geo[geovar_1.loc[(i__ << 1) - 1] +
geovar_1.loc[(i__ << 1) - 2] * 3];
/* L110: */
/* Computing 2nd power */
d__1 = grad[i__];
gnorm += d__1 * d__1;
}
gnorm = sqrt(gnorm);
slow = FALSE_;
noanci = FALSE_;
if (halfe) {
noanci = i_indx(keywrd_1.keywrd, "NOANCI", (ftnlen)241, (ftnlen)6) !=
0 || molkst_1.nopen == molkst_1.norbs;
slow = noanci && (gnorm < grlim || scf1);
}
if (geosym_1.ndep != 0) {
symtry_();
}
gmetry_(&geo[4], genral_1.coord);
/* COORD NOW HOLDS THE CARTESIAN COORDINATES */
if (halfe && ! noanci) {
if (debug) {
s_wsle(&io___42);
do_lio(&c__9, &c__1, "DOING ANALYTICAL C.I. DERIVATIVES", (ftnlen)
33);
e_wsle();
}
dernvo_(genral_1.coord, xyzgra_1.dxyz);
} else {
if (debug) {
s_wsle(&io___43);
do_lio(&c__9, &c__1, "DOING VARIATIONALLY OPIMIZED DERIVATIVES", (
ftnlen)40);
e_wsle();
}
dcart_(genral_1.coord, xyzgra_1.dxyz);
}
ij = 0;
i__1 = molkst_1.numat;
for (ii = 1; ii <= i__1; ++ii) {
i__2 = ucell_1.l1u;
for (il = ucell_1.l1l; il <= i__2; ++il) {
i__3 = ucell_1.l2u;
for (jl = ucell_1.l2l; jl <= i__3; ++jl) {
i__4 = ucell_1.l3u;
for (kl = ucell_1.l3l; kl <= i__4; ++kl) {
/* $DOIT ASIS */
for (ll = 1; ll <= 3; ++ll) {
/* L120: */
xjuc[ll - 1] = genral_1.coord[ll + ii * 3 - 4] +
euler_1.tvec[ll - 1] * il + euler_1.tvec[ll +
2] * jl + euler_1.tvec[ll + 5] * kl;
}
++ij;
/* $DOIT ASIS */
for (kk = 1; kk <= 3; ++kk) {
genral_1.cold[kk + ij * 3 - 4] = xjuc[kk - 1];
/* L130: */
}
/* L140: */
}
}
}
/* L150: */
}
step = change[0];
jcarin_(genral_1.coord, genral_1.xparam, &step, &precis, work3_1.work2, &
ncol);
mxm_(work3_1.work2, &geovar_1.nvar, xyzgra_1.dxyz, &ncol, &grad[1], &c__1)
;
if (precis) {
step = .5 / step;
} else {
step = 1. / step;
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L160: */
grad[i__] *= step;
}
/* NOW TO ENSURE THAT INTERNAL DERIVATIVES ACCURATELY REFLECT CARTESIAN */
/* DERIVATIVES */
if (int__ && ! geook && geovar_1.nvar >= molkst_1.numat * 3 - 6 &&
euler_1.id == 0) {
/* NUMBER OF VARIABLES LOOKS O.K. */
sum = dot_(&grad[1], &grad[1], &geovar_1.nvar);
i__1 = molkst_1.numat * 3;
/* Computing MAX */
d__1 = 4., d__2 = sum * 4.;
if (sum < 2. && dot_(xyzgra_1.dxyz, xyzgra_1.dxyz, &i__1) > max(d__1,
d__2)) {
/* OOPS, LOOKS LIKE AN ERROR. */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
j = (integer) (genral_1.xparam[i__ - 1] / 3.141);
if (geovar_1.loc[(i__ << 1) - 1] == 2 && geovar_1.loc[(i__ <<
1) - 2] > 3 && (d__1 = genral_1.xparam[i__ - 1] - j *
3.1415926, abs(d__1)) < .005) {
/* ERROR LOCATED, BUT CANNOT CORRECT IN THIS RUN */
s_wsfe(&io___54);
do_fio(&c__1, " INTERNAL COORDINATE DERIVATIVES DO NOT R"
"EFLECT", (ftnlen)47);
do_fio(&c__1, " CARTESIAN COORDINATE DERIVATIVES", (
ftnlen)33);
do_fio(&c__1, " TO CORRECT ERROR, INCREASE DIHEDRAL OF A"
"TOM", (ftnlen)44);
do_fio(&c__1, (char *)&geovar_1.loc[(i__ << 1) - 2], (
ftnlen)sizeof(integer));
do_fio(&c__1, " BY 90 DEGREES", (ftnlen)14);
e_wsfe();
s_wsfe(&io___55);
do_fio(&c__1, " CURRENT GEOMETRY", (ftnlen)21);
e_wsfe();
geout_(&c__6);
s_stop("", (ftnlen)0);
}
/* L170: */
}
}
}
/* THIS CODE IS ONLY USED IF THE KEYWORD NOANCI IS SPECIFIED */
if (slow) {
if (debug) {
s_wsle(&io___56);
do_lio(&c__9, &c__1, "DOING FULL SCF DERIVATIVES", (ftnlen)26);
e_wsle();
}
deritr_(errfn_1.errfn, &geo[4]);
/* THE ARRAY ERRFN HOLDS THE EXACT DERIVATIVES MINUS THE APPROXIMATE */
/* DERIVATIVES */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L180: */
errfn_1.errfn[i__ - 1] -= grad[i__];
}
}
gravec_1.cosine = dot_(&grad[1], genral_1.gold, &geovar_1.nvar) / sqrt(
dot_(&grad[1], &grad[1], &geovar_1.nvar) * dot_(genral_1.gold,
genral_1.gold, &geovar_1.nvar) + 1e-20);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L190: */
grad[i__] += errfn_1.errfn[i__ - 1];
}
if (aic) {
if (aifrst) {
aifrst = FALSE_;
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L200: */
errfn_1.aicorr[i__ - 1] = -aidref[i__ - 1] - grad[i__];
}
}
/* # WRITE(6,'('' GRADIENTS BEFORE AI CORRECTION'')') */
/* # WRITE(6,'(10F8.3)')(GRAD(I),I=1,NVAR) */
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L210: */
grad[i__] += errfn_1.aicorr[i__ - 1];
}
}
/* L220: */
if (debug) {
s_wsfe(&io___57);
e_wsfe();
s_wsfe(&io___58);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&grad[i__], (ftnlen)sizeof(doublereal));
}
e_wsfe();
if (slow) {
s_wsfe(&io___59);
e_wsfe();
s_wsfe(&io___60);
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&errfn_1.errfn[i__ - 1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
}
}
if (debug) {
s_wsfe(&io___61);
do_fio(&c__1, (char *)&gravec_1.cosine, (ftnlen)sizeof(doublereal));
e_wsfe();
}
return 0;
} /* deriv_ */
int
e_wsfe()
{ return(e_rsfe());
}
/* $Procedure READLN ( Read a text line from a logical unit ) */
/* Subroutine */ int readln_(integer *unit, char *line, logical *eof, ftnlen
line_len)
{
/* System generated locals */
cilist ci__1;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
/* Local variables */
extern /* Subroutine */ int chkin_(char *, ftnlen), errfnm_(char *,
integer *, ftnlen), sigerr_(char *, ftnlen), chkout_(char *,
ftnlen), setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
/* $ Abstract */
/* This routine will read a single line of text from the Fortran */
/* logical unit UNIT, reporting the end of file if it occurs. */
/* $ 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 */
/* None. */
/* $ Keywords */
/* ASCII */
/* TEXT */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* UNIT I The Fortran unit number to use for input. */
/* LINE O The line read from the file. */
/* EOF O A logical flag indicating the end of file. */
/* $ Detailed_Input */
/* UNIT The Fortran unit number for the input. This may */
/* be either the unit number for the terminal, or the */
/* unit number of a previously opened text file. */
/* $ Detailed_Output */
/* LINE On output, this will contain the next text line */
/* encountered when reading from UNIT. */
/* If the length of the character string LINE is shorter */
/* than the length of the current line in the text file, the */
/* line is truncated on the right by the Fortran READ */
/* statement, filling LINE with the first LEN(LINE) */
/* characters from the current line in the file. */
/* If an error or the end of file occurs during the */
/* attempt to read from UNIT, the value of this variable */
/* is not guaranteed. */
/* EOF On output, this variable will be set to .TRUE. if the */
/* end of file ( IOSTAT < 0 ) is encountered during the */
/* attempt to read from unit UNIT. Otherwise, this */
/* variable will be set to .FALSE.. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If an error occurs while attempting to read from the text */
/* file attached to UNIT, the error SPICE(FILEREADFAILED) will */
/* be signalled. */
/* This routine only checks in with the error handler in the event */
/* that an error occurred. (Discovery check in) */
/* $ Files */
/* None. */
/* $ Particulars */
/* This routine will read a single line, a text record, from the */
/* logical unit UNIT. UNIT may be the terminal, or it may be a */
/* logical unit number obtained from a Fortran OPEN or INQUIRE */
/* statement. This routine will set a logical flag, EOF, on output */
/* if the end of the file is encountered during the read attempt. */
/* $ Examples */
/* CALL READLN ( UNIT, LINE, EOF ) */
/* IF ( EOF ) THEN */
/* < The end of file, deal with it appropriately > */
/* END IF */
/* You now have a line of text from unit UNIT. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* $ Version */
/* - SPICELIB 1.0.0, 20-DEC-1995 (KRG) */
/* The routine graduated */
/* - Beta Version 1.0.1, 22-NOV-1994 (KRG) */
/* Cleaned up the comments a little bit. No code changes. */
/* - Beta Version 1.0.0, 17-DEC-1992 (KRG) */
/* -& */
/* $ Index_Entries */
/* read a text line from a logical unit */
/* -& */
/* Local variables */
/* Standard SPICE error handling. */
/* Read in the next line from the text file attached to UNIT. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, line_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
/* Check to see if we got a read error, and signal it if we did. */
if (iostat > 0) {
chkin_("READLN", (ftnlen)6);
setmsg_("Error reading from file: #. IOSTAT = #.", (ftnlen)39);
errfnm_("#", unit, (ftnlen)1);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("READLN", (ftnlen)6);
return 0;
}
/* Check to see if we got the end of file, and set the logical */
/* flag EOF if we did. */
if (iostat < 0) {
*eof = TRUE_;
} else {
*eof = FALSE_;
}
return 0;
} /* readln_ */
/* Subroutine */ int getgeo_(integer *iread, integer *labels, doublereal *geo,
integer *lopt, integer *na, integer *nb, integer *nc, doublereal *
ams, integer *natoms, logical *int__)
{
/* Initialized data */
static char elemnt[2*107] = "H " "HE" "LI" "BE" "B " "C " "N " "O " "F "
"NE" "NA" "MG" "AL" "SI" "P " "S " "CL" "AR" "K " "CA" "SC" "TI"
"V " "CR" "MN" "FE" "CO" "NI" "CU" "ZN" "GA" "GE" "AS" "SE" "BR"
"KR" "RB" "SR" "Y " "ZR" "NB" "MO" "TC" "RU" "RH" "PD" "AG" "CD"
"IN" "SN" "SB" "TE" "I " "XE" "CS" "BA" "LA" "CE" "PR" "ND" "PM"
"SM" "EU" "GD" "TB" "DY" "HO" "ER" "TM" "YB" "LU" "HF" "TA" "W "
"RE" "OS" "IR" "PT" "AU" "HG" "TL" "PB" "BI" "PO" "AT" "RN" "FR"
"RA" "AC" "TH" "PA" "U " "NP" "PU" "AM" "CM" "BK" "CF" "XX" "FM"
"MD" "CB" "++" "+ " "--" "- " "TV";
static char comma[1] = ",";
static char space[1] = " ";
static char nine[1] = "9";
static char zero[1] = "0";
/* Format strings */
static char fmt_260[] = "(i4,2x,3(f10.5,2x,i2,2x),3(i2,1x))";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3[2];
doublereal d__1, d__2;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
double sqrt(doublereal), d_sign(doublereal *, doublereal *), asin(
doublereal);
/* Local variables */
static integer i__, j, k, l;
static doublereal ca, sa;
static integer jj;
static char ele[2], tab[1];
static doublereal xyz[360] /* was [3][120] */;
static integer itab;
static doublereal real__;
static integer khar;
static char line[80];
static integer ndmy;
static char turn[1];
static doublereal temp1, temp2;
extern doublereal reada_(char *, integer *, ftnlen);
static integer icapa, label, iline, icapz, ilowa;
static doublereal value[40];
extern /* Subroutine */ int geout_(integer *);
static integer numat, iserr;
static doublereal const__;
static integer ilowz;
static doublereal degree;
static integer icomma;
static logical ircdrc, leadsp;
extern /* Subroutine */ int nuchar_(char *, doublereal *, integer *,
ftnlen);
static integer nvalue;
static doublereal weight;
static integer istart[40];
static char string[80];
static integer maxtxt;
extern /* Subroutine */ int xyzint_(doublereal *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *);
/* Fortran I/O blocks */
static cilist io___16 = { 1, 0, 1, "(A)", 0 };
static cilist io___29 = { 0, 6, 0, "(' ILLEGAL ATOMIC NUMBER')", 0 };
static cilist io___32 = { 0, 6, 0, "(' UNRECOGNIZED ELEMENT NAME: (',A,"
"')')", 0 };
static cilist io___33 = { 0, 6, 0, "(' FOR ATOM',I4,' ISOTOPIC MASS:' "
" ,F15.5)", 0 };
static cilist io___34 = { 0, 6, 0, "(//10X,'**** MAX. NUMBER OF ATOMS A"
"LLOWED:',I4)", 0 };
static cilist io___36 = { 0, 6, 0, "(A)", 0 };
static cilist io___38 = { 0, 6, 0, "(A)", 0 };
static cilist io___41 = { 0, 6, 0, "(//10X,' WARNING: INTERNAL COORDINAT"
"ES ARE ASSUMED -',/10X,' FOR THREE-ATOM SYSTEMS ',//)", 0 };
static cilist io___42 = { 0, 6, 0, "(A)", 0 };
static cilist io___43 = { 0, 5, 0, "(A)", 0 };
static cilist io___46 = { 0, 6, 0, "(/10X,A)", 0 };
static cilist io___53 = { 0, 6, 0, "(A)", 0 };
static cilist io___54 = { 0, 6, 0, "(//10X,' AN UNOPTIMIZABLE GEOMETRIC "
"PARAMETER HAS',/10X,' BEEN MARKED FOR OPTIMIZATION. THIS IS A NO"
"N-FATAL ' ,'ERROR')", 0 };
static cilist io___55 = { 0, 6, 0, "( ' ERROR DURING READ AT ATOM NUMBER"
" ', I3 )", 0 };
static cilist io___56 = { 0, 6, 0, "(' DATA CURRENTLY READ IN ARE ')", 0 }
;
static cilist io___57 = { 0, 6, 0, fmt_260, 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 */
/* *********************************************************************** */
/* GETGEO READS IN THE GEOMETRY. THE ELEMENT IS SPECIFIED BY IT'S */
/* CHEMICAL SYMBOL, OR, OPTIONALLY, BY IT'S ATOMIC NUMBER. */
/* ON INPUT IREAD = CHANNEL NUMBER FOR READ, NORMALLY 5 */
/* AMS = DEFAULT ATOMIC MASSES. */
/* ON OUTPUT LABELS = ATOMIC NUMBERS OF ALL ATOMS, INCLUDING DUMMIES. */
/* GEO = INTERNAL COORDINATES, IN ANGSTROMS, AND DEGREES. */
/* LOPT = INTEGER ARRAY, A '1' MEANS OPTIMIZE THIS PARAMETER, */
/* '0' MEANS DO NOT OPTIMIZE, AND A '-1' LABELS THE */
/* REACTION COORDINATE. */
/* NA = INTEGER ARRAY OF ATOMS (SEE DATA INPUT) */
/* NB = INTEGER ARRAY OF ATOMS (SEE DATA INPUT) */
/* NC = INTEGER ARRAY OF ATOMS (SEE DATA INPUT) */
/* ATMASS = ATOMIC MASSES OF ATOMS. */
/* *********************************************************************** */
/* Parameter adjustments */
--ams;
--nc;
--nb;
--na;
lopt -= 4;
geo -= 4;
--labels;
/* Function Body */
*(unsigned char *)tab = '\t';
ircdrc = i_indx(keywrd_1.keywrd, "IRC", (ftnlen)241, (ftnlen)3) + i_indx(
keywrd_1.keywrd, "DRC", (ftnlen)241, (ftnlen)3) != 0;
ilowa = 'a';
ilowz = 'z';
icapa = 'A';
icapz = 'Z';
maxtxt = 0;
*natoms = 0;
numat = 0;
iserr = 0;
for (i__ = 1; i__ <= 360; ++i__) {
/* L10: */
s_copy(simbol_1.simbol + (i__ - 1) * 10, "---", (ftnlen)10, (ftnlen)3)
;
}
L20:
io___16.ciunit = *iread;
i__1 = s_rsfe(&io___16);
if (i__1 != 0) {
goto L100001;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L100001;
}
i__1 = e_rsfe();
L100001:
if (i__1 < 0) {
goto L130;
}
if (i__1 > 0) {
goto L230;
}
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) == 0) {
goto L130;
}
++(*natoms);
/* SEE IF TEXT IS ASSOCIATED WITH THIS ELEMENT */
i__ = i_indx(line, "(", (ftnlen)80, (ftnlen)1);
if (i__ != 0) {
/* YES, ELEMENT IS LABELLED. */
k = i_indx(line, ")", (ftnlen)80, (ftnlen)1);
s_copy(atomtx_1.txtatm + (*natoms - 1 << 3), line + (i__ - 1), (
ftnlen)8, k - (i__ - 1));
/* Computing MAX */
i__1 = maxtxt, i__2 = k - i__ + 1;
maxtxt = max(i__1,i__2);
i__1 = k;
/* Writing concatenation */
i__3[0] = i__ - 1, a__1[0] = line;
i__3[1] = 80 - i__1, a__1[1] = line + i__1;
s_cat(string, a__1, i__3, &c__2, (ftnlen)80);
s_copy(line, string, (ftnlen)80, (ftnlen)80);
} else {
s_copy(atomtx_1.txtatm + (*natoms - 1 << 3), " ", (ftnlen)8, (ftnlen)
1);
}
/* CLEAN THE INPUT DATA */
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
iline = *(unsigned char *)&line[i__ - 1];
if (iline >= ilowa && iline <= ilowz) {
*(unsigned char *)&line[i__ - 1] = (char) (iline + icapa - ilowa);
}
/* L30: */
}
/* *********************************************************************** */
icomma = *(unsigned char *)&comma[0];
itab = *(unsigned char *)tab;
for (i__ = 1; i__ <= 80; ++i__) {
khar = *(unsigned char *)&line[i__ - 1];
if (khar == icomma || khar == itab) {
*(unsigned char *)&line[i__ - 1] = *(unsigned char *)&space[0];
}
/* L40: */
}
/* INITIALIZE ISTART TO INTERPRET BLANKS AS ZERO'S */
for (i__ = 1; i__ <= 10; ++i__) {
/* L50: */
istart[i__ - 1] = 80;
}
/* FIND INITIAL DIGIT OF ALL NUMBERS, CHECK FOR LEADING SPACES FOLLOWED */
/* BY A CHARACTER AND STORE IN ISTART */
leadsp = TRUE_;
nvalue = 0;
for (i__ = 1; i__ <= 80; ++i__) {
if (leadsp && *(unsigned char *)&line[i__ - 1] != *(unsigned char *)&
space[0]) {
++nvalue;
istart[nvalue - 1] = i__;
}
leadsp = *(unsigned char *)&line[i__ - 1] == *(unsigned char *)&space[
0];
/* L60: */
}
/* ESTABLISH THE ELEMENT'S NAME AND ISOTOPE, CHECK FOR ERRORS OR E.O.DATA */
weight = 0.;
i__1 = istart[0] - 1;
s_copy(string, line + i__1, (ftnlen)80, istart[1] - 1 - i__1);
if (*(unsigned char *)string >= *(unsigned char *)&zero[0] && *(unsigned
char *)string <= *(unsigned char *)&nine[0]) {
/* ATOMIC NUMBER USED: NO ISOTOPE ALLOWED */
label = (integer) reada_(string, &c__1, (ftnlen)80);
if (label == 0) {
goto L120;
}
if (label < 0 || label > 107) {
s_wsfe(&io___29);
e_wsfe();
goto L240;
}
goto L80;
}
/* ATOMIC SYMBOL USED */
real__ = (d__1 = reada_(string, &c__1, (ftnlen)80), abs(d__1));
if (real__ < 1e-15) {
/* NO ISOTOPE */
s_copy(ele, string, (ftnlen)2, (ftnlen)2);
} else {
weight = real__;
if (*(unsigned char *)&string[1] >= *(unsigned char *)&zero[0] && *(
unsigned char *)&string[1] <= *(unsigned char *)&nine[0]) {
s_copy(ele, string, (ftnlen)2, (ftnlen)1);
} else {
s_copy(ele, string, (ftnlen)2, (ftnlen)2);
}
}
/* CHECK FOR ERROR IN ATOMIC SYMBOL */
if (*(unsigned char *)ele == '-' && *(unsigned char *)&ele[1] != '-') {
*(unsigned char *)&ele[1] = ' ';
}
for (i__ = 1; i__ <= 107; ++i__) {
if (s_cmp(ele, elemnt + (i__ - 1 << 1), (ftnlen)2, (ftnlen)2) == 0) {
label = i__;
goto L80;
}
/* L70: */
}
if (*(unsigned char *)ele == 'X') {
label = 99;
goto L80;
}
s_wsfe(&io___32);
do_fio(&c__1, ele, (ftnlen)2);
e_wsfe();
goto L240;
/* ALL O.K. */
L80:
if (label != 99) {
++numat;
}
if (weight != 0.) {
s_wsfe(&io___33);
do_fio(&c__1, (char *)&(*natoms), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&weight, (ftnlen)sizeof(doublereal));
e_wsfe();
atmass_1.atmass[numat - 1] = weight;
} else {
if (label != 99) {
atmass_1.atmass[numat - 1] = ams[label];
}
}
if (*natoms > 120) {
s_wsfe(&io___34);
do_fio(&c__1, (char *)&c__120, (ftnlen)sizeof(integer));
e_wsfe();
s_stop("", (ftnlen)0);
}
labels[*natoms] = label;
geo[*natoms * 3 + 1] = reada_(line, &istart[1], (ftnlen)80);
geo[*natoms * 3 + 2] = reada_(line, &istart[3], (ftnlen)80);
geo[*natoms * 3 + 3] = reada_(line, &istart[5], (ftnlen)80);
if (ircdrc) {
i__1 = istart[2] - 1;
s_copy(turn, line + i__1, (ftnlen)1, istart[2] - i__1);
if (*(unsigned char *)turn == 'T') {
lopt[*natoms * 3 + 1] = 1;
if (*natoms == 1) {
s_wsfe(&io___36);
do_fio(&c__1, " IN DRC MONITOR POTENTIAL ENERGY TURNING POIN"
"TS", (ftnlen)47);
e_wsfe();
}
} else {
lopt[*natoms * 3 + 1] = 0;
}
i__1 = istart[4] - 1;
s_copy(turn, line + i__1, (ftnlen)1, istart[4] - i__1);
if (*(unsigned char *)turn == 'T') {
lopt[*natoms * 3 + 2] = 1;
} else {
lopt[*natoms * 3 + 2] = 0;
}
i__1 = istart[6] - 1;
s_copy(turn, line + i__1, (ftnlen)1, istart[6] - i__1);
if (*(unsigned char *)turn == 'T') {
lopt[*natoms * 3 + 3] = 1;
} else {
lopt[*natoms * 3 + 3] = 0;
}
} else {
lopt[*natoms * 3 + 1] = (integer) reada_(line, &istart[2], (ftnlen)80)
;
lopt[*natoms * 3 + 2] = (integer) reada_(line, &istart[4], (ftnlen)80)
;
lopt[*natoms * 3 + 3] = (integer) reada_(line, &istart[6], (ftnlen)80)
;
for (i__ = 3; i__ <= 7; i__ += 2) {
i__1 = istart[i__ - 1] - 1;
i__2 = istart[i__ - 1] - 1;
if (*(unsigned char *)&line[i__1] >= icapa && *(unsigned char *)&
line[i__2] <= icapz) {
iserr = 1;
}
/* L90: */
}
}
na[*natoms] = (integer) reada_(line, &istart[7], (ftnlen)80);
nb[*natoms] = (integer) reada_(line, &istart[8], (ftnlen)80);
nc[*natoms] = (integer) reada_(line, &istart[9], (ftnlen)80);
/* SPECIAL CASE OF USERS FORGETTING TO ADD DIHEDRAL DATA FOR ATOM 3 */
if (*natoms == 3) {
if (lopt[12] == 2) {
na[3] = 1;
nb[3] = 2;
geo[12] = 0.;
lopt[12] = 0;
} else if (lopt[12] == 1 && (d__1 = geo[12] - 2., abs(d__1)) < 1e-4) {
na[3] = 2;
nb[3] = 1;
geo[12] = 0.;
lopt[12] = 0;
}
}
if (lopt[*natoms * 3 + 1] > 1 || lopt[*natoms * 3 + 2] > 1 || lopt[*
natoms * 3 + 3] > 1) {
iserr = 1;
}
if (iserr == 1) {
/* MUST BE GAUSSIAN GEOMETRY INPUT */
i__1 = *natoms;
for (i__ = 2; i__ <= i__1; ++i__) {
for (k = 1; k <= 3; ++k) {
j = (integer) (geo[k + i__ * 3] + .4);
if ((d__1 = geo[k + i__ * 3] - j, abs(d__1)) > 1e-5) {
/* GEOMETRY CANNOT BE GAUSSIAN */
s_wsfe(&io___38);
do_fio(&c__1, " GEOMETRY IS FAULTY. GEOMETRY READ IN IS",
(ftnlen)41);
e_wsfe();
const__ = .017453292519988887;
i__2 = *natoms;
for (l = 1; l <= i__2; ++l) {
geo[l * 3 + 2] *= const__;
/* L100: */
geo[l * 3 + 3] *= const__;
}
geout_(&c__6);
s_stop("", (ftnlen)0);
}
/* L110: */
}
}
*natoms = -1;
return 0;
}
goto L20;
/* ALL DATA READ IN, CLEAN UP AND RETURN */
L120:
--(*natoms);
L130:
na[2] = 1;
*(unsigned char *)atomtx_1.ltxt = (char) maxtxt;
if (*natoms > 3) {
*int__ = na[4] != 0;
} else {
if (geo[11] < 10. && *natoms == 3) {
s_wsfe(&io___41);
e_wsfe();
}
*int__ = TRUE_;
}
if (*int__) {
geo[8] = 0.;
}
/* READ IN VELOCITY VECTOR, IF PRESENT */
if (i_indx(keywrd_1.keywrd, "VELO", (ftnlen)241, (ftnlen)4) > 0) {
if (*int__) {
s_wsfe(&io___42);
do_fio(&c__1, " COORDINATES MUST BE CARTESIAN WHEN VELOCITY VECT"
"OR IS USED.", (ftnlen)60);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* # WRITE(6,'(/10X,A)')'INITIAL VELOCITY VECTOR FOR DRC' */
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
s_rsfe(&io___43);
do_fio(&c__1, line, (ftnlen)80);
e_rsfe();
nuchar_(line, value, &ndmy, (ftnlen)80);
if (ndmy != 3) {
s_wsfe(&io___46);
do_fio(&c__1, " THERE MUST BE EXACTLY THREE VELOCITY DATA P"
"ER LINE", (ftnlen)52);
e_wsfe();
s_stop("", (ftnlen)0);
}
for (j = 1; j <= 3; ++j) {
/* L140: */
path_1.react[j + (i__ + 2) * 3 - 4] = value[j - 1];
}
/* # WRITE(6,'(2X,A2,2X,3F13.5)')ELEMNT(LABELS(I)),(VALUE(J),J=1,3) */
/* L150: */
}
for (i__ = 1; i__ <= 3; ++i__) {
for (j = 1; j <= 2; ++j) {
/* L160: */
path_1.react[i__ + j * 3 - 4] = geo[i__ + (j + 1) * 3] - geo[
i__ + 3];
}
}
/* NOW TO ROTATE VELOCITY VECTOR TO SUIT INTERNAL COORDINATE DEFINITION */
/* ROTATE AROUND THE 1-2 X-AXIS TO AS TO ELIMINATE REACT(3,2) */
/* (PUT ATOM 2 IN X-Y PLANE) */
/* Computing 2nd power */
d__1 = path_1.react[1];
/* Computing 2nd power */
d__2 = path_1.react[2];
sa = path_1.react[2] / sqrt(d__1 * d__1 + d__2 * d__2 + 1e-20);
/* Computing 2nd power */
d__2 = sa;
d__1 = sqrt(1. - d__2 * d__2);
ca = d_sign(&d__1, &path_1.react[1]);
/* # LABELS(NATOMS+1)=1 */
/* # LABELS(NATOMS+2)=1 */
/* # WRITE(6,*)' FIRST ROTATION, ABOUT 1-2 X-AXIS' */
i__1 = *natoms + 2;
for (i__ = 1; i__ <= i__1; ++i__) {
temp1 = path_1.react[i__ * 3 - 2] * ca + path_1.react[i__ * 3 - 1]
* sa;
temp2 = -path_1.react[i__ * 3 - 2] * sa + path_1.react[i__ * 3 -
1] * ca;
path_1.react[i__ * 3 - 2] = temp1;
path_1.react[i__ * 3 - 1] = temp2;
/* # WRITE(6,'(2X,A2,2X,3F13.5)')ELEMNT(LABELS(I)),(REACT(J,I),J=1,3) */
/* L170: */
}
/* ROTATE AROUND THE 1-2 Z-AXIS TO AS TO ELIMINATE REACT(2,2) */
/* (PUT ATOM 2 ON X AXIS) */
/* Computing 2nd power */
d__1 = path_1.react[1];
/* Computing 2nd power */
d__2 = path_1.react[0];
ca = path_1.react[0] / sqrt(d__1 * d__1 + d__2 * d__2 + 1e-20);
/* Computing 2nd power */
d__2 = ca;
d__1 = sqrt(1. - d__2 * d__2);
sa = d_sign(&d__1, &path_1.react[1]);
/* # WRITE(6,*)' SECOND ROTATION, ABOUT 1-2 Z-AXIS' */
i__1 = *natoms + 2;
for (i__ = 1; i__ <= i__1; ++i__) {
temp1 = path_1.react[i__ * 3 - 3] * ca + path_1.react[i__ * 3 - 2]
* sa;
temp2 = -path_1.react[i__ * 3 - 3] * sa + path_1.react[i__ * 3 -
2] * ca;
path_1.react[i__ * 3 - 3] = temp1;
path_1.react[i__ * 3 - 2] = temp2;
/* # WRITE(6,'(2X,A2,2X,3F13.5)')ELEMNT(LABELS(I)),(REACT(J,I),J=1,3) */
/* L180: */
}
/* ROTATE AROUND THE 2-3 X-AXIS TO AS TO ELIMINATE REACT(3,3) */
/* (PUT ATOM 3 ON X-Y PLANE) */
/* Computing 2nd power */
d__1 = path_1.react[4];
/* Computing 2nd power */
d__2 = path_1.react[5];
sa = path_1.react[5] / sqrt(d__1 * d__1 + d__2 * d__2 + 1e-20);
/* Computing 2nd power */
d__2 = sa;
d__1 = sqrt(1. - d__2 * d__2);
ca = d_sign(&d__1, &path_1.react[4]);
/* # WRITE(6,*)' THIRD ROTATION, ABOUT 2-3 X-AXIS' */
i__1 = *natoms + 2;
for (i__ = 1; i__ <= i__1; ++i__) {
temp1 = path_1.react[i__ * 3 - 2] * ca + path_1.react[i__ * 3 - 1]
* sa;
temp2 = -path_1.react[i__ * 3 - 2] * sa + path_1.react[i__ * 3 -
1] * ca;
path_1.react[i__ * 3 - 2] = temp1;
path_1.react[i__ * 3 - 1] = temp2;
/* # WRITE(6,'(2X,A2,2X,3F13.5)')ELEMNT(LABELS(I)),(REACT(J,I),J=1,3) */
/* L190: */
}
/* STRIP OFF FIRST TWO COORDINATES; THESE WERE THE COORDINATE AXIS */
/* DEFINITIONS */
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L200: */
path_1.react[j + i__ * 3 - 4] = path_1.react[j + (i__ + 2) *
3 - 4];
}
}
}
if (! (*int__)) {
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L210: */
xyz[j + i__ * 3 - 4] = geo[j + i__ * 3];
}
}
degree = 90. / asin(1.);
xyzint_(xyz, natoms, &na[1], &nb[1], &nc[1], °ree, &geo[4]);
if (i_indx(keywrd_1.keywrd, " XYZ", (ftnlen)241, (ftnlen)4) == 0) {
/* UNCONDITIONALLY SET FLAGS FOR INTERNAL COORDINATES */
for (i__ = 1; i__ <= 3; ++i__) {
for (j = i__; j <= 3; ++j) {
/* L220: */
lopt[j + i__ * 3] = 0;
}
}
}
if ((d__1 = geo[11] - 180., abs(d__1)) < 1e-4 || abs(geo[11]) < 1e-4)
{
s_wsfe(&io___53);
do_fio(&c__1, " DUE TO PROGRAM BUG, THE FIRST THREE ATOMS MUST N"
"OT LIE IN A STRAIGHT LINE.", (ftnlen)75);
e_wsfe();
s_stop("", (ftnlen)0);
}
} else if (! ircdrc) {
lopt[8] = 0;
if (lopt[4] + lopt[5] + lopt[6] + lopt[9] + lopt[12] > 0) {
lopt[4] = 0;
lopt[5] = 0;
lopt[6] = 0;
lopt[9] = 0;
lopt[12] = 0;
s_wsfe(&io___54);
e_wsfe();
}
}
if (na[3] == 0) {
nb[3] = 1;
na[3] = 2;
}
return 0;
/* ERROR CONDITIONS */
L230:
if (*iread == 5) {
s_wsfe(&io___55);
do_fio(&c__1, (char *)&(*natoms), (ftnlen)sizeof(integer));
e_wsfe();
} else {
*natoms = 0;
return 0;
}
L240:
j = *natoms - 1;
s_wsfe(&io___56);
e_wsfe();
i__1 = j;
for (k = 1; k <= i__1; ++k) {
/* L250: */
s_wsfe(&io___57);
do_fio(&c__1, (char *)&labels[k], (ftnlen)sizeof(integer));
for (jj = 1; jj <= 3; ++jj) {
do_fio(&c__1, (char *)&geo[jj + k * 3], (ftnlen)sizeof(doublereal)
);
do_fio(&c__1, (char *)&lopt[jj + k * 3], (ftnlen)sizeof(integer));
}
do_fio(&c__1, (char *)&na[k], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nb[k], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nc[k], (ftnlen)sizeof(integer));
e_wsfe();
}
s_stop("", (ftnlen)0);
return 0;
} /* getgeo_ */
/* $Procedure COUNTC ( Count characters in a text file ) */
integer countc_(integer *unit, integer *bline, integer *eline, char *line,
ftnlen line_len)
{
/* System generated locals */
integer ret_val;
cilist ci__1;
alist al__1;
/* Builtin functions */
integer f_rew(alist *), s_rsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_rsfe(void), s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
logical done;
extern /* Subroutine */ int chkin_(char *, ftnlen);
integer chars, linect;
extern integer lastnb_(char *, ftnlen);
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), astrip_(
char *, char *, char *, char *, ftnlen, ftnlen, ftnlen, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Count the characters in a group of lines in a text 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. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* CHARACTERS */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* UNIT I Logical unit connected to text file. */
/* BLINE I Beginning line number. */
/* ELINE I Ending line number. */
/* LINE I,O Workspace. */
/* COUNTC returns the number of characters. */
/* $ Detailed_Input */
/* UNIT is a logical unit that has been connected to a */
/* text file by the calling program. Use the routine */
/* TXTOPR to open the file for read access and get its */
/* logical unit. A text file is a formatted, */
/* sequential file that contains only printable */
/* characters: ASCII 32-126. */
/* BLINE, */
/* ELINE are line numbers in the text file. BLINE is */
/* the line where the count will begin, and ELINE */
/* is the line where the count will end. The */
/* number of characters in the beginning and ending */
/* lines are included in the total count. */
/* By convention, line 1 is the first line of the file. */
/* LINE on input, is an arbitrary character string whose */
/* contents are ignored. LINE is used to read lines */
/* from the file connected to UNIT; its function */
/* is to determine the maximum length of the lines */
/* that can be read from the file. Lines longer */
/* than the declared length of LINE are truncated */
/* as they are read. */
/* $ Detailed_Output */
/* LINE on output, is undefined. */
/* The function, COUNTC, returns the number of characters in the */
/* group of lines in the file beginning with BLINE and ending with */
/* ELINE. Trailing blanks on a line are not included in the count. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) If an error occurs while reading from the input file, */
/* the error SPICE(FILEREADFAILED) is signalled. */
/* 2) If a non-printing ASCII character is encountered during */
/* the count, the error SPICE(INVALIDTEXT) is signalled. */
/* 3) If BLINE is greater than ELINE or if the file does not */
/* contain both of this lines, the error SPICE(CANNOTFINDGRP) */
/* is signalled. */
/* $ Files */
/* See argument UNIT. COUNTC rewinds the text file connected to */
/* UNIT and then steps through the file. The next read statement */
/* after calling COUNTC would return the line after ELINE. */
/* $ Particulars */
/* This routine counts characters in a group of lines in a text */
/* file. Using COUNTC, you can determine in advance how much space */
/* is required to store those characters. */
/* $ Examples */
/* The following code fragment opens an existing text file for */
/* read access and counts the characters that it contains in */
/* the first five lines. We'll assume that the longest line */
/* in the file is 80 characters. */
/* INTEGER COUNTC */
/* INTEGER UNIT */
/* INTEGER N */
/* CHARACTER*(80) LINE */
/* CALL TXTOPR ( 'DATA.TXT', UNIT ) */
/* N = COUNTC ( UNIT, 1, 5, LINE ) */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* J.E. McLean (JPL) */
/* H.A. Neilan (JPL) */
/* $ Version */
/* - SPICELIB Version 1.1.0, 17-MAY-1994 (HAN) */
/* Set the default function value to either 0, 0.0D0, .FALSE., */
/* or blank depending on the type of the function. */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 05-APR-1991 (JEM) */
/* -& */
/* $ Index_Entries */
/* count characters in a text file */
/* -& */
/* SPICELIB functions */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
ret_val = 0;
return ret_val;
} else {
chkin_("COUNTC", (ftnlen)6);
ret_val = 0;
}
/* First, see if the line numbers make sense. */
if (*bline > *eline || *bline <= 0) {
setmsg_("The line numbers do not make sense: BLINE = # and ELINE ="
" #.", (ftnlen)62);
errint_("#", bline, (ftnlen)1);
errint_("#", eline, (ftnlen)1);
sigerr_("SPICE(CANNOTFINDGRP)", (ftnlen)20);
chkout_("COUNTC", (ftnlen)6);
return ret_val;
}
/* Read through the file, line by line, beginning with the first */
/* line in the file, checking for I/O errors, and counting */
/* characters in the lines between and including BLINE and ELINE. */
al__1.aerr = 0;
al__1.aunit = *unit;
f_rew(&al__1);
linect = 0;
chars = 0;
done = FALSE_;
while(! done) {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, line_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
/* An end-of-file condition is indicated by a negative value */
/* for IOSTAT. Any other non-zero value indicates some other */
/* error. If IOSTAT is zero, the read was successful. */
if (iostat > 0) {
setmsg_("Error reading text file named FILENAME.The value of IOS"
"TAT is #.", (ftnlen)64);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FILENAME", unit, (ftnlen)8);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("COUNTC", (ftnlen)6);
return ret_val;
} else if (iostat < 0) {
setmsg_("Reached end of file unexpectedly at line # in file FILE"
". BLINE = # and ELINE = #.", (ftnlen)82);
errint_("#", &linect, (ftnlen)1);
errint_("#", bline, (ftnlen)1);
errint_("#", eline, (ftnlen)1);
errfnm_("FILE", unit, (ftnlen)4);
sigerr_("SPICE(CANNOTFINDGRP)", (ftnlen)20);
chkout_("COUNTC", (ftnlen)6);
return ret_val;
} else {
/* We've read a line successfully, so add it to the line count. */
/* If this line is in the group delimited by BLINE and ELINE, */
/* count the characters in it, and if this line is ELINE, we're */
/* done. */
++linect;
if (linect >= *bline && linect <= *eline) {
/* Add the number of characters in this line to the count. */
/* If LINE is blank, LASTNB will return 0 which is just */
/* what we want. */
chars += lastnb_(line, line_len);
/* Remove the printable characters from the line. If */
/* any characters remain, signal an error. */
astrip_(line, " ", "~", line, line_len, (ftnlen)1, (ftnlen)1,
line_len);
if (s_cmp(line, " ", line_len, (ftnlen)1) != 0) {
setmsg_("Non-printing ASCII characters were found when c"
"ounting characters on line number # in file FILE"
"NAME.", (ftnlen)100);
errint_("#", &linect, (ftnlen)1);
errfnm_("FILENAME", unit, (ftnlen)8);
sigerr_("SPICE(INVALIDTEXT)", (ftnlen)18);
chkout_("COUNTC", (ftnlen)6);
return ret_val;
}
}
if (linect == *eline) {
done = TRUE_;
}
}
}
/* Assign the final character count. */
ret_val = chars;
chkout_("COUNTC", (ftnlen)6);
return ret_val;
} /* countc_ */
/* $Procedure RDCMD (Read command file) */
/* Subroutine */ int rdcmd_(char *cmdfil, char *cmdsym, integer *cmdptr, char
*cmdval, ftnlen cmdfil_len, ftnlen cmdsym_len, ftnlen cmdval_len)
{
/* Initialized data */
static char kwds1[32*2] = "LEAPSECONDS_KERNEL 1 1 " "SPK_KERNEL"
" 1 1000 ";
static char kwds2[32*5] = "SOURCE_SPK_KERNEL 1 1000 " "LOG_FILE "
" 0 1 " "BODIES 0 1 " "BEGI"
"N_TIME 0 1000 " "INCLUDE_TEXT_FILE 0 1000 ";
static char kwds3[32*3] = "BODIES 0 1 " "BEGIN_TIME"
" 0 1000 " "INCLUDE_COMMENTS 0 1 ";
static char kwds4[32*1] = "END_TIME 1 1 ";
/* System generated locals */
cilist ci__1;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
/* Local variables */
static char line[350];
static integer unit;
extern /* Subroutine */ int chkin_(char *, ftnlen), cperr_(char *,
integer *, ftnlen), repmi_(char *, char *, integer *, char *,
ftnlen, ftnlen, ftnlen);
static char tabval[32*26];
extern /* Subroutine */ int evalcp_(char *, logical *, char *, integer *,
char *, logical *, ftnlen, ftnlen, ftnlen), initcp_(char *,
integer *, char *, char *, ftnlen, ftnlen, ftnlen);
static char reason[160];
extern /* Subroutine */ int sigerr_(char *, ftnlen);
static integer tabptr[26];
extern /* Subroutine */ int prefix_(char *, integer *, char *, ftnlen,
ftnlen);
static char tabsym[32*26];
extern /* Subroutine */ int ssizec_(integer *, char *, ftnlen), chkout_(
char *, ftnlen);
static integer linnum, iostat;
extern /* Subroutine */ int setmsg_(char *, ftnlen), ssizei_(integer *,
integer *);
extern logical return_(void);
extern /* Subroutine */ int syputc_(char *, char *, integer *, char *,
integer *, char *, ftnlen, ftnlen, ftnlen, ftnlen), txtopr_(char *
, integer *, ftnlen);
static logical eof, err;
/* $ Abstract */
/* Parse the command 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. */
/* $ Required_Reading */
/* None. */
/* $ Keywords */
/* None. */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* CMDFIL I Name of command file. */
/* CMDSYM, */
/* CMDPTR, */
/* CMDVAL O Command symbol table. */
/* $ Detailed_Input */
/* CMDFIL is the name of the command file. */
/* $ Detailed_Output */
/* CMDSYM, */
/* CMDPTR, */
/* CMDVAL is the command symbol table. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* 1) An error is signaled if the file cannot be parsed */
/* successfully. */
/* $ Files */
/* None. */
/* $ Particulars */
/* None. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* M.J. Spencer (JPL) */
/* $ Version */
/* - Beta Version 1.1.0, 17-JAN-2014 (BVS) */
/* Increased LINLEN from 120 to 350 (350 = 300 characters for */
/* value consistent with VALLEN in CPARSE_2 and the main program */
/* + 50 more characters for the keyword name, =, and blanks.) */
/* Increased maximum counts of child values in KWDS* from 300 to */
/* 1000 for all values. */
/* Saved all variables. */
/* - Beta Version 1.0.0, 26-JAN-1994 (MJS) */
/* -& */
/* SPICELIB functions */
/* Other functions */
/* Local parameters */
/* Local variables */
/* Save all. */
/* Initial values */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("RDCMD", (ftnlen)5);
}
/* Initialize the parser. */
ssizec_(&c__20, tabsym, (ftnlen)32);
ssizei_(&c__20, tabptr);
ssizec_(&c__20, tabval, (ftnlen)32);
syputc_("HEAD", kwds1, &c__2, tabsym, tabptr, tabval, (ftnlen)4, (ftnlen)
32, (ftnlen)32, (ftnlen)32);
syputc_("SPK_KERNEL", kwds2, &c__5, tabsym, tabptr, tabval, (ftnlen)10, (
ftnlen)32, (ftnlen)32, (ftnlen)32);
syputc_("SOURCE_SPK_KERNEL", kwds3, &c__3, tabsym, tabptr, tabval, (
ftnlen)17, (ftnlen)32, (ftnlen)32, (ftnlen)32);
syputc_("BEGIN_TIME", kwds4, &c__1, tabsym, tabptr, tabval, (ftnlen)10, (
ftnlen)32, (ftnlen)32, (ftnlen)32);
initcp_(tabsym, tabptr, tabval, "HEAD", (ftnlen)32, (ftnlen)32, (ftnlen)4)
;
/* Open the command file, and parse its contents */
txtopr_(cmdfil, &unit, cmdfil_len);
eof = FALSE_;
err = FALSE_;
while(! eof && ! err) {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, (ftnlen)350);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
eof = iostat != 0;
evalcp_(line, &eof, cmdsym, cmdptr, cmdval, &err, (ftnlen)350,
cmdsym_len, cmdval_len);
}
if (err) {
cperr_(reason, &linnum, (ftnlen)160);
repmi_(reason, "#", &linnum, reason, (ftnlen)160, (ftnlen)1, (ftnlen)
160);
prefix_(":", &c__1, reason, (ftnlen)1, (ftnlen)160);
prefix_(cmdfil, &c__0, reason, cmdfil_len, (ftnlen)160);
setmsg_(reason, (ftnlen)160);
sigerr_("SPICE(CMDPARSEERROR)", (ftnlen)20);
chkout_("RDCMD", (ftnlen)5);
return 0;
}
chkout_("RDCMD", (ftnlen)5);
return 0;
} /* rdcmd_ */
/* Main program */ MAIN__(void)
{
/* Initialized data */
static integer iseed[4] = { 0,0,0,1 };
static integer mxtype[4] = { 8,4,5,4 };
/* Format strings */
static char fmt_9993[] = "(\002 Timing the Nonsymmetric Eigenvalue Probl"
"em routines\002,/\002 DGEHRD, DHSEQR, DTREVC, and DHSEIN\002)";
static char fmt_9992[] = "(\002 Timing the Symmetric Eigenvalue Problem "
"routines\002,/\002 DSYTRD, DSTEQR, and DSTERF\002)";
static char fmt_9991[] = "(\002 Timing the Singular Value Decomposition "
"routines\002,/\002 DGEBRD, DBDSQR, DORGBR, DBDSDC and DGESD"
"D\002)";
static char fmt_9990[] = "(\002 Timing the Generalized Eigenvalue Proble"
"m routines\002,/\002 DGGHRD, DHGEQZ, and DTGEVC \002)";
static char fmt_9996[] = "(1x,a3,\002: Unrecognized path name\002)";
static char fmt_9985[] = "(/\002 LAPACK VERSION 3.0, released June 30, 1"
"999 \002)";
static char fmt_9989[] = "(/\002 The following parameter values will be "
"used:\002)";
static char fmt_9995[] = "(\002 *** Invalid input value: \002,a6,\002"
"=\002,i6,\002; must be >=\002,i6)";
static char fmt_9994[] = "(\002 *** Invalid input value: \002,a6,\002"
"=\002,i6,\002; must be <=\002,i6)";
static char fmt_9988[] = "(\002 Values of \002,a5,\002: \002,10i6,/1"
"9x,10i6)";
static char fmt_9987[] = "(/\002 Minimum time a subroutine will be timed"
" = \002,f8.2,\002 seconds\002,/)";
static char fmt_9999[] = "(/\002 Execution not attempted due to input er"
"rors\002)";
static char fmt_9986[] = "(\002 *** Error code from \002,a6,\002 = \002,"
"i4)";
static char fmt_9998[] = "(//\002 End of timing run\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;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_rsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_rsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsle(cilist *), e_wsle(void);
/* Local variables */
static char line[80];
static integer info;
static char path[3];
static integer mval[12], nval[12];
static doublereal work[649241], a[1008000] /* was [168000][6] */, d__[
1600] /* was [400][4] */;
static integer i__;
static logical fatal;
extern /* Subroutine */ int dtim21_(char *, integer *, integer *, integer
*, logical *, integer *, integer *, integer *, integer *, integer
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, logical *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *, integer *, ftnlen),
dtim22_(char *, integer *, integer *, integer *, logical *,
integer *, integer *, integer *, doublereal *, integer *, integer
*, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, logical *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *, integer *, ftnlen);
static integer nbval[10];
extern /* Subroutine */ int dtim51_(char *, integer *, integer *, integer
*, logical *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, doublereal *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
logical *, doublereal *, integer *, integer *, integer *,
doublereal *, integer *, integer *, integer *, integer *, ftnlen),
dtim26_(char *, integer *, integer *, integer *, integer *,
logical *, integer *, integer *, integer *, doublereal *, integer
*, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, logical *,
doublereal *, integer *, integer *, integer *, doublereal *,
integer *, integer *, integer *, integer *, ftnlen);
static char vname[6];
static integer nsval[10];
static char c3[3];
static integer iwork[10];
static doublereal s1, s2;
static integer iwork2[20406], nn;
extern doublereal dsecnd_(void);
static integer ldaval[10], nbkval[10], nbmval[10];
extern logical lsamen_(integer *, char *, char *);
static integer mxbval[10];
static doublereal timmin;
static integer nparms;
static logical dotype[10], logwrk[400];
static doublereal opcnts[30000] /* was [10][10][12][25] */, result[
30000] /* was [10][10][12][25] */;
static integer maxtyp, ntypes;
static logical gep, nep, sep, svd;
/* Fortran I/O blocks */
static cilist io___9 = { 0, 5, 1, "(A3)", 0 };
static cilist io___11 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___12 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___13 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___14 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___15 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___16 = { 0, 6, 0, fmt_9985, 0 };
static cilist io___17 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___18 = { 0, 5, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___21 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___22 = { 0, 5, 0, 0, 0 };
static cilist io___26 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___27 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___28 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___29 = { 0, 5, 0, 0, 0 };
static cilist io___31 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___32 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___33 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___34 = { 0, 5, 0, 0, 0 };
static cilist io___36 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___37 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___38 = { 0, 5, 0, 0, 0 };
static cilist io___40 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___41 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___42 = { 0, 5, 0, 0, 0 };
static cilist io___44 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___45 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___46 = { 0, 5, 0, 0, 0 };
static cilist io___48 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___49 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___50 = { 0, 5, 0, 0, 0 };
static cilist io___52 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___53 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___54 = { 0, 5, 0, 0, 0 };
static cilist io___56 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___57 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___58 = { 0, 5, 0, 0, 0 };
static cilist io___60 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___61 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___62 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___63 = { 0, 5, 0, 0, 0 };
static cilist io___65 = { 0, 6, 0, fmt_9987, 0 };
static cilist io___66 = { 0, 5, 0, 0, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___70 = { 0, 5, 0, 0, 0 };
static cilist io___73 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___74 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___75 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___76 = { 0, 5, 1, "(A80)", 0 };
static cilist io___87 = { 0, 6, 0, fmt_9986, 0 };
static cilist io___88 = { 0, 6, 0, fmt_9986, 0 };
static cilist io___89 = { 0, 6, 0, fmt_9986, 0 };
static cilist io___90 = { 0, 6, 0, fmt_9986, 0 };
static cilist io___91 = { 0, 6, 0, 0, 0 };
static cilist io___92 = { 0, 6, 0, 0, 0 };
static cilist io___93 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___94 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___96 = { 0, 6, 0, fmt_9997, 0 };
#define a_ref(a_1,a_2) a[(a_2)*168000 + a_1 - 168001]
#define d___ref(a_1,a_2) d__[(a_2)*400 + a_1 - 401]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
DTIMEE is the main timing program for the DOUBLE PRECISION matrix
eigenvalue routines in LAPACK.
There are four sets of routines that can be timed:
NEP (Nonsymmetric Eigenvalue Problem):
Includes DGEHRD, DHSEQR, DTREVC, and DHSEIN
SEP (Symmetric Eigenvalue Problem):
Includes DSYTRD, DORGTR, DORMTR, DSTEQR, DSTERF, DPTEQR, DSTEBZ,
DSTEIN, and DSTEDC
SVD (Singular Value Decomposition):
Includes DGEBRD, DBDSQR, DORGBR, DBDSDC and DGESDD
GEP (Generalized nonsymmetric Eigenvalue Problem):
Includes DGGHRD, DHGEQZ, and DTGEVC
Each test path has a different input file. The first line of the
input file should contain the characters NEP, SEP, SVD, or GEP in
columns 1-3. The number of remaining lines depends on what is found
on the first line.
-----------------------------------------------------------------------
NEP input file:
line 2: NN, INTEGER
Number of values of N.
line 3: NVAL, INTEGER array, dimension (NN)
The values for the matrix dimension N.
line 4: NPARM, INTEGER
Number of values of the parameters NB, NS, MAXB, and LDA.
line 5: NBVAL, INTEGER array, dimension (NPARM)
The values for the blocksize NB.
line 6: NSVAL, INTEGER array, dimension (NPARM)
The values for the number of shifts.
line 7: MXBVAL, INTEGER array, dimension (NPARM)
The values for MAXB, used in determining whether multishift
will be used.
line 8: LDAVAL, INTEGER array, dimension (NPARM)
The values for the leading dimension LDA.
line 9: TIMMIN, DOUBLE PRECISION
The minimum time (in seconds) that a subroutine will be
timed. If TIMMIN is zero, each routine should be timed only
once.
line 10: NTYPES, INTEGER
The number of matrix types to be used in the timing run.
If NTYPES >= MAXTYP, all the types are used.
If 0 < NTYPES < MAXTYP, then line 11 specifies NTYPES integer
values, which are the numbers of the matrix types to be used.
The remaining lines specify a path name and the specific routines to
be timed. For the nonsymmetric eigenvalue problem, the path name is
'DHS'. A line to request all the routines in this path has the form
DHS T T T T T T T T T T T T
where the first 3 characters specify the path name, and up to MAXTYP
nonblank characters may appear in columns 4-80. If the k-th such
character is 'T' or 't', the k-th routine will be timed. If at least
one but fewer than 12 nonblank characters are specified, the
remaining routines will not be timed. If columns 4-80 are blank, all
the routines will be timed, so the input line
DHS
is equivalent to the line above.
-----------------------------------------------------------------------
SEP input file:
line 2: NN, INTEGER
Number of values of N.
line 3: NVAL, INTEGER array, dimension (NN)
The values for the matrix dimension N.
line 4: NPARM, INTEGER
Number of values of the parameters NB and LDA.
line 5: NBVAL, INTEGER array, dimension (NPARM)
The values for the blocksize NB.
line 6: LDAVAL, INTEGER array, dimension (NPARM)
The values for the leading dimension LDA.
line 7: TIMMIN, DOUBLE PRECISION
The minimum time (in seconds) that a subroutine will be
timed. If TIMMIN is zero, each routine should be timed only
once.
line 8: NTYPES, INTEGER
The number of matrix types to be used in the timing run.
If NTYPES >= MAXTYP, all the types are used.
If 0 < NTYPES < MAXTYP, then line 9 specifies NTYPES integer
values, which are the numbers of the matrix types to be used.
The remaining lines specify a path name and the specific routines to
be timed as for the NEP input file. For the symmetric eigenvalue
problem, the path name is 'DST' and up to 8 routines may be timed.
-----------------------------------------------------------------------
SVD input file:
line 2: NN, INTEGER
Number of values of M and N.
line 3: MVAL, INTEGER array, dimension (NN)
The values for the matrix dimension M.
line 4: NVAL, INTEGER array, dimension (NN)
The values for the matrix dimension N.
line 5: NPARM, INTEGER
Number of values of the parameters NB and LDA.
line 6: NBVAL, INTEGER array, dimension (NPARM)
The values for the blocksize NB.
line 7: LDAVAL, INTEGER array, dimension (NPARM)
The values for the leading dimension LDA.
line 8: TIMMIN, DOUBLE PRECISION
The minimum time (in seconds) that a subroutine will be
timed. If TIMMIN is zero, each routine should be timed only
once.
line 9: NTYPES, INTEGER
The number of matrix types to be used in the timing run.
If NTYPES >= MAXTYP, all the types are used.
If 0 < NTYPES < MAXTYP, then line 10 specifies NTYPES integer
values, which are the numbers of the matrix types to be used.
The remaining lines specify a path name and the specific routines to
be timed as for the NEP input file. For the singular value
decomposition the path name is 'DBD' and up to 16 routines may be
timed.
-----------------------------------------------------------------------
GEP input file:
line 2: NN, INTEGER
Number of values of N.
line 3: NVAL, INTEGER array, dimension (NN)
The values for the matrix dimension N.
line 4: NPARM, INTEGER
Number of values of the parameters NB, NS, MAXB, and LDA.
line 5: NBVAL, INTEGER array, dimension (NPARM)
The values for the blocksize NB.
line 6: NSVAL, INTEGER array, dimension (NPARM)
The values for the number of shifts.
line 7: NEIVAL, INTEGER array, dimension (NPARM)
The values for NEISP, used in determining whether multishift
will be used.
line 8: NBMVAL, INTEGER array, dimension (NPARM)
The values for MINNB, used in determining minimum blocksize.
line 9: NBKVAL, INTEGER array, dimension (NPARM)
The values for MINBLK, also used in determining minimum
blocksize.
line 10: LDAVAL, INTEGER array, dimension (NPARM)
The values for the leading dimension LDA.
line 11: TIMMIN, DOUBLE PRECISION
The minimum time (in seconds) that a subroutine will be
timed. If TIMMIN is zero, each routine should be timed only
once.
line 12: NTYPES, INTEGER
The number of matrix types to be used in the timing run.
If NTYPES >= MAXTYP, all the types are used.
If 0 < NTYPES < MAXTYP, then line 13 specifies NTYPES integer
values, which are the numbers of the matrix types to be used.
The remaining lines specify a path name and the specific routines to
be timed. For the nonsymmetric eigenvalue problem, the path name is
'DHG'. A line to request all the routines in this path has the form
DHG T T T T T T T T T T T T T T T T T T
where the first 3 characters specify the path name, and up to MAXTYP
nonblank characters may appear in columns 4-80. If the k-th such
character is 'T' or 't', the k-th routine will be timed. If at least
one but fewer than 18 nonblank characters are specified, the
remaining routines will not be timed. If columns 4-80 are blank, all
the routines will be timed, so the input line
DHG
is equivalent to the line above.
=======================================================================
The workspace requirements in terms of square matrices for the
different test paths are as follows:
NEP: 3 N**2 + N*(3*NB+2)
SEP: 2 N**2 + N*(2*N) + N
SVD: 4 N**2 + MAX( 6*N, MAXIN*MAXPRM*MAXT )
GEP: 6 N**2 + 3*N
MAXN is currently set to 400,
LG2MXN = ceiling of log-base-2 of MAXN = 9, and LDAMAX = 420.
The real work space needed is LWORK = MAX( MAXN*(4*MAXN+2),
2*LDAMAX+1+3*MAXN+2*MAXN*LG2MXN+3*MAXN**2 ), and the integer
workspace needed is LIWRK2 = 6 + 6*MAXN + 5*MAXN*LG2MXN.
For SVD, we assume NRHS may be as big
as N. The parameter NEED is set to 4 to allow for 4 NxN matrices
for SVD. */
s1 = dsecnd_();
fatal = FALSE_;
nep = FALSE_;
sep = FALSE_;
svd = FALSE_;
gep = FALSE_;
/* Read the 3-character test path */
i__1 = s_rsfe(&io___9);
if (i__1 != 0) {
goto L160;
}
i__1 = do_fio(&c__1, path, (ftnlen)3);
if (i__1 != 0) {
goto L160;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L160;
}
nep = lsamen_(&c__3, path, "NEP") || lsamen_(&c__3,
path, "DHS");
sep = lsamen_(&c__3, path, "SEP") || lsamen_(&c__3,
path, "DST");
svd = lsamen_(&c__3, path, "SVD") || lsamen_(&c__3,
path, "DBD");
gep = lsamen_(&c__3, path, "GEP") || lsamen_(&c__3,
path, "DHG");
/* Report values of parameters as they are read. */
if (nep) {
s_wsfe(&io___11);
e_wsfe();
} else if (sep) {
s_wsfe(&io___12);
e_wsfe();
} else if (svd) {
s_wsfe(&io___13);
e_wsfe();
} else if (gep) {
s_wsfe(&io___14);
e_wsfe();
} else {
s_wsfe(&io___15);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
s_stop("", (ftnlen)0);
}
s_wsfe(&io___16);
e_wsfe();
s_wsfe(&io___17);
e_wsfe();
/* Read the number of values of M and N. */
s_rsle(&io___18);
do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
e_rsle();
if (nn < 1) {
s_wsfe(&io___20);
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___21);
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_;
}
/* Read the values of M */
s_rsle(&io___22);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
if (svd) {
s_copy(vname, " M", (ftnlen)6, (ftnlen)3);
} else {
s_copy(vname, " N", (ftnlen)6, (ftnlen)3);
}
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
if (mval[i__ - 1] < 0) {
s_wsfe(&io___26);
do_fio(&c__1, vname, (ftnlen)6);
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] > 400) {
s_wsfe(&io___27);
do_fio(&c__1, vname, (ftnlen)6);
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__400, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L10: */
}
/* Read the values of N */
if (svd) {
s_wsfe(&io___28);
do_fio(&c__1, "M ", (ftnlen)4);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
s_rsle(&io___29);
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___31);
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] > 400) {
s_wsfe(&io___32);
do_fio(&c__1, "N ", (ftnlen)4);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&c__400, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L20: */
}
} else {
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
nval[i__ - 1] = mval[i__ - 1];
/* L30: */
}
}
s_wsfe(&io___33);
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 number of parameter values. */
s_rsle(&io___34);
do_lio(&c__3, &c__1, (char *)&nparms, (ftnlen)sizeof(integer));
e_rsle();
if (nparms < 1) {
s_wsfe(&io___36);
do_fio(&c__1, "NPARMS", (ftnlen)6);
do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
e_wsfe();
nparms = 0;
fatal = TRUE_;
} else if (nparms > 12) {
s_wsfe(&io___37);
do_fio(&c__1, "NPARMS", (ftnlen)6);
do_fio(&c__1, (char *)&nparms, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__12, (ftnlen)sizeof(integer));
e_wsfe();
nparms = 0;
fatal = TRUE_;
}
/* Read the values of NB */
s_rsle(&io___38);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer))
;
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nbval[i__ - 1] < 0) {
s_wsfe(&io___40);
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: */
}
s_wsfe(&io___41);
do_fio(&c__1, "NB ", (ftnlen)4);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
if (nep || gep) {
/* Read the values of NSHIFT */
s_rsle(&io___42);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nsval[i__ - 1] < 0) {
s_wsfe(&io___44);
do_fio(&c__1, "NS ", (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_;
}
/* L50: */
}
s_wsfe(&io___45);
do_fio(&c__1, "NS ", (ftnlen)4);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nsval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Read the values of MAXB */
s_rsle(&io___46);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (mxbval[i__ - 1] < 0) {
s_wsfe(&io___48);
do_fio(&c__1, "MAXB", (ftnlen)4);
do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L60: */
}
s_wsfe(&io___49);
do_fio(&c__1, "MAXB", (ftnlen)4);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&mxbval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
} else {
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
nsval[i__ - 1] = 1;
mxbval[i__ - 1] = 1;
/* L70: */
}
}
if (gep) {
/* Read the values of NBMIN */
s_rsle(&io___50);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nbmval[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nbmval[i__ - 1] < 0) {
s_wsfe(&io___52);
do_fio(&c__1, "NBMIN", (ftnlen)5);
do_fio(&c__1, (char *)&nbmval[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L80: */
}
s_wsfe(&io___53);
do_fio(&c__1, "NBMIN", (ftnlen)5);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbmval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Read the values of MINBLK */
s_rsle(&io___54);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&nbkval[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (nbkval[i__ - 1] < 0) {
s_wsfe(&io___56);
do_fio(&c__1, "MINBLK", (ftnlen)6);
do_fio(&c__1, (char *)&nbkval[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L90: */
}
s_wsfe(&io___57);
do_fio(&c__1, "MINBLK", (ftnlen)6);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbkval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
} else {
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
nbmval[i__ - 1] = 401;
nbkval[i__ - 1] = 401;
/* L100: */
}
}
/* Read the values of LDA */
s_rsle(&io___58);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer)
);
}
e_rsle();
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
if (ldaval[i__ - 1] < 0) {
s_wsfe(&io___60);
do_fio(&c__1, "LDA ", (ftnlen)4);
do_fio(&c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (ldaval[i__ - 1] > 420) {
s_wsfe(&io___61);
do_fio(&c__1, "LDA ", (ftnlen)4);
do_fio(&c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__420, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L110: */
}
s_wsfe(&io___62);
do_fio(&c__1, "LDA ", (ftnlen)4);
i__1 = nparms;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Read the minimum time a subroutine will be timed. */
s_rsle(&io___63);
do_lio(&c__5, &c__1, (char *)&timmin, (ftnlen)sizeof(doublereal));
e_rsle();
s_wsfe(&io___65);
do_fio(&c__1, (char *)&timmin, (ftnlen)sizeof(doublereal));
e_wsfe();
/* Read the number of matrix types to use in timing. */
s_rsle(&io___66);
do_lio(&c__3, &c__1, (char *)&ntypes, (ftnlen)sizeof(integer));
e_rsle();
if (ntypes < 0) {
s_wsfe(&io___68);
do_fio(&c__1, "NTYPES", (ftnlen)6);
do_fio(&c__1, (char *)&ntypes, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
ntypes = 0;
}
/* Read the matrix types. */
if (nep) {
maxtyp = mxtype[0];
} else if (sep) {
maxtyp = mxtype[1];
} else if (svd) {
maxtyp = mxtype[2];
} else {
maxtyp = mxtype[3];
}
if (ntypes < maxtyp) {
s_rsle(&io___70);
i__1 = ntypes;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&iwork[i__ - 1], (ftnlen)sizeof(
integer));
}
e_rsle();
i__1 = maxtyp;
for (i__ = 1; i__ <= i__1; ++i__) {
dotype[i__ - 1] = FALSE_;
/* L120: */
}
i__1 = ntypes;
for (i__ = 1; i__ <= i__1; ++i__) {
if (iwork[i__ - 1] < 0) {
s_wsfe(&io___73);
do_fio(&c__1, "TYPE", (ftnlen)4);
do_fio(&c__1, (char *)&iwork[i__ - 1], (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&c__0, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else if (iwork[i__ - 1] > maxtyp) {
s_wsfe(&io___74);
do_fio(&c__1, "TYPE", (ftnlen)4);
do_fio(&c__1, (char *)&iwork[i__ - 1], (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&maxtyp, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
} else {
dotype[iwork[i__ - 1] - 1] = TRUE_;
}
/* L130: */
}
} else {
ntypes = maxtyp;
for (i__ = 1; i__ <= 10; ++i__) {
dotype[i__ - 1] = TRUE_;
/* L140: */
}
}
if (fatal) {
s_wsfe(&io___75);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* Read the input lines indicating the test path and the routines
to be timed. The first three characters indicate the test path. */
L150:
i__1 = s_rsfe(&io___76);
if (i__1 != 0) {
goto L160;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L160;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L160;
}
s_copy(c3, line, (ftnlen)3, (ftnlen)3);
/* -------------------------------------
NEP: Nonsymmetric Eigenvalue Problem
------------------------------------- */
if (lsamen_(&c__3, c3, "DHS") || lsamen_(&c__3, c3,
"NEP")) {
dtim21_(line, &nn, nval, &maxtyp, dotype, &nparms, nbval, nsval,
mxbval, ldaval, &timmin, &c__6, iseed, &a_ref(1, 1), &a_ref(1,
2), &a_ref(1, 3), &d___ref(1, 1), work, &c_b226, logwrk,
iwork2, result, &c__10, &c__10, &c__12, opcnts, &c__10, &
c__10, &c__12, &info, (ftnlen)80);
if (info != 0) {
s_wsfe(&io___87);
do_fio(&c__1, "DTIM21", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
e_wsfe();
}
/* ----------------------------------
SEP: Symmetric Eigenvalue Problem
---------------------------------- */
} else if (lsamen_(&c__3, c3, "DST") || lsamen_(&
c__3, c3, "SEP")) {
dtim22_(line, &nn, nval, &maxtyp, dotype, &nparms, nbval, ldaval, &
timmin, &c__6, iseed, &a_ref(1, 1), &d___ref(1, 1), &d___ref(
1, 2), &d___ref(1, 3), &a_ref(1, 2), &a_ref(1, 3), work, &
c_b226, logwrk, iwork2, result, &c__10, &c__10, &c__12,
opcnts, &c__10, &c__10, &c__12, &info, (ftnlen)80);
if (info != 0) {
s_wsfe(&io___88);
do_fio(&c__1, "DTIM22", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
e_wsfe();
}
/* ----------------------------------
SVD: Singular Value Decomposition
---------------------------------- */
} else if (lsamen_(&c__3, c3, "DBD") || lsamen_(&
c__3, c3, "SVD")) {
dtim26_(line, &nn, nval, mval, &maxtyp, dotype, &nparms, nbval,
ldaval, &timmin, &c__6, iseed, &a_ref(1, 1), &a_ref(1, 2), &
a_ref(1, 3), &a_ref(1, 4), &d___ref(1, 1), &d___ref(1, 2), &
d___ref(1, 3), &d___ref(1, 4), work, &c_b226, iwork2, logwrk,
result, &c__10, &c__10, &c__12, opcnts, &c__10, &c__10, &
c__12, &info, (ftnlen)80);
if (info != 0) {
s_wsfe(&io___89);
do_fio(&c__1, "DTIM26", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
e_wsfe();
}
/* -------------------------------------------------
GEP: Generalized Nonsymmetric Eigenvalue Problem
------------------------------------------------- */
} else if (lsamen_(&c__3, c3, "DHG") || lsamen_(&
c__3, c3, "GEP")) {
dtim51_(line, &nn, nval, &maxtyp, dotype, &nparms, nbval, nsval,
mxbval, nbmval, nbkval, ldaval, &timmin, &c__6, iseed, &a_ref(
1, 1), &a_ref(1, 2), &a_ref(1, 3), &a_ref(1, 4), &a_ref(1, 5),
&a_ref(1, 6), &d___ref(1, 1), work, &c_b226, logwrk, result,
&c__10, &c__10, &c__12, opcnts, &c__10, &c__10, &c__12, &info,
(ftnlen)80);
if (info != 0) {
s_wsfe(&io___90);
do_fio(&c__1, "DTIM51", (ftnlen)6);
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
e_wsfe();
}
} else {
s_wsle(&io___91);
e_wsle();
s_wsle(&io___92);
e_wsle();
s_wsfe(&io___93);
do_fio(&c__1, c3, (ftnlen)3);
e_wsfe();
}
goto L150;
L160:
s_wsfe(&io___94);
e_wsfe();
s2 = dsecnd_();
s_wsfe(&io___96);
d__1 = s2 - s1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
/* End of DTIMEE */
return 0;
} /* MAIN__ */
/* Subroutine */ int alareq_(char *path, integer *nmats, logical *dotype,
integer *ntypes, integer *nin, integer *nout)
{
/* Initialized data */
static char intstr[10] = "0123456789";
/* Format strings */
static char fmt_9995[] = "(//\002 *** Not enough matrix types on input l"
"ine\002,/a79)";
static char fmt_9994[] = "(\002 ==> Specify \002,i4,\002 matrix types on"
" this line or \002,\002adjust NTYPES on previous line\002)";
static char fmt_9996[] = "(//\002 *** Invalid integer value in column"
" \002,i2,\002 of input\002,\002 line:\002,/a79)";
static char fmt_9997[] = "(\002 *** Warning: duplicate request of matri"
"x type \002,i2,\002 for \002,a3)";
static char fmt_9999[] = "(\002 *** Invalid type request for \002,a3,"
"\002, type \002,i4,\002: must satisfy 1 <= type <= \002,i2)";
static char fmt_9998[] = "(/\002 *** End of file reached when trying to "
"read matrix \002,\002types for \002,a3,/\002 *** Check that you "
"are requesting the\002,\002 right number of types for each pat"
"h\002,/)";
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
i_len(char *, ftnlen), s_wsfe(cilist *), e_wsfe(void), s_wsle(
cilist *), e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static char line[80];
static integer lenp, nreq[100], i__, j, k;
static char c1[1];
static integer i1, ic, nt;
static logical firstt;
/* Fortran I/O blocks */
static cilist io___4 = { 0, 0, 1, "(A80)", 0 };
static cilist io___10 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___18 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___21 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___22 = { 0, 0, 0, 0, 0 };
/* -- 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
Purpose
=======
ALAREQ handles input for the LAPACK test program. It is called
to evaluate the input line which requested NMATS matrix types for
PATH. The flow of control is as follows:
If NMATS = NTYPES then
DOTYPE(1:NTYPES) = .TRUE.
else
Read the next input line for NMATS matrix types
Set DOTYPE(I) = .TRUE. for each valid type I
endif
Arguments
=========
PATH (input) CHARACTER*3
An LAPACK path name for testing.
NMATS (input) INTEGER
The number of matrix types to be used in testing this path.
DOTYPE (output) LOGICAL array, dimension (NTYPES)
The vector of flags indicating if each type will be tested.
NTYPES (input) INTEGER
The maximum number of matrix types for this path.
NIN (input) INTEGER
The unit number for input. NIN >= 1.
NOUT (input) INTEGER
The unit number for output. NOUT >= 1.
=====================================================================
Parameter adjustments */
--dotype;
/* Function Body */
if (*nmats >= *ntypes) {
/* Test everything if NMATS >= NTYPES. */
i__1 = *ntypes;
for (i__ = 1; i__ <= i__1; ++i__) {
dotype[i__] = TRUE_;
/* L10: */
}
} else {
i__1 = *ntypes;
for (i__ = 1; i__ <= i__1; ++i__) {
dotype[i__] = FALSE_;
/* L20: */
}
firstt = TRUE_;
/* Read a line of matrix types if 0 < NMATS < NTYPES. */
if (*nmats > 0) {
io___4.ciunit = *nin;
i__1 = s_rsfe(&io___4);
if (i__1 != 0) {
goto L90;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L90;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L90;
}
lenp = i_len(line, (ftnlen)80);
i__ = 0;
i__1 = *nmats;
for (j = 1; j <= i__1; ++j) {
nreq[j - 1] = 0;
i1 = 0;
L30:
++i__;
if (i__ > lenp) {
if (j == *nmats && i1 > 0) {
goto L60;
} else {
io___10.ciunit = *nout;
s_wsfe(&io___10);
do_fio(&c__1, line, (ftnlen)80);
e_wsfe();
io___11.ciunit = *nout;
s_wsfe(&io___11);
do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(
integer));
e_wsfe();
goto L80;
}
}
if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned
char *)&line[i__ - 1] != ',') {
i1 = i__;
*(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
/* Check that a valid integer was read */
for (k = 1; k <= 10; ++k) {
if (*(unsigned char *)c1 == *(unsigned char *)&intstr[
k - 1]) {
ic = k - 1;
goto L50;
}
/* L40: */
}
io___15.ciunit = *nout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, line, (ftnlen)80);
e_wsfe();
io___16.ciunit = *nout;
s_wsfe(&io___16);
do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(integer));
e_wsfe();
goto L80;
L50:
nreq[j - 1] = nreq[j - 1] * 10 + ic;
goto L30;
} else if (i1 > 0) {
goto L60;
} else {
goto L30;
}
L60:
;
}
}
i__1 = *nmats;
for (i__ = 1; i__ <= i__1; ++i__) {
nt = nreq[i__ - 1];
if (nt > 0 && nt <= *ntypes) {
if (dotype[nt]) {
if (firstt) {
io___18.ciunit = *nout;
s_wsle(&io___18);
e_wsle();
}
firstt = FALSE_;
io___19.ciunit = *nout;
s_wsfe(&io___19);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
dotype[nt] = TRUE_;
} else {
io___20.ciunit = *nout;
s_wsfe(&io___20);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*ntypes), (ftnlen)sizeof(integer));
e_wsfe();
}
/* L70: */
}
L80:
;
}
return 0;
L90:
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___22.ciunit = *nout;
s_wsle(&io___22);
e_wsle();
s_stop("", (ftnlen)0);
/* End of ALAREQ */
return 0;
} /* alareq_ */
/* Main program */ int MAIN__(void)
{
/* Initialized data */
static char intstr[10] = "0123456789";
/* Format strings */
static char fmt_9994[] = "(\002 Tests of the DOUBLE PRECISION LAPACK DSG"
"ESV/DSPOSV\002,\002 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,a6,\002 routines were not tested\002)";
static char fmt_9989[] = "(/1x,a6,\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;
doublereal d__1;
cilist ci__1;
cllist cl__1;
/* Local variables */
doublereal a[34848] /* was [17424][2] */, b[4224] /* was [2112][2] */;
integer i__, k;
char c1[1], c2[2];
doublereal s1, s2;
integer ic, nm, vers_patch__, vers_major__, vers_minor__, lda;
doublereal eps;
integer nns;
char path[3];
integer mval[12], nrhs;
real seps;
doublereal work[4224];
logical fatal;
char aline[72];
integer nmats, nsval[12], iwork[132];
doublereal rwork[132];
real swork[19536];
doublereal thresh;
logical dotype[30];
integer ntypes;
logical tsterr, tstdrv;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 5, 0, 0, 0 };
static cilist io___9 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___10 = { 0, 5, 0, 0, 0 };
static cilist io___12 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___13 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___14 = { 0, 5, 0, 0, 0 };
static cilist io___17 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___18 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___19 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___20 = { 0, 5, 0, 0, 0 };
static cilist io___22 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___23 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___24 = { 0, 5, 0, 0, 0 };
static cilist io___26 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___27 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___28 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___29 = { 0, 5, 0, 0, 0 };
static cilist io___31 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___32 = { 0, 5, 0, 0, 0 };
static cilist io___34 = { 0, 5, 0, 0, 0 };
static cilist io___36 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___38 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___39 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___40 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___41 = { 0, 6, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, fmt_9991, 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, 0, 0 };
static cilist io___55 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___56 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___65 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___66 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___69 = { 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 */
/* ======= */
/* DCHKAB is the test program for the DOUBLE PRECISION LAPACK */
/* DSGESV/DSPOSV routine */
/* The program must be driven by a short data file. The first 5 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 10 lines: */
/* Data file for testing DOUBLE PRECISION LAPACK DSGESV */
/* 7 Number of values of M */
/* 0 1 2 3 5 10 16 Values of M (row dimension) */
/* 1 Number of values of NRHS */
/* 2 Values of NRHS (number of right hand sides) */
/* 20.0 Threshold value of test ratio */
/* T Put T to test the LAPACK routines */
/* T Put T to test the error exits */
/* DGE 11 List types on next line if 0 < NTYPES < 11 */
/* DPO 9 List types on next line if 0 < NTYPES < 9 */
/* 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, NRHS, NB, and NX */
/* 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 .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Data statements .. */
/* .. */
/* .. Executable Statements .. */
s1 = dsecnd_();
lda = 132;
fatal = FALSE_;
/* Read a dummy line. */
s_rsle(&io___5);
e_rsle();
/* Report values of parameters. */
ilaver_(&vers_major__, &vers_minor__, &vers_patch__);
s_wsfe(&io___9);
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___10);
do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
e_rsle();
if (nm < 1) {
s_wsfe(&io___12);
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___13);
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___14);
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___17);
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___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__132, (ftnlen)sizeof(integer));
e_wsfe();
fatal = TRUE_;
}
/* L10: */
}
if (nm > 0) {
s_wsfe(&io___19);
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 NRHS */
s_rsle(&io___20);
do_lio(&c__3, &c__1, (char *)&nns, (ftnlen)sizeof(integer));
e_rsle();
if (nns < 1) {
s_wsfe(&io___22);
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___23);
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___24);
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___26);
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___27);
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___28);
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 threshold value for the test ratios. */
s_rsle(&io___29);
do_lio(&c__5, &c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_rsle();
s_wsfe(&io___31);
do_fio(&c__1, (char *)&thresh, (ftnlen)sizeof(doublereal));
e_wsfe();
/* Read the flag that indicates whether to test the driver routine. */
s_rsle(&io___32);
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___34);
do_lio(&c__8, &c__1, (char *)&tsterr, (ftnlen)sizeof(logical));
e_rsle();
if (fatal) {
s_wsfe(&io___36);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* Calculate and print the machine dependent constants. */
seps = slamch_("Underflow threshold");
s_wsfe(&io___38);
do_fio(&c__1, "(single precision) underflow", (ftnlen)28);
do_fio(&c__1, (char *)&seps, (ftnlen)sizeof(real));
e_wsfe();
seps = slamch_("Overflow threshold");
s_wsfe(&io___39);
do_fio(&c__1, "(single precision) overflow ", (ftnlen)28);
do_fio(&c__1, (char *)&seps, (ftnlen)sizeof(real));
e_wsfe();
seps = slamch_("Epsilon");
s_wsfe(&io___40);
do_fio(&c__1, "(single precision) precision", (ftnlen)28);
do_fio(&c__1, (char *)&seps, (ftnlen)sizeof(real));
e_wsfe();
s_wsle(&io___41);
e_wsle();
eps = dlamch_("Underflow threshold");
s_wsfe(&io___43);
do_fio(&c__1, "(double precision) underflow", (ftnlen)28);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Overflow threshold");
s_wsfe(&io___44);
do_fio(&c__1, "(double precision) overflow ", (ftnlen)28);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
eps = dlamch_("Epsilon");
s_wsfe(&io___45);
do_fio(&c__1, "(double precision) precision", (ftnlen)28);
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(doublereal));
e_wsfe();
s_wsle(&io___46);
e_wsle();
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) {
nmats = 30;
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);
nrhs = nsval[0];
/* Check first character for correct precision. */
if (! lsame_(c1, "Double precision")) {
s_wsfe(&io___55);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
} else if (nmats <= 0) {
/* Check for a positive number of tests requested. */
s_wsfe(&io___56);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
goto L140;
} else if (lsamen_(&c__2, c2, "GE")) {
/* GE: general matrices */
ntypes = 11;
alareq_("DGE", &nmats, dotype, &ntypes, &c__5, &c__6);
/* Test the error exits */
if (tsterr) {
derrab_(&c__6);
}
if (tstdrv) {
ddrvab_(dotype, &nm, mval, &nns, nsval, &thresh, &lda, a, &a[
17424], b, &b[2112], work, rwork, swork, iwork, &c__6);
} else {
s_wsfe(&io___65);
do_fio(&c__1, "DSGESV", (ftnlen)6);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PO")) {
/* PO: positive definite matrices */
ntypes = 9;
alareq_("DPO", &nmats, dotype, &ntypes, &c__5, &c__6);
if (tsterr) {
derrac_(&c__6);
}
if (tstdrv) {
ddrvac_(dotype, &nm, mval, &nns, nsval, &thresh, &lda, a, &a[
17424], b, &b[2112], work, rwork, swork, &c__6);
} else {
s_wsfe(&io___66);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
} else {
}
/* 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___68);
e_wsfe();
s_wsfe(&io___69);
d__1 = s2 - s1;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
/* L9988: */
/* End of DCHKAB */
return 0;
} /* MAIN__ */
/* PURE fio_ersfe PUREGVA */
int fio_ersfe(void)
{
return e_rsfe();
}
/* ----------------------------------------------------------------------- */
/* Main program */ int MAIN__(void)
{
/* System generated locals */
address a__1[7];
integer i__1, i__2[7], i__3, i__4;
alist al__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer f_rew(alist *), s_wsfe(cilist *), e_wsfe(void), s_wsfi(icilist *),
e_wsfi(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer i__, l, m, ld;
static char cmd[4];
static integer irc;
static real data[6];
static integer leng;
static char line[72];
static integer nred, nmem, ipos, kpos, iout;
static char type__[1];
static real work[300000];
static integer ldata;
static char aleng[6];
extern /* Subroutine */ int pdsin_(char *, char *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer iomls, iotxt;
extern /* Subroutine */ int setli1_(char *, integer *, real *, integer *,
ftnlen), setli2_(char *, integer *, real *, integer *, ftnlen),
setli3_(char *, integer *, real *, integer *, ftnlen);
static char member[8], dirnam[72], memnam[8*4000];
extern /* Subroutine */ int setlin_(char *, integer *, real *, ftnlen),
memlst_(integer *, integer *, char *, ftnlen), uioset_(void),
txtlin_(integer *, integer *);
/* Fortran I/O blocks */
static cilist io___7 = { 0, 5, 0, "(A72)", 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___13 = { 0, 0, 0, "(A72)", 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 6, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, 0, 0 };
static icilist io___26 = { 0, aleng, 0, "(I6)", 6, 1 };
static cilist io___27 = { 0, 0, 0, "(A72)", 0 };
static cilist io___35 = { 0, 0, 0, "(A72)", 0 };
static cilist io___36 = { 0, 0, 0, "(A72)", 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 };
/* ----- IO DEVICE */
/* IOTXT : TEXT PDS (WRITE) */
/* IOMLS : MEMBER LIST (READ) */
/* IOUT : STANDARD OUTPUT (WRITE) */
/* 49 : DEVICE FOR PDS MEMBER, INTERNALLY OPENED AND CLOSED (READ) */
/* 5 : STANDARD INPUT FOR DIRECTORY NAME OF PDS FILE */
uioset_();
iotxt = 10;
iomls = 11;
iout = 6;
nred = 0;
s_copy(cmd, "*PUT", (ftnlen)4, (ftnlen)4);
*(unsigned char *)type__ = 'N';
/* ******************** */
/* READ INPUT DATA * */
/* ******************** */
/* DIRNAM : FULL NAME OF DIRECTORY FOR PDS */
/* EX:/DG05/UFS02/J9347/SRAC95/LIB/PDS/PFAST/PFASTJ2 */
s_rsfe(&io___7);
do_fio(&c__1, dirnam, (ftnlen)72);
e_rsfe();
if (*(unsigned char *)dirnam == ' ') {
s_wsle(&io___9);
do_lio(&c__9, &c__1, " ERROR(MAIN) : DIRECTORY NAME IS INVALID", (
ftnlen)40);
e_wsle();
s_wsle(&io___10);
do_lio(&c__9, &c__1, " THE FIRST COLUMN SHOULD BE NON-BLANK", (ftnlen)
37);
e_wsle();
s_wsle(&io___11);
do_lio(&c__9, &c__1, " DIRNAM = ", (ftnlen)10);
do_lio(&c__9, &c__1, dirnam, (ftnlen)72);
e_wsle();
s_stop("", (ftnlen)0);
}
/* ************************ */
/* WRITE HEADER IN TEXT * */
/* ************************ */
al__1.aerr = 0;
al__1.aunit = iotxt;
f_rew(&al__1);
s_copy(line, " 3 PDSEDT INPUT R/W MODE ", (ftnlen)72, (ftnlen)34)
;
io___13.ciunit = iotxt;
s_wsfe(&io___13);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
/* ******************** */
/* READ MEMBER LIST * */
/* ******************** */
memlst_(&iomls, &nmem, memnam, (ftnlen)8);
if (nmem > 4000) {
s_wsle(&io___16);
do_lio(&c__9, &c__1, " ERROR (MAIN) : MAX OF MEMBER(MAXME=", (ftnlen)
36);
do_lio(&c__3, &c__1, (char *)&c__4000, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS LESS THAN REQUIRED SIZE(=", (ftnlen)30);
do_lio(&c__3, &c__1, (char *)&nmem, (ftnlen)sizeof(integer));
e_wsle();
s_stop("", (ftnlen)0);
}
/* ******************** */
/* LOOP ON MEMBER * */
/* ******************** */
i__1 = nmem;
for (m = 1; m <= i__1; ++m) {
s_copy(member, memnam + (m - 1 << 3), (ftnlen)8, (ftnlen)8);
setdt_1.ntnuc1 = 0;
setdt_1.ntnuc2 = 0;
setdt_1.nzon2 = 0;
setdt_1.nzon3 = 0;
/* *************************** */
/* READ CONTENTS OF MEMBER * */
/* *************************** */
pdsin_(dirnam, member, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)
8);
if (irc != 0) {
s_wsle(&io___22);
do_lio(&c__9, &c__1, " PDS ERROR : ERROR CODE = ", (ftnlen)26);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___23);
do_lio(&c__9, &c__1, " MEMBER = ", (ftnlen)10);
do_lio(&c__9, &c__1, member, (ftnlen)8);
e_wsle();
s_stop("", (ftnlen)0);
} else {
++nred;
}
if (leng > 300000) {
s_wsle(&io___24);
do_lio(&c__9, &c__1, " ERROR (MAIN) : WORK AREA(MAXWK=", (ftnlen)
32);
do_lio(&c__3, &c__1, (char *)&c_b48, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS LESS THAN REQUIRED SIZE(=", (ftnlen)30)
;
do_lio(&c__3, &c__1, (char *)&leng, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " IN MEMBER:", (ftnlen)11);
do_lio(&c__9, &c__1, member, (ftnlen)8);
e_wsle();
s_stop("", (ftnlen)0);
}
/* ***************** */
/* WRITE IN TEXT * */
/* ***************** */
/* ----- WRITE MEMBER NAME AND LENGTH */
s_wsfi(&io___26);
do_fio(&c__1, (char *)&leng, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__1[0] = cmd;
i__2[1] = 1, a__1[1] = " ";
i__2[2] = 8, a__1[2] = member;
i__2[3] = 1, a__1[3] = " ";
i__2[4] = 1, a__1[4] = type__;
i__2[5] = 1, a__1[5] = " ";
i__2[6] = 6, a__1[6] = aleng;
s_cat(line, a__1, i__2, &c__7, (ftnlen)72);
io___27.ciunit = iotxt;
s_wsfe(&io___27);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
/* ----- SET NUMBER OF LINES TO WRITE IN TEXT FOR DATA OF A MEMBER */
txtlin_(&leng, &ldata);
/* ----- SET LINE DATA AND WRITE IN TEXT */
i__3 = ldata;
for (l = 1; l <= i__3; ++l) {
kpos = (l - 1) * 6 + 1;
if (l != ldata) {
ld = 6;
} else {
ld = leng - (ldata - 1) * 6;
}
i__4 = ld;
for (i__ = 1; i__ <= i__4; ++i__) {
ipos = (l - 1) * 6 + i__;
data[i__ - 1] = work[ipos - 1];
/* L110: */
}
if (s_cmp(member + 4, "DN", (ftnlen)2, (ftnlen)2) == 0 && *(
unsigned char *)&member[7] == 'T') {
setli1_(line, &ld, data, &kpos, (ftnlen)72);
} else if (s_cmp(member + 4, "BNUP", (ftnlen)4, (ftnlen)4) == 0) {
setli2_(line, &ld, data, &kpos, (ftnlen)72);
} else if (s_cmp(member + 4, "REST", (ftnlen)4, (ftnlen)4) == 0) {
setli3_(line, &ld, data, &kpos, (ftnlen)72);
} else {
setlin_(line, &ld, data, (ftnlen)72);
}
io___35.ciunit = iotxt;
s_wsfe(&io___35);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
/* L100: */
}
/* L1000: */
}
/* *********** */
/* FINISH * */
/* *********** */
s_copy(line, "*FIN", (ftnlen)72, (ftnlen)4);
io___36.ciunit = iotxt;
s_wsfe(&io___36);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
io___37.ciunit = iout;
s_wsle(&io___37);
e_wsle();
io___38.ciunit = iout;
s_wsle(&io___38);
do_lio(&c__9, &c__1, " NUMBER OF MEMBERS READ FROM PDS=", (ftnlen)33);
do_lio(&c__3, &c__1, (char *)&nred, (ftnlen)sizeof(integer));
e_wsle();
io___39.ciunit = iout;
s_wsle(&io___39);
do_lio(&c__9, &c__1, " ********** JOB END **********", (ftnlen)30);
e_wsle();
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* Subroutine */ int getgeg_(integer *iread, integer *labels, doublereal *geo,
integer *na, integer *nb, integer *nc, doublereal *ams, integer *
natoms, logical *int__)
{
/* Initialized data */
static char elemnt[2*107] = " H" "HE" "LI" "BE" " B" " C" " N" " O" " F"
"NE" "NA" "MG" "AL" "SI" " P" " S" "CL" "AR" "K " "CA" "SC" "TI"
" V" "CR" "MN" "FE" "CO" "NI" "CU" "ZN" "GA" "GE" "AS" "SE" "BR"
"KR" "RB" "SR" " Y" "ZR" "NB" "MO" "TC" "RU" "RH" "PD" "AG" "CD"
"IN" "SN" "SB" "TE" " I" "XE" "CS" "BA" "LA" "CE" "PR" "ND" "PM"
"SM" "EU" "GD" "TB" "DY" "HO" "ER" "TM" "YB" "LU" "HF" "TA" " W"
"RE" "OS" "IR" "PT" "AU" "HG" "TL" "PB" "BI" "PO" "AT" "RN" "FR"
"RA" "AC" "TH" "PA" "U " "NP" "PU" "AM" "CM" "BK" "CF" "XX" "FM"
"MD" "CB" "++" " +" "--" " -" "TV";
/* System generated locals */
address a__1[2], a__2[2];
integer i__1, i__2, i__3[2], i__4[2];
char ch__1[81], ch__2[3], ch__3[29];
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen), i_indx(char *, char *,
ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
char **, integer *, integer *, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
double asin(doublereal);
/* Local variables */
static integer i__, j, k, l, n;
static doublereal sum;
static integer lgeo[300] /* was [3][100] */;
static char line[80], tgeo[12*3*100];
static integer ivar, kerr, merr, nerr, lerr;
extern doublereal reada_(char *, integer *, ftnlen);
static integer iline, numat;
static doublereal degree;
static logical leadsp;
extern /* Subroutine */ int getval_(char *, doublereal *, char *, ftnlen,
ftnlen);
static integer nvalue, istart[20];
static char string[80];
static integer maxtxt;
/* Fortran I/O blocks */
static cilist io___5 = { 1, 0, 1, "(A)", 0 };
static cilist io___15 = { 0, 6, 0, "(2A)", 0 };
static cilist io___16 = { 0, 6, 0, "(' FOR ATOM',I4,' ISOTOPIC MASS:' "
" ,F15.5)", 0 };
static cilist io___21 = { 1, 0, 1, "(A)", 0 };
static cilist io___27 = { 0, 6, 0, "(A)", 0 };
static cilist io___28 = { 0, 6, 0, "(A)", 0 };
static cilist io___29 = { 0, 6, 0, "(2A)", 0 };
static cilist io___30 = { 0, 6, 0, "(2A)", 0 };
static cilist io___31 = { 0, 6, 0, "(2A)", 0 };
static cilist io___32 = { 0, 6, 0, "(I4,A)", 0 };
static cilist io___33 = { 0, 6, 0, "(A,I3,A)", 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 */
/* Parameter adjustments */
--ams;
--nc;
--nb;
--na;
geo -= 4;
--labels;
/* Function Body */
nerr = 0;
*int__ = TRUE_;
numat = 0;
na[1] = 0;
nb[1] = 0;
nc[1] = 0;
nb[2] = 0;
nc[2] = 0;
nc[3] = 0;
maxtxt = 0;
for (*natoms = 1; *natoms <= 100; ++(*natoms)) {
io___5.ciunit = *iread;
i__1 = s_rsfe(&io___5);
if (i__1 != 0) {
goto L70;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L70;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L70;
}
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) == 0) {
goto L70;
}
/* SEE IF TEXT IS ASSOCIATED WITH THIS ELEMENT */
i__ = i_indx(line, "(", (ftnlen)80, (ftnlen)1);
if (i__ != 0) {
/* YES, ELEMENT IS LABELLED. */
k = i_indx(line, ")", (ftnlen)80, (ftnlen)1);
s_copy(atomtx_1.txtatm + (*natoms - 1 << 3), line + (i__ - 1), (
ftnlen)8, k - (i__ - 1));
/* Computing MAX */
i__1 = maxtxt, i__2 = k - i__ + 1;
maxtxt = max(i__1,i__2);
i__1 = k;
/* Writing concatenation */
i__3[0] = i__ - 1, a__1[0] = line;
i__3[1] = 80 - i__1, a__1[1] = line + i__1;
s_cat(string, a__1, i__3, &c__2, (ftnlen)80);
s_copy(line, string, (ftnlen)80, (ftnlen)80);
} else {
s_copy(atomtx_1.txtatm + (*natoms - 1 << 3), " ", (ftnlen)8, (
ftnlen)1);
}
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
iline = *(unsigned char *)&line[i__ - 1];
if (iline >= 'a' && iline <= 'z') {
*(unsigned char *)&line[i__ - 1] = (char) (iline + 'A' - 'a');
}
/* L10: */
}
/* *********************************************************************** */
nvalue = 0;
leadsp = TRUE_;
for (i__ = 1; i__ <= 80; ++i__) {
if (leadsp && *(unsigned char *)&line[i__ - 1] != ' ') {
++nvalue;
istart[nvalue - 1] = i__;
}
leadsp = *(unsigned char *)&line[i__ - 1] == ' ';
/* L20: */
}
for (j = 1; j <= 107; ++j) {
/* L30: */
i__1 = istart[0] - 1;
/* Writing concatenation */
i__3[0] = 1, a__1[0] = " ";
i__3[1] = istart[0] + 2 - i__1, a__1[1] = line + i__1;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)81);
/* Writing concatenation */
i__4[0] = 2, a__2[0] = elemnt + (j - 1 << 1);
i__4[1] = 1, a__2[1] = " ";
s_cat(ch__2, a__2, i__4, &c__2, (ftnlen)3);
if (i_indx(ch__1, ch__2, istart[0] + 2 - i__1 + 1, (ftnlen)3) !=
0) {
goto L40;
}
}
i__1 = istart[0] - 1;
/* Writing concatenation */
i__3[0] = 1, a__1[0] = " ";
i__3[1] = istart[0] + 2 - i__1, a__1[1] = line + i__1;
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)81);
if (i_indx(ch__1, " X", istart[0] + 2 - i__1 + 1, (ftnlen)2) != 0) {
j = 99;
goto L40;
}
s_wsfe(&io___15);
do_fio(&c__1, " ELEMENT NOT RECOGNIZED: ", (ftnlen)25);
i__1 = istart[0] - 1;
do_fio(&c__1, line + i__1, istart[0] + 2 - i__1);
e_wsfe();
++nerr;
L40:
labels[*natoms] = j;
if (j != 99) {
++numat;
/* Computing MAX */
i__1 = istart[1] - 1;
atmass_1.atmass[numat - 1] = reada_(line, istart, (max(i__1,1)));
if (atmass_1.atmass[numat - 1] > 1e-15) {
s_wsfe(&io___16);
do_fio(&c__1, (char *)&(*natoms), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&atmass_1.atmass[numat - 1], (ftnlen)
sizeof(doublereal));
e_wsfe();
} else {
atmass_1.atmass[numat - 1] = ams[j];
}
/* # WRITE(6,*)NATOMS,NUMAT,ATMASS(NUMAT) */
}
s_copy(tgeo + (*natoms * 3 - 3) * 12, " ", (ftnlen)12, (ftnlen)1);
s_copy(tgeo + (*natoms * 3 - 2) * 12, " ", (ftnlen)12, (ftnlen)1);
s_copy(tgeo + (*natoms * 3 - 1) * 12, " ", (ftnlen)12, (ftnlen)1);
if (*natoms == 1) {
goto L50;
}
na[*natoms] = (integer) reada_(line, &istart[1], (ftnlen)80);
i__1 = istart[2] - 1;
getval_(line + i__1, &geo[*natoms * 3 + 1], tgeo + (*natoms * 3 - 3) *
12, 80 - i__1, (ftnlen)12);
if (*natoms == 2) {
goto L50;
}
nb[*natoms] = (integer) reada_(line, &istart[3], (ftnlen)80);
i__1 = istart[4] - 1;
getval_(line + i__1, &geo[*natoms * 3 + 2], tgeo + (*natoms * 3 - 2) *
12, 80 - i__1, (ftnlen)12);
if (*natoms == 3) {
goto L50;
}
nc[*natoms] = (integer) reada_(line, &istart[5], (ftnlen)80);
i__1 = istart[6] - 1;
getval_(line + i__1, &geo[*natoms * 3 + 3], tgeo + (*natoms * 3 - 1) *
12, 80 - i__1, (ftnlen)12);
L50:
/* L60: */
;
}
L70:
--(*natoms);
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L80: */
lgeo[j + i__ * 3 - 4] = -1;
}
}
ivar = -1;
geovar_1.nvar = 0;
geosym_1.ndep = 0;
kerr = 0;
L90:
io___21.ciunit = *iread;
i__1 = s_rsfe(&io___21);
if (i__1 != 0) {
goto L180;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L180;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L180;
}
if (s_cmp(line, " ", (ftnlen)80, (ftnlen)1) == 0) {
if (ivar == -1) {
merr = 0;
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L100: */
if (geo[j + i__ * 3] < -998.) {
++merr;
}
}
/* L110: */
}
/* IF ALL SYMBOLS ARE DEFINED, THEN DO NOT READ 'FIXED' SYMBOLS */
if (merr == 0) {
goto L180;
}
ivar = geovar_1.nvar;
goto L90;
} else {
goto L180;
}
}
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
iline = *(unsigned char *)&line[i__ - 1];
if (iline >= 'a' && iline <= 'z') {
*(unsigned char *)&line[i__ - 1] = (char) (iline + 'A' - 'a');
}
/* L120: */
}
/* *********************************************************************** */
for (i__ = 1; i__ <= 80; ++i__) {
/* L130: */
if (*(unsigned char *)&line[i__ - 1] != ' ') {
goto L140;
}
}
L140:
i__1 = i__ + 12;
for (l = i__; l <= i__1; ++l) {
/* L150: */
if (*(unsigned char *)&line[l - 1] == ' ') {
goto L160;
}
}
L160:
sum = reada_(line, &l, (ftnlen)80);
n = 0;
lerr = 0;
i__1 = *natoms;
for (j = 1; j <= i__1; ++j) {
for (k = 1; k <= 3; ++k) {
if (s_cmp(tgeo + (k + j * 3 - 4) * 12, line + (i__ - 1), (ftnlen)
12, l - (i__ - 1)) == 0 || s_cmp(tgeo + ((k + j * 3 - 4) *
12 + 1), line + (i__ - 1), (ftnlen)11, l - (i__ - 1)) ==
0 && *(unsigned char *)&tgeo[(k + j * 3 - 4) * 12] == '-')
{
if (lgeo[k + j * 3 - 4] != -1) {
lerr = 1;
}
++lgeo[k + j * 3 - 4];
++n;
geo[k + j * 3] = sum;
if (n == 1) {
++geovar_1.nvar;
geovar_1.loc[(geovar_1.nvar << 1) - 2] = j;
geovar_1.loc[(geovar_1.nvar << 1) - 1] = k;
geovar_1.xparam[geovar_1.nvar - 1] = sum;
s_copy(simbol_1.simbol + (geovar_1.nvar - 1) * 10, tgeo +
(k + j * 3 - 4) * 12, (ftnlen)10, (ftnlen)12);
if (*(unsigned char *)&simbol_1.simbol[(geovar_1.nvar - 1)
* 10] == '-') {
s_wsfe(&io___27);
do_fio(&c__1, " NEGATIVE SYMBOLICS MUST BE PRECEEDED"
" BY THE POSITIVE EQUIVALENT", (ftnlen)65);
e_wsfe();
s_wsfe(&io___28);
/* Writing concatenation */
i__3[0] = 19, a__1[0] = " FAULTY SYMBOLIC: ";
i__3[1] = 10, a__1[1] = simbol_1.simbol + (
geovar_1.nvar - 1) * 10;
s_cat(ch__3, a__1, i__3, &c__2, (ftnlen)29);
do_fio(&c__1, ch__3, (ftnlen)29);
e_wsfe();
s_stop("", (ftnlen)0);
}
}
if (n > 1) {
++geosym_1.ndep;
geosym_1.locpar[geosym_1.ndep - 1] = geovar_1.loc[(
geovar_1.nvar << 1) - 2];
geosym_1.idepfn[geosym_1.ndep - 1] = geovar_1.loc[(
geovar_1.nvar << 1) - 1];
if (*(unsigned char *)&tgeo[(k + j * 3 - 4) * 12] == '-')
{
geosym_1.idepfn[geosym_1.ndep - 1] = 14;
if (geovar_1.loc[(geovar_1.nvar << 1) - 1] != 3) {
++kerr;
s_wsfe(&io___29);
do_fio(&c__1, " ONLY DIHEDRAL SYMBOLICS CAN BE P"
"RECEEDED BY A \"-\" SIGN", (ftnlen)55);
e_wsfe();
}
}
geosym_1.locdep[geosym_1.ndep - 1] = j;
}
}
/* L170: */
}
}
kerr += lerr;
if (lerr == 1) {
s_wsfe(&io___30);
do_fio(&c__1, " THE FOLLOWING SYMBOL HAS BEEN DEFINED MORE THAN ONCE:"
, (ftnlen)54);
do_fio(&c__1, line + (i__ - 1), l - (i__ - 1));
e_wsfe();
++nerr;
}
if (n == 0) {
s_wsfe(&io___31);
do_fio(&c__1, " THE FOLLOWING SYMBOLIC WAS NOT USED:", (ftnlen)37);
do_fio(&c__1, line + (i__ - 1), l - (i__ - 1));
e_wsfe();
++nerr;
}
goto L90;
L180:
merr = 0;
i__1 = *natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L190: */
if (geo[j + i__ * 3] < -998.) {
++merr;
}
}
/* # WRITE(6,'(2X,A,3F12.6,3I4)')ELEMNT(LABELS(I)), */
/* # 1(GEO(J,I),J=1,3), NA(I), NB(I), NC(I) */
/* L200: */
}
if (merr != 0) {
s_wsfe(&io___32);
do_fio(&c__1, (char *)&merr, (ftnlen)sizeof(integer));
do_fio(&c__1, " GEOMETRY VARIABLES WERE NOT DEFINED", (ftnlen)36);
e_wsfe();
}
if (merr + kerr + nerr != 0) {
s_wsfe(&io___33);
do_fio(&c__1, " THE GEOMETRY DATA-SET CONTAINED", (ftnlen)32);
i__1 = merr + kerr + nerr;
do_fio(&c__1, (char *)&i__1, (ftnlen)sizeof(integer));
do_fio(&c__1, " ERRORS", (ftnlen)7);
e_wsfe();
s_stop("", (ftnlen)0);
}
/* SORT PARAMETERS TO BE OPTIMIZED INTO INCREASING ORDER OF ATOMS */
if (ivar != -1) {
geovar_1.nvar = ivar;
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
j = 100000;
i__2 = geovar_1.nvar;
for (l = i__; l <= i__2; ++l) {
if (j > (geovar_1.loc[(l << 1) - 2] << 2) + geovar_1.loc[(l << 1)
- 1]) {
k = l;
j = (geovar_1.loc[(l << 1) - 2] << 2) + geovar_1.loc[(l << 1)
- 1];
}
/* L210: */
}
s_copy(string, simbol_1.simbol + (i__ - 1) * 10, (ftnlen)10, (ftnlen)
10);
s_copy(simbol_1.simbol + (i__ - 1) * 10, simbol_1.simbol + (k - 1) *
10, (ftnlen)10, (ftnlen)10);
s_copy(simbol_1.simbol + (k - 1) * 10, string, (ftnlen)10, (ftnlen)80)
;
sum = geovar_1.xparam[i__ - 1];
geovar_1.xparam[i__ - 1] = geovar_1.xparam[k - 1];
geovar_1.xparam[k - 1] = sum;
for (j = 1; j <= 2; ++j) {
l = geovar_1.loc[j + (i__ << 1) - 3];
geovar_1.loc[j + (i__ << 1) - 3] = geovar_1.loc[j + (k << 1) - 3];
/* L220: */
geovar_1.loc[j + (k << 1) - 3] = l;
}
/* L230: */
}
/* # IF(NVAR.NE.0)WRITE(6,'(//,'' PARAMETERS TO BE OPTIMIZED'')') */
degree = asin(1.) / 90;
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* # WRITE(6,'(2I6,F12.6)')LOC(1,I),LOC(2,I),XPARAM(I) */
/* L240: */
if (geovar_1.loc[(i__ << 1) - 1] != 1) {
geovar_1.xparam[i__ - 1] *= degree;
}
}
/* # IF(NDEP.NE.0)WRITE(6,'(//,'' SYMMETRY FUNCTIONS '')') */
/* # DO 28 I=1,NDEP */
/* # 28 WRITE(6,'(3I6)')LOCPAR(I),IDEPFN(I),LOCDEP(I) */
*(unsigned char *)atomtx_1.ltxt = (char) maxtxt;
return 0;
} /* getgeg_ */
/* $ Procedure ZZCONVTB ( Convert kernel file from text to binary ) */
/* Subroutine */ int zzconvtb_(char *txtfil, char *arch, char *type__, char *
binfil, integer *number, ftnlen txtfil_len, ftnlen arch_len, ftnlen
type_len, ftnlen binfil_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
alist al__1;
/* Builtin functions */
integer s_cmp(char *, char *, ftnlen, ftnlen), f_clos(cllist *), f_back(
alist *), s_rsfe(cilist *), do_fio(integer *, char *, ftnlen),
e_rsfe(void), f_open(olist *), s_wsfe(cilist *), e_wsfe(void);
/* Local variables */
char line[255];
extern /* Subroutine */ int daftb_(integer *, char *, ftnlen), spcac_(
integer *, integer *, char *, char *, ftnlen, ftnlen), chkin_(
char *, ftnlen), dastb_(integer *, char *, ftnlen), errch_(char *,
char *, ftnlen, ftnlen);
extern integer ltrim_(char *, ftnlen), rtrim_(char *, ftnlen);
extern /* Subroutine */ int daft2b_(integer *, char *, integer *, ftnlen);
extern logical failed_(void);
integer handle;
extern /* Subroutine */ int dafcls_(integer *);
logical havcom;
extern /* Subroutine */ int dafopw_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), getlun_(integer *),
setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
integer scrlun;
extern logical return_(void);
logical eoc;
/* $ Abstract */
/* Convert a SPICE text file into its equivalent binary format. */
/* NOTE: This routine is currently for use ONLY with the SPACIT */
/* utility program. Use it at your own risk. */
/* $ 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 */
/* None. */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* TXTFIL I Name of text file to be converted. */
/* BINARY I Name of a binary file to be created. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Files */
/* 1) This routine uses a Fortran scratch file to temporarily */
/* store any lines of comments. */
/* $ Exceptions */
/* 1) If there is a problem opening or writing to the binary */
/* file, a routine that ZZCONVTB calls diagnoses and signals */
/* an error. */
/* 2) If there is a problem reading from the text file, the */
/* error SPICE(FILEREADFAILED) is signalled. */
/* 3) If there is a problem opening the scratch file, the error */
/* SPICE(FILEOPENERROR) is signalled. */
/* 4) If there is a problem writing to the scratch file, the */
/* error SPICE(FILEWRITEFAILED) is signalled. */
/* 5) If the binary file archictecture is not recognized, the error */
/* SPICE(UNSUPPBINARYARCH) will be signalled. */
/* 7) If the transfer file format is not recognized, the error */
/* SPICE(NOTATRANSFERFILE) will be signalled. */
/* 8) If the input file format cannot be identified, the error */
/* SPICE(UNRECOGNIZABLEFILE) will be signalled.. */
/* $ Particulars */
/* This routine is currently only for use with the SPACIT program. */
/* $ Examples */
/* $ Restrictions */
/* 1) This routine assumes that the data and comments in the */
/* text format SPK, PCK or CK file come from a binary file */
/* and were written by one of the SPICELIB binary to text */
/* conversion routines. Data and/or comments written any */
/* other way may not be in the correct format and, therefore, */
/* may not be handled properly. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* E.D. Wright (JPL) */
/* $ Version */
/* - Beta Version 1.0.0, 20-MAR-1999 (EDW) */
/* This routine is a modification of the CONVTB routine. */
/* Both have the same basic functionality, but this routine */
/* takes the unit number of the text file opened by ZZGETFAT, */
/* the architecture, and file type as input. ZZCONVTB does */
/* not open the file, ZZGETFAT performs that function. */
/* -& */
/* $ Index_Entries */
/* convert text SPICE files to binary */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Begin and end markers in the file for the comment area. */
/* Maximum length of an input text line. */
/* Maximum length of a file architecture. */
/* Maximum length of a file type. */
/* Number of reserved records to use when creating a binar DAF file. */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("ZZCONVTB", (ftnlen)8);
}
/* Process the file based on the derived architecture and type. */
if (s_cmp(arch, "XFR", arch_len, (ftnlen)3) == 0 && s_cmp(type__, "DAF",
type_len, (ftnlen)3) == 0) {
/* We got a DAF file. */
/* Convert the data portion of the text file to binary. At this */
/* point, we know that we have a current DAF text file format. */
/* We expect to have comments. */
havcom = TRUE_;
/* Convert it. */
daftb_(number, binfil, binfil_len);
if (failed_()) {
/* If there was an error then we need to close the */
/* text file, and then check out and return to the */
/* caller. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
} else if (s_cmp(arch, "XFR", arch_len, (ftnlen)3) == 0 && s_cmp(type__,
"DAS", type_len, (ftnlen)3) == 0) {
/* We got a DAS file. So we should begin converting it to binary. */
/* DAS files are easier: all we do is call one routine. */
/* We do not have comments. Actually, we might but they are */
/* included as part of the DAS file conversion process. */
havcom = FALSE_;
/* Convert it. */
dastb_(number, binfil, binfil_len);
if (failed_()) {
/* If there was an error then we need to close the */
/* text file, and then check out and return to the */
/* caller. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
} else if (s_cmp(arch, "DAS", arch_len, (ftnlen)3) == 0) {
/* This is an error case, most likely caused by reading a binary */
/* DAS file by accident. So signal an appropriate error. */
setmsg_("The file '#' appears to be a binary DAS file and not a tran"
"sfer file.", (ftnlen)69);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
sigerr_("SPICE(NOTATRANSFERFILE)", (ftnlen)23);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
} else if (s_cmp(arch, "DAS", arch_len, (ftnlen)3) == 0 && s_cmp(type__,
"PRE", type_len, (ftnlen)3) == 0) {
/* This is an error case, most likely caused by reading a binary */
/* DAS file by accident. So signal an appropriate error. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("The file '#' appears to be a pre-release binary DAS file an"
"d not a transfer file.", (ftnlen)81);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
sigerr_("SPICE(NOTATRANSFERFILE)", (ftnlen)23);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
} else if (s_cmp(arch, "DAF", arch_len, (ftnlen)3) == 0) {
/* This is an error case, most likely caused by reading a binary */
/* DAF file by accident. So signal an appropriate error. */
setmsg_("The file '#' appears to be a binary DAF file and not a tran"
"sfer file.", (ftnlen)69);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
sigerr_("SPICE(NOTATRANSFERFILE)", (ftnlen)23);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
} else if (s_cmp(arch, "DEC", arch_len, (ftnlen)3) == 0 && s_cmp(type__,
"DAF", type_len, (ftnlen)3) == 0) {
/* This is the case for the old text file format. It has no */
/* identifying marks whatsoever, so we simply have to try and */
/* convert it. */
/* We expect to have comments. */
havcom = TRUE_;
/* Back up one record so that we are positioned in the file where */
/* we were when this routine was entered. */
al__1.aerr = 0;
al__1.aunit = *number;
f_back(&al__1);
/* Convert it. */
daft2b_(number, binfil, &c__0, binfil_len);
if (failed_()) {
/* If there was an error then we need to close the text */
/* file, and then check out and return to the caller. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
} else {
/* This is the catch all error case. At this point, we didn't */
/* match any of the files whose architecture and types are */
/* recognized. So, we toss our hands in the air and signal an */
/* error. */
setmsg_("The architecture and type of the file '#'could not be deter"
"mined.", (ftnlen)65);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
sigerr_("SPICE(UNRECOGNIZABLEFILE)", (ftnlen)25);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* If we have comments to process, then process them. */
if (havcom) {
/* There are three situations that we need to consider here: */
/* 1) We have a SPICE text file with comments. This implies */
/* that we have a bunch of comments to be put into the */
/* comment area that are surrounded by the begin comments */
/* marker, BCMARK, and the end comemnts marker, ECMARK. */
/* 2) We are at the end of the file. This means that we have */
/* an old SPICE kernel file, from the good old days before */
/* the comment area was implemented, or we ahve a plain old */
/* ordinary DAF file. */
/* 3) We are not at the end of the file, but there are no */
/* comments. This means a text DAF file may be embedded */
/* in a larger text file or something. PDS does things like */
/* this: SFDUs and such. */
/* So, we need to look out for and deal with each of these */
/* possibilities. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *number;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, (ftnlen)255);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
if (iostat > 0) {
/* If there was an error then we need to close the text */
/* file, and then check out and return to the caller. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Error reading the text file: #. IOSTAT = #.", (ftnlen)43)
;
errch_("#", txtfil, (ftnlen)1, txtfil_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* If we encountered the end of the file, just check out and */
/* return. This is not an error. */
if (iostat < 0) {
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* We got a line, so left justify it and see if it matches the */
/* begin comments marker. If not, then use the Fortran BACKSPACE */
/* command to reposition the file pointer to be ready to read the */
/* line we just read. */
i__1 = ltrim_(line, (ftnlen)255) - 1;
if (s_cmp(line + i__1, "~NAIF/SPC BEGIN COMMENTS~", 255 - i__1, (
ftnlen)25) != 0) {
al__1.aerr = 0;
al__1.aunit = *number;
f_back(&al__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* We're not at the end of the file, and the line we read */
/* is BCMARK, so we write the comments to a scratch file. */
/* We do this because we have to use SPCAC to add the comments */
/* to the comment area of the binary file, and SPCAC rewinds */
/* the file. It's okay for SPCAC to rewind a scratch file, since */
/* it will probably not be very big, but it's not okay to rewind */
/* the file connected to NUMBER -- we don't know the initial */
/* location of the file pointer or how big the file is. */
getlun_(&scrlun);
o__1.oerr = 1;
o__1.ounit = scrlun;
o__1.ofnm = 0;
o__1.orl = 0;
o__1.osta = "SCRATCH";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
/* If there was an error then we need to close the text */
/* file, and then check out and return to the caller. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Error opening temporary file. IOSTAT = #.", (ftnlen)41);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEOPENERROR)", (ftnlen)20);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* Continue reading lines from the text file and storing them */
/* in the scratch file until we get to the end marker. We do not */
/* write the begin and end markers to the scratch file. We do not */
/* need them. */
eoc = FALSE_;
while(! eoc) {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *number;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, (ftnlen)255);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
if (iostat != 0) {
/* If there was an error then we need to close the */
/* scratch file, the text file, and then check out */
/* and return to the caller. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Error reading the text file: #. IOSTAT = #.", (
ftnlen)43);
errch_("#", txtfil, (ftnlen)1, txtfil_len);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* If we are not at the end of the comments, then write the */
/* line ot the scratch file. Otherwise set the end of comments */
/* flag to .TRUE.. */
i__1 = ltrim_(line, (ftnlen)255) - 1;
if (s_cmp(line + i__1, "~NAIF/SPC END COMMENTS~", 255 - i__1, (
ftnlen)23) != 0) {
ci__1.cierr = 1;
ci__1.ciunit = scrlun;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, line, rtrim_(line, (ftnlen)255));
if (iostat != 0) {
goto L100003;
}
iostat = e_wsfe();
L100003:
if (iostat != 0) {
/* If there was an error then we need to close the */
/* scratch file, the text file, and then check out */
/* and return to the caller. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
setmsg_("Error writing to temporary file. IOSTAT = #.", (
ftnlen)44);
errint_("#", &iostat, (ftnlen)1);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
} else {
eoc = TRUE_;
}
}
/* Open the new binary file and add the comments that have been */
/* stored temporarily in a scratch file. */
dafopw_(binfil, &handle, binfil_len);
if (failed_()) {
/* If there was an error then we need to close the scratch */
/* file and the text file, and then check out and return to */
/* the caller. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
spcac_(&handle, &scrlun, " ", " ", (ftnlen)1, (ftnlen)1);
if (failed_()) {
/* If there was an error then we need to close the scratch */
/* file and the text file, and then check out and return to */
/* the caller. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
dafcls_(&handle);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
}
/* We succeeded, so close the files we opened to deal with the */
/* comments. The scratch file is automatically deleted. */
cl__1.cerr = 0;
cl__1.cunit = scrlun;
cl__1.csta = 0;
f_clos(&cl__1);
dafcls_(&handle);
}
/* Close the transfer file. We know it is open, because we got here. */
cl__1.cerr = 0;
cl__1.cunit = *number;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("ZZCONVTB", (ftnlen)8);
return 0;
} /* zzconvtb_ */
/* ********** */
/* Main program */ int MAIN__(void)
{
/* Initialized data */
static integer nread = 5;
static integer nwrite = 6;
static doublereal one = 1.;
static doublereal ten = 10.;
/* Format strings */
static char fmt_50[] = "(3i5)";
static char fmt_60[] = "(////5x,\002 PROBLEM\002,i5,5x,\002 DIMENSION"
"\002,i5,5x//)";
static char fmt_70[] = "(5x,\002 INITIAL L2 NORM OF THE RESIDUALS\002,d1"
"5.7//5x,\002 FINAL L2 NORM OF THE RESIDUALS \002,d15.7//5x,\002"
" NUMBER OF FUNCTION EVALUATIONS \002,i10//5x,\002 EXIT PARAMETER"
"\002,18x,i10//5x,\002 FINAL APPROXIMATE SOLUTION\002//(5x,5d15.7"
"))";
static char fmt_80[] = "(\0021SUMMARY OF \002,i3,\002 CALLS TO HYBRD1"
"\002/)";
static char fmt_90[] = "(\002 NPROB N NFEV INFO FINAL L2 NORM\002"
"/)";
static char fmt_100[] = "(i4,i6,i7,i6,1x,d15.7)";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
double sqrt(doublereal);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_wsfe(cilist *), e_wsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
/* Local variables */
static integer i__, k, n;
static doublereal x[40];
static integer ic, na[60], nf[60];
static doublereal wa[2660];
static integer np[60], nx[60];
extern /* Subroutine */ int fcn_();
static doublereal fnm[60];
static integer lwa;
static doublereal tol, fvec[40];
static integer info;
extern doublereal enorm_(integer *, doublereal *);
extern /* Subroutine */ int hybrd1_(U_fp, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
static doublereal fnorm1, fnorm2;
extern /* Subroutine */ int vecfcn_(integer *, doublereal *, doublereal *,
integer *);
static doublereal factor;
extern doublereal dpmpar_(integer *);
static integer ntries;
extern /* Subroutine */ int initpt_(integer *, doublereal *, integer *,
doublereal *);
/* Fortran I/O blocks */
static cilist io___8 = { 0, 0, 0, fmt_50, 0 };
static cilist io___16 = { 0, 0, 0, fmt_60, 0 };
static cilist io___25 = { 0, 0, 0, fmt_70, 0 };
static cilist io___27 = { 0, 0, 0, fmt_80, 0 };
static cilist io___28 = { 0, 0, 0, fmt_90, 0 };
static cilist io___29 = { 0, 0, 0, fmt_100, 0 };
/* LOGICAL INPUT UNIT IS ASSUMED TO BE NUMBER 5. */
/* LOGICAL OUTPUT UNIT IS ASSUMED TO BE NUMBER 6. */
tol = sqrt(dpmpar_(&c__1));
lwa = 2660;
ic = 0;
L10:
io___8.ciunit = nread;
s_rsfe(&io___8);
do_fio(&c__1, (char *)&refnum_1.nprob, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ntries, (ftnlen)sizeof(integer));
e_rsfe();
if (refnum_1.nprob <= 0) {
goto L30;
}
factor = one;
i__1 = ntries;
for (k = 1; k <= i__1; ++k) {
++ic;
initpt_(&n, x, &refnum_1.nprob, &factor);
vecfcn_(&n, x, fvec, &refnum_1.nprob);
fnorm1 = enorm_(&n, fvec);
io___16.ciunit = nwrite;
s_wsfe(&io___16);
do_fio(&c__1, (char *)&refnum_1.nprob, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
e_wsfe();
refnum_1.nfev = 0;
hybrd1_((U_fp)fcn_, &n, x, fvec, &tol, &info, wa, &lwa);
fnorm2 = enorm_(&n, fvec);
np[ic - 1] = refnum_1.nprob;
na[ic - 1] = n;
nf[ic - 1] = refnum_1.nfev;
nx[ic - 1] = info;
fnm[ic - 1] = fnorm2;
io___25.ciunit = nwrite;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&fnorm1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&fnorm2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&refnum_1.nfev, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&info, (ftnlen)sizeof(integer));
i__2 = n;
for (i__ = 1; i__ <= i__2; ++i__) {
do_fio(&c__1, (char *)&x[i__ - 1], (ftnlen)sizeof(doublereal));
}
e_wsfe();
factor = ten * factor;
/* L20: */
}
goto L10;
L30:
io___27.ciunit = nwrite;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&ic, (ftnlen)sizeof(integer));
e_wsfe();
io___28.ciunit = nwrite;
s_wsfe(&io___28);
e_wsfe();
i__1 = ic;
for (i__ = 1; i__ <= i__1; ++i__) {
io___29.ciunit = nwrite;
s_wsfe(&io___29);
do_fio(&c__1, (char *)&np[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&na[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nf[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&nx[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&fnm[i__ - 1], (ftnlen)sizeof(doublereal));
e_wsfe();
/* L40: */
}
s_stop("", (ftnlen)0);
/* LAST CARD OF DRIVER. */
return 0;
} /* MAIN__ */
/* 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__ */
/* Main program */ MAIN__(void)
{
/* Format strings */
static char fmt_9983[] = "(\002 LAPACK VERSION 3.0, released June 30, 19"
"99 \002,/)";
static char fmt_9992[] = "(\002 The following parameter values will be u"
"sed:\002)";
static char fmt_9999[] = "(\002 Too many values of \002,a,\002 using "
"\002,a,\002 = \002,i2)";
static char fmt_9991[] = "(4x,a7,1x,10i6,/12x,10i6)";
static char fmt_9997[] = "(\002 *** \002,a1,\002 = \002,i7,\002 is too b"
"ig: \002,\002maximum allowed is\002,i7)";
static char fmt_9998[] = "(\002 *** LDA = \002,i7,\002 is too small, mus"
"t have \002,\002LDA > 0.\002)";
static char fmt_9995[] = "(\002 *** LDA*N is too big for the dense routi"
"nes \002,\002(LDA =\002,i6,\002, N =\002,i6,\002)\002,/\002 --> "
"Increase LA to at least \002,i8)";
static char fmt_9994[] = "(\002 *** (LDA+K)*M is too big for the band ro"
"utines \002,\002(LDA=\002,i6,\002, M=\002,i6,\002, K=\002,i6,"
"\002)\002,/\002 --> Increase LA to at least \002,i8)";
static char fmt_9996[] = "(\002 *** N*NB is too big for N =\002,i6,\002,"
" NB =\002,i6,/\002 --> Increase LA to at least \002,i8)";
static char fmt_9984[] = "(/\002 Tests not done due to input errors\002)";
static char fmt_9993[] = "(\002 The minimum time a subroutine will be ti"
"med = \002,f6.3,\002 seconds\002)";
static char fmt_9990[] = "(/\002 ------------------------------\002,/"
"\002 >>>>> Sample BLAS <<<<<\002,/\002 ------------------"
"------------\002)";
static char fmt_9989[] = "(1x,a6,\002 not timed due to input errors\002,"
"/)";
static char fmt_9988[] = "(/\002 ------------------------------\002,/"
"\002 >>>>> Timing data <<<<<\002,/\002 ------------------"
"------------\002)";
static char fmt_9987[] = "(1x,a6,\002: Unrecognized path or subroutine "
"name\002,/)";
static char fmt_9986[] = "(\002 End of tests\002)";
static char fmt_9985[] = "(\002 Total time used = \002,f12.2,\002 seco"
"nds\002)";
/* System generated locals */
integer i__1, i__2;
real r__1;
/* Builtin functions */
integer s_wsfe(cilist *), e_wsfe(void), s_rsfe(cilist *), do_fio(integer *
, char *, ftnlen), e_rsfe(void), s_rsle(cilist *), do_lio(integer
*, integer *, char *, ftnlen), e_rsle(void), s_wsle(cilist *),
e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer need, nlda;
static logical blas;
static char line[80];
static integer kval[6], mval[6], maxk, nval[6], maxm, maxn;
static real work[280576] /* was [512][548] */, a[817152] /* was [
272384][3] */, b[817152] /* was [272384][3] */, d__[2048]
/* was [1024][2] */;
static integer i__, l;
static real s[1024];
static logical ldaok;
extern logical lsame_(char *, char *);
static integer nbval[6], maxnb, mkmax;
static char c1[1], c2[2], c3[3];
static integer nxval[6], i2, j2, iwork[10000];
static real s1, s2;
extern /* Subroutine */ int stimb2_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, real *, real *,
integer *, integer *, integer *, ftnlen), stimb3_(char *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, real *, real *, real *, real *, real *, integer *,
integer *, integer *, ftnlen), stimq3_(char *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, real *, real *, real *, real *, real *, integer *, real *,
integer *, integer *, integer *, ftnlen);
static integer nk, nm, nn, ldaval[4];
static logical ldamok, ldanok;
static integer maxlda;
extern doublereal second_(void);
extern logical lsamen_(integer *, char *, char *);
static real flptbl[1088640], opctbl[1088640];
extern /* Subroutine */ int stimgb_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, real *, real *, real *, integer *, real *, integer *
, integer *, integer *, integer *, ftnlen), stimge_(char *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, real *, real *, real *, real *, integer *,
real *, integer *, integer *, integer *, integer *, ftnlen);
static real timtbl[1088640], timmin;
extern /* Subroutine */ int stimpb_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, real *, real *, real *, integer *, real *, integer *
, integer *, integer *, integer *, ftnlen);
static logical nxnbok;
extern /* Subroutine */ int stimbr_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, real *, real *, real *, real *, real *, real *,
real *, integer *, integer *, integer *, integer *, ftnlen),
stimtb_(char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, real *, real *, real *
, real *, integer *, integer *, integer *, integer *, ftnlen),
stimtd_(char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, real *,
real *, real *, real *, real *, real *, real *, integer *,
integer *, integer *, integer *, ftnlen), stimhr_(char *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, real *, real *,
real *, integer *, integer *, integer *, integer *, ftnlen),
stimgt_(char *, integer *, integer *, integer *, integer *,
integer *, integer *, real *, real *, real *, integer *, real *,
integer *, integer *, integer *, integer *, ftnlen), stimmm_(char
*, char *, integer *, integer *, integer *, integer *, real *,
real *, real *, real *, real *, integer *, integer *, integer *,
ftnlen, ftnlen), stimlq_(char *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, real *, real *, real *, real *, real *, real *,
integer *, integer *, integer *, integer *, ftnlen), stimql_(char
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, real *, real *,
real *, real *, real *, real *, integer *, integer *, integer *,
integer *, ftnlen), stimls_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, real *, real *,
real *, real *, real *, real *, real *, real *, integer *,
integer *, ftnlen);
static real reslts[6912] /* was [6][6][8][24] */;
extern /* Subroutine */ int stimpo_(char *, integer *, integer *, integer
*, integer *, integer *, integer *, integer *, integer *, real *,
real *, real *, integer *, real *, integer *, integer *, integer *
, integer *, ftnlen), stimpp_(char *, integer *, integer *,
integer *, integer *, integer *, real *, real *, real *, integer *
, real *, integer *, integer *, integer *, integer *, ftnlen),
stimmv_(char *, integer *, integer *, integer *, integer *,
integer *, integer *, real *, real *, integer *, real *, real *,
real *, integer *, integer *, integer *, ftnlen), stimpt_(char *,
integer *, integer *, integer *, integer *, integer *, integer *,
real *, real *, real *, real *, integer *, integer *, integer *,
integer *, ftnlen), stimqp_(char *, integer *, integer *, integer
*, integer *, integer *, real *, real *, real *, real *, real *,
integer *, real *, integer *, integer *, integer *, ftnlen),
stimqr_(char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
real *, real *, real *, real *, real *, real *, integer *,
integer *, integer *, integer *, ftnlen), stimrq_(char *, integer
*, integer *, integer *, integer *, integer *, integer *, integer
*, integer *, integer *, integer *, real *, real *, real *, real *
, real *, real *, integer *, integer *, integer *, integer *,
ftnlen), stimsp_(char *, integer *, integer *, integer *, integer
*, integer *, real *, real *, real *, real *, integer *, real *,
integer *, integer *, integer *, integer *, ftnlen), stimtp_(char
*, integer *, integer *, integer *, integer *, integer *, real *,
real *, real *, real *, integer *, integer *, integer *, integer *
, ftnlen), stimtr_(char *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, real *,
real *, real *, real *, integer *, integer *, integer *, integer *
, ftnlen), stimsy_(char *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, real *,
real *, real *, real *, integer *, real *, integer *, integer *,
integer *, integer *, ftnlen);
static integer nnb;
static logical mok, nok;
static integer ldr1, ldr2, ldr3;
/* Fortran I/O blocks */
static cilist io___5 = { 0, 6, 0, fmt_9983, 0 };
static cilist io___6 = { 0, 5, 0, "( A80 )", 0 };
static cilist io___10 = { 0, 6, 0, "( 1X, A, / )", 0 };
static cilist io___11 = { 0, 6, 0, fmt_9992, 0 };
static cilist io___12 = { 0, 5, 0, 0, 0 };
static cilist io___14 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___15 = { 0, 5, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___21 = { 0, 6, 0, fmt_9997, 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 5, 0, 0, 0 };
static cilist io___25 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___26 = { 0, 5, 0, 0, 0 };
static cilist io___28 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___31 = { 0, 6, 0, fmt_9997, 0 };
static cilist io___32 = { 0, 6, 0, 0, 0 };
static cilist io___33 = { 0, 5, 0, 0, 0 };
static cilist io___35 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 5, 0, 0, 0 };
static cilist io___38 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___41 = { 0, 5, 0, 0, 0 };
static cilist io___43 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___44 = { 0, 5, 0, 0, 0 };
static cilist io___47 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___49 = { 0, 5, 0, 0, 0 };
static cilist io___50 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___51 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___52 = { 0, 5, 0, 0, 0 };
static cilist io___54 = { 0, 6, 0, fmt_9999, 0 };
static cilist io___55 = { 0, 5, 0, 0, 0 };
static cilist io___57 = { 0, 6, 0, fmt_9991, 0 };
static cilist io___60 = { 0, 6, 0, fmt_9998, 0 };
static cilist io___61 = { 0, 6, 0, 0, 0 };
static cilist io___64 = { 0, 6, 0, fmt_9995, 0 };
static cilist io___66 = { 0, 6, 0, fmt_9994, 0 };
static cilist io___68 = { 0, 6, 0, fmt_9996, 0 };
static cilist io___69 = { 0, 6, 0, fmt_9984, 0 };
static cilist io___70 = { 0, 6, 0, 0, 0 };
static cilist io___71 = { 0, 6, 0, 0, 0 };
static cilist io___72 = { 0, 5, 0, 0, 0 };
static cilist io___74 = { 0, 6, 0, fmt_9993, 0 };
static cilist io___75 = { 0, 6, 0, 0, 0 };
static cilist io___76 = { 0, 5, 1, "(A)", 0 };
static cilist io___77 = { 0, 5, 1, "(A)", 0 };
static cilist io___78 = { 0, 6, 0, fmt_9990, 0 };
static cilist io___83 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___84 = { 0, 5, 1, "(A)", 0 };
static cilist io___85 = { 0, 6, 0, fmt_9988, 0 };
static cilist io___89 = { 0, 6, 0, fmt_9987, 0 };
static cilist io___92 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___93 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___94 = { 0, 6, 0, fmt_9989, 0 };
static cilist io___101 = { 0, 6, 0, fmt_9987, 0 };
static cilist io___102 = { 0, 5, 1, "(A)", 0 };
static cilist io___104 = { 0, 6, 0, fmt_9986, 0 };
static cilist io___105 = { 0, 6, 0, fmt_9985, 0 };
#define a_ref(a_1,a_2) a[(a_2)*272384 + a_1 - 272385]
#define b_ref(a_1,a_2) b[(a_2)*272384 + a_1 - 272385]
#define d___ref(a_1,a_2) d__[(a_2)*1024 + a_1 - 1025]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
STIMAA is the timing program for the REAL LAPACK
routines. This program collects performance data for the factor,
solve, and inverse routines used in solving systems of linear
equations, and also for the orthogonal factorization and reduction
routines used in solving least squares problems and matrix eigenvalue
problems.
The subprograms call a REAL function SECOND with no
arguments which is assumed to return the central-processor time in
seconds from some fixed starting time.
The program is driven by a short data file, which specifies values
for the matrix dimensions M, N and K, for the blocking parameters
NB and NX, and for the leading array dimension LDA. A minimum time
for each subroutine is included for timing small problems or for
obtaining results on a machine with an inaccurate SECOND function.
The matrix dimensions M, N, and K correspond to the three dimensions
m, n, and k in the Level 3 BLAS. When timing the LAPACK routines for
square matrices, M and N correspond to the matrix dimensions m and n,
and K is the number of right-hand sides (nrhs) for the solves. When
timing the LAPACK routines for band matrices, M is the matrix order
m, N is the half-bandwidth (kl, ku, or kd in the LAPACK notation),
and K is again the number of right-hand sides.
The first 13 records of the data file are read using list-directed
input. The first line of input is printed as the first line of
output and can be used to identify different sets of results. To
assist with debugging an input file, the values are printed out as
they are read in.
The following records are read using the format (A). For these
records, the first 6 characters are reserved for the path or
subroutine name. If a path name is used, the characters after the
path name indicate the routines in the path to be timed, where
'T' or 't' means 'Time this routine'. If the line is blank after the
path name, all routines in the path are timed. If fewer characters
appear than routines in a path, the remaining characters are assumed
to be 'F'. For example, the following 3 lines are equivalent ways of
requesting timing of SGETRF:
SGE T F F
SGE T
SGETRF
An annotated example of a data file can be obtained by deleting the
first 3 characters from the following 30 lines:
LAPACK timing, REAL square matrices
5 Number of values of M
100 200 300 400 500 Values of M (row dimension)
5 Number of values of N
100 200 300 400 500 Values of N (column dimension)
2 Number of values of K
100 400 Values of K
5 Number of values of NB
1 16 32 48 64 Values of NB (blocksize)
0 48 128 128 128 Values of NX (crossover point)
2 Number of values of LDA
512 513 Values of LDA (leading dimension)
0.0 Minimum time in seconds
SGE T T T
SPO T T T
SPP T T T
SSY T T T
SSP T T T
STR T T
STP T T
SQR T T F
SLQ T T F
SQL T T F
SRQ T T F
SQP T
SHR T T F F
STD T T F F
SBR T F F
SLS T T T T T T
The routines are timed for all combinations of applicable values of
M, N, K, NB, NX, and LDA, and for all combinations of options such as
UPLO and TRANS. For Level 2 BLAS timings, values of NB are used for
INCX. Certain subroutines, such as the QR factorization, treat the
values of M and N as ordered pairs and operate on M x N matrices.
Internal Parameters
===================
NMAX INTEGER
The maximum value of M or N for square matrices.
LDAMAX INTEGER
The maximum value of LDA.
NMAXB INTEGER
The maximum value of N for band matrices.
MAXVAL INTEGER
The maximum number of values that can be read in for M, N,
K, NB, or NX.
MXNLDA INTEGER
The maximum number of values that can be read in for LDA.
NIN INTEGER
The unit number for input. Currently set to 5 (std input).
NOUT INTEGER
The unit number for output. Currently set to 6 (std output).
===================================================================== */
s1 = second_();
ldr1 = 6;
ldr2 = 6;
ldr3 = 8;
s_wsfe(&io___5);
e_wsfe();
/* Read the first line. The first four characters must be 'BLAS'
for the BLAS data file format to be used. Otherwise, the LAPACK
data file format is assumed. */
s_rsfe(&io___6);
do_fio(&c__1, line, (ftnlen)80);
e_rsfe();
blas = lsamen_(&c__4, line, "BLAS");
/* Find the last non-blank and print the first line of input as the
first line of output. */
for (l = 80; l >= 1; --l) {
if (*(unsigned char *)&line[l - 1] != ' ') {
goto L20;
}
/* L10: */
}
l = 1;
L20:
s_wsfe(&io___10);
do_fio(&c__1, line, l);
e_wsfe();
s_wsfe(&io___11);
e_wsfe();
/* Read in NM and the values for M. */
s_rsle(&io___12);
do_lio(&c__3, &c__1, (char *)&nm, (ftnlen)sizeof(integer));
e_rsle();
if (nm > 6) {
s_wsfe(&io___14);
do_fio(&c__1, "M", (ftnlen)1);
do_fio(&c__1, "NM", (ftnlen)2);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
nm = 6;
}
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();
s_wsfe(&io___18);
do_fio(&c__1, "M: ", (ftnlen)7);
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Check that M <= NMAXB for all values of M. */
mok = TRUE_;
maxm = 0;
i__1 = nm;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
i__2 = mval[i__ - 1];
maxm = max(i__2,maxm);
if (mval[i__ - 1] > 5000) {
s_wsfe(&io___21);
do_fio(&c__1, "M", (ftnlen)1);
do_fio(&c__1, (char *)&mval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__5000, (ftnlen)sizeof(integer));
e_wsfe();
mok = FALSE_;
}
/* L30: */
}
if (! mok) {
s_wsle(&io___22);
e_wsle();
}
/* Read in NN and the values for N. */
s_rsle(&io___23);
do_lio(&c__3, &c__1, (char *)&nn, (ftnlen)sizeof(integer));
e_rsle();
if (nn > 6) {
s_wsfe(&io___25);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, "NN", (ftnlen)2);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
nn = 6;
}
s_rsle(&io___26);
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();
s_wsfe(&io___28);
do_fio(&c__1, "N: ", (ftnlen)7);
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Check that N <= NMAXB for all values of N. */
nok = TRUE_;
maxn = 0;
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
i__2 = nval[i__ - 1];
maxn = max(i__2,maxn);
if (nval[i__ - 1] > 5000) {
s_wsfe(&io___31);
do_fio(&c__1, "N", (ftnlen)1);
do_fio(&c__1, (char *)&nval[i__ - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__5000, (ftnlen)sizeof(integer));
e_wsfe();
nok = FALSE_;
}
/* L40: */
}
if (! nok) {
s_wsle(&io___32);
e_wsle();
}
/* Read in NK and the values for K. */
s_rsle(&io___33);
do_lio(&c__3, &c__1, (char *)&nk, (ftnlen)sizeof(integer));
e_rsle();
if (nk > 6) {
s_wsfe(&io___35);
do_fio(&c__1, "K", (ftnlen)1);
do_fio(&c__1, "NK", (ftnlen)2);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
nk = 6;
}
s_rsle(&io___36);
i__1 = nk;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer));
}
e_rsle();
s_wsfe(&io___38);
do_fio(&c__1, "K: ", (ftnlen)7);
i__1 = nk;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&kval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Find the maximum value of K (= NRHS). */
maxk = 0;
i__1 = nk;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
i__2 = kval[i__ - 1];
maxk = max(i__2,maxk);
/* L50: */
}
mkmax = maxm * max(2,maxk);
/* Read in NNB and the values for NB. For the BLAS input files,
NBVAL is used to store values for INCX and INCY. */
s_rsle(&io___41);
do_lio(&c__3, &c__1, (char *)&nnb, (ftnlen)sizeof(integer));
e_rsle();
if (nnb > 6) {
s_wsfe(&io___43);
do_fio(&c__1, "NB", (ftnlen)2);
do_fio(&c__1, "NNB", (ftnlen)3);
do_fio(&c__1, (char *)&c__6, (ftnlen)sizeof(integer));
e_wsfe();
nnb = 6;
}
s_rsle(&io___44);
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();
/* Find the maximum value of NB. */
maxnb = 0;
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
i__2 = nbval[i__ - 1];
maxnb = max(i__2,maxnb);
/* L60: */
}
if (blas) {
s_wsfe(&io___47);
do_fio(&c__1, "INCX: ", (ftnlen)7);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
nxval[i__ - 1] = 0;
/* L70: */
}
} else {
/* LAPACK data files: Read in the values for NX. */
s_rsle(&io___49);
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();
s_wsfe(&io___50);
do_fio(&c__1, "NB: ", (ftnlen)7);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nbval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
s_wsfe(&io___51);
do_fio(&c__1, "NX: ", (ftnlen)7);
i__1 = nnb;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&nxval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
}
/* Read in NLDA and the values for LDA. */
s_rsle(&io___52);
do_lio(&c__3, &c__1, (char *)&nlda, (ftnlen)sizeof(integer));
e_rsle();
if (nlda > 4) {
s_wsfe(&io___54);
do_fio(&c__1, "LDA", (ftnlen)3);
do_fio(&c__1, "NLDA", (ftnlen)4);
do_fio(&c__1, (char *)&c__4, (ftnlen)sizeof(integer));
e_wsfe();
nlda = 4;
}
s_rsle(&io___55);
i__1 = nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
do_lio(&c__3, &c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer)
);
}
e_rsle();
s_wsfe(&io___57);
do_fio(&c__1, "LDA: ", (ftnlen)7);
i__1 = nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
do_fio(&c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer));
}
e_wsfe();
/* Check that LDA >= 1 for all values of LDA. */
ldaok = TRUE_;
maxlda = 0;
i__1 = nlda;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
i__2 = ldaval[i__ - 1];
maxlda = max(i__2,maxlda);
if (ldaval[i__ - 1] <= 0) {
s_wsfe(&io___60);
do_fio(&c__1, (char *)&ldaval[i__ - 1], (ftnlen)sizeof(integer));
e_wsfe();
ldaok = FALSE_;
}
/* L80: */
}
if (! ldaok) {
s_wsle(&io___61);
e_wsle();
}
/* Check that MAXLDA*MAXN <= LA (for the dense routines). */
ldanok = TRUE_;
need = maxlda * maxn;
if (need > 272384) {
s_wsfe(&io___64);
do_fio(&c__1, (char *)&maxlda, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&maxn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&need, (ftnlen)sizeof(integer));
e_wsfe();
ldanok = FALSE_;
}
/* Check that MAXLDA*MAXM + MAXM*MAXK <= 3*LA (for band routines). */
ldamok = TRUE_;
need = maxlda * maxm + maxm * maxk;
if (need > 817152) {
need = (need + 2) / 3;
s_wsfe(&io___66);
do_fio(&c__1, (char *)&maxlda, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&maxm, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&maxk, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&need, (ftnlen)sizeof(integer));
e_wsfe();
ldamok = FALSE_;
}
/* Check that MAXN*MAXNB (or MAXN*INCX) <= LA. */
nxnbok = TRUE_;
need = maxn * maxnb;
if (need > 272384) {
s_wsfe(&io___68);
do_fio(&c__1, (char *)&maxn, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&maxnb, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&need, (ftnlen)sizeof(integer));
e_wsfe();
nxnbok = FALSE_;
}
if (! (mok && nok && ldaok && ldanok && nxnbok)) {
s_wsfe(&io___69);
e_wsfe();
goto L110;
}
if (! ldamok) {
s_wsle(&io___70);
e_wsle();
}
/* Read the minimum time to time a subroutine. */
s_wsle(&io___71);
e_wsle();
s_rsle(&io___72);
do_lio(&c__4, &c__1, (char *)&timmin, (ftnlen)sizeof(real));
e_rsle();
s_wsfe(&io___74);
do_fio(&c__1, (char *)&timmin, (ftnlen)sizeof(real));
e_wsfe();
s_wsle(&io___75);
e_wsle();
/* Read the first input line. */
i__1 = s_rsfe(&io___76);
if (i__1 != 0) {
goto L100;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L100;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L100;
}
/* If the first record is the special signal 'NONE', then get the
next line but don't time SGEMV and SGEMM. */
if (lsamen_(&c__4, line, "NONE")) {
i__1 = s_rsfe(&io___77);
if (i__1 != 0) {
goto L100;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L100;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L100;
}
} else {
s_wsfe(&io___78);
e_wsfe();
/* If the first record is the special signal 'BAND', then time
the band routine SGBMV and SGEMM with N = K. */
if (lsamen_(&c__4, line, "BAND")) {
if (ldamok) {
if (mkmax > 272384) {
i2 = 544768 - mkmax + 1;
j2 = 2;
} else {
i2 = 272384 - mkmax + 1;
j2 = 3;
}
i__1 = mkmax / 2;
stimmv_("SGBMV ", &nm, mval, &nn, nval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &i__1, &a_ref(i2, j2), &a_ref(
272384 - mkmax / 2 + 1, 3), reslts, &ldr1, &ldr2, &
c__6, (ftnlen)6);
} else {
s_wsfe(&io___83);
do_fio(&c__1, "SGBMV ", (ftnlen)6);
e_wsfe();
}
stimmm_("SGEMM ", "K", &nn, nval, &nlda, ldaval, &timmin, &a_ref(
1, 1), &a_ref(1, 2), &a_ref(1, 3), reslts, &ldr1, &ldr2, &
c__6, (ftnlen)6, (ftnlen)1);
i__1 = s_rsfe(&io___84);
if (i__1 != 0) {
goto L100;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L100;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L100;
}
} else {
/* Otherwise time SGEMV and SGEMM. */
stimmv_("SGEMV ", &nn, nval, &nnb, nbval, &nlda, ldaval, &timmin,
&a_ref(1, 1), &c_b172, &a_ref(1, 2), &a_ref(1, 3), reslts,
&ldr1, &ldr2, &c__6, (ftnlen)6);
stimmm_("SGEMM ", "N", &nn, nval, &nlda, ldaval, &timmin, &a_ref(
1, 1), &a_ref(1, 2), &a_ref(1, 3), reslts, &ldr1, &ldr2, &
c__6, (ftnlen)6, (ftnlen)1);
}
}
/* Call the appropriate timing routine for each input line. */
s_wsfe(&io___85);
e_wsfe();
L90:
*(unsigned char *)c1 = *(unsigned char *)line;
s_copy(c2, line + 1, (ftnlen)2, (ftnlen)2);
s_copy(c3, line + 3, (ftnlen)3, (ftnlen)3);
/* Check first character for correct precision. */
if (! lsame_(c1, "Single precision")) {
s_wsfe(&io___89);
do_fio(&c__1, line, (ftnlen)6);
e_wsfe();
} else if (lsamen_(&c__2, c2, "B2") || lsamen_(&
c__3, c3, "MV ") || lsamen_(&c__3, c3,
"SV ") || lsamen_(&c__3, c3, "R ") || lsamen_(&c__3, c3, "RC ")
|| lsamen_(&c__3, c3, "RU ") || lsamen_(&
c__3, c3, "R2 ")) {
/* Level 2 BLAS */
stimb2_(line, &nm, mval, &nn, nval, &nk, kval, &nnb, nbval, &nlda,
ldaval, &c_b172, &timmin, &a_ref(1, 1), &a_ref(1, 2), &a_ref(
1, 3), reslts, &ldr1, &ldr2, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "B3") || lsamen_(&
c__3, c3, "MM ") || lsamen_(&c__3, c3,
"SM ") || lsamen_(&c__3, c3, "RK ") || lsamen_(&c__3, c3, "R2K"))
{
/* Level 3 BLAS */
stimb3_(line, &nm, mval, &nn, nval, &nk, kval, &nlda, ldaval, &timmin,
&a_ref(1, 1), &a_ref(1, 2), &a_ref(1, 3), reslts, &ldr1, &
ldr2, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "QR") || lsamen_(&
c__2, c3, "QR") || lsamen_(&c__2, c3 + 1,
"QR")) {
/* QR routines */
stimqr_(line, &nn, mval, nval, &nk, kval, &nnb, nbval, nxval, &nlda,
ldaval, &timmin, &a_ref(1, 1), d__, &a_ref(1, 2), &a_ref(1, 3)
, reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "LQ") || lsamen_(&
c__2, c3, "LQ") || lsamen_(&c__2, c3 + 1,
"LQ")) {
/* LQ routines */
stimlq_(line, &nn, mval, nval, &nk, kval, &nnb, nbval, nxval, &nlda,
ldaval, &timmin, &a_ref(1, 1), d__, &a_ref(1, 2), &a_ref(1, 3)
, reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "QL") || lsamen_(&
c__2, c3, "QL") || lsamen_(&c__2, c3 + 1,
"QL")) {
/* QL routines */
stimql_(line, &nn, mval, nval, &nk, kval, &nnb, nbval, nxval, &nlda,
ldaval, &timmin, &a_ref(1, 1), d__, &a_ref(1, 2), &a_ref(1, 3)
, reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "RQ") || lsamen_(&
c__2, c3, "RQ") || lsamen_(&c__2, c3 + 1,
"RQ")) {
/* RQ routines */
stimrq_(line, &nn, mval, nval, &nk, kval, &nnb, nbval, nxval, &nlda,
ldaval, &timmin, &a_ref(1, 1), d__, &a_ref(1, 2), &a_ref(1, 3)
, reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "QP") || lsamen_(&
c__3, c3, "QPF")) {
/* QR with column pivoting */
stimqp_(line, &nm, mval, nval, &nlda, ldaval, &timmin, &a_ref(1, 1), &
a_ref(1, 2), &d___ref(1, 1), &a_ref(1, 3), iwork, reslts, &
ldr1, &ldr2, &c__6, (ftnlen)80);
/* Blas-3 QR with column pivoting */
stimq3_(line, &nm, mval, nval, &nnb, nbval, nxval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(1, 2), &d___ref(1, 1), &a_ref(1,
3), iwork, reslts, &ldr1, &ldr2, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "HR") || lsamen_(&
c__3, c3, "HRD") || lsamen_(&c__2, c3 + 1,
"HR")) {
/* Reduction to Hessenberg form */
stimhr_(line, &nn, nval, &nk, kval, &nnb, nbval, nxval, &nlda, ldaval,
&timmin, &a_ref(1, 1), d__, &a_ref(1, 2), &a_ref(1, 3),
reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "TD") || lsamen_(&
c__3, c3, "TRD") || lsamen_(&c__2, c3 + 1,
"TR")) {
/* Reduction to tridiagonal form */
stimtd_(line, &nn, nval, &nk, kval, &nnb, nbval, nxval, &nlda, ldaval,
&timmin, &a_ref(1, 1), &a_ref(1, 2), &d___ref(1, 1), &
d___ref(1, 2), &a_ref(1, 3), reslts, &ldr1, &ldr2, &ldr3, &
c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "BR") || lsamen_(&
c__3, c3, "BRD") || lsamen_(&c__2, c3 + 1,
"BR")) {
/* Reduction to bidiagonal form */
stimbr_(line, &nn, mval, nval, &nk, kval, &nnb, nbval, nxval, &nlda,
ldaval, &timmin, &a_ref(1, 1), &a_ref(1, 2), &d___ref(1, 1), &
d___ref(1, 2), &a_ref(1, 3), reslts, &ldr1, &ldr2, &ldr3, &
c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "GE")) {
/* Routines for general matrices */
stimge_(line, &nn, nval, &nk, kval, &nnb, nbval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(1, 2), &a_ref(1, 3), iwork,
reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "GB")) {
/* General band matrices */
if (ldamok) {
stimgb_(line, &nm, mval, &nn, nval, &nk, kval, &nnb, nbval, &nlda,
ldaval, &timmin, &a_ref(1, 1), &a_ref(272384 - mkmax + 1,
3), iwork, reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)
80);
} else {
s_wsfe(&io___92);
do_fio(&c__1, line, (ftnlen)6);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "GT")) {
/* Routines for general tridiagonal matrices */
stimgt_(line, &nn, nval, &nk, kval, &nlda, ldaval, &timmin, &a_ref(1,
1), &a_ref(1, 2), iwork, reslts, &ldr1, &ldr2, &ldr3, &c__6, (
ftnlen)80);
} else if (lsamen_(&c__2, c2, "PO")) {
/* Positive definite matrices */
stimpo_(line, &nn, nval, &nk, kval, &nnb, nbval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(1, 2), iwork, reslts, &ldr1, &
ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "PP")) {
/* Positive definite packed matrices */
stimpp_(line, &nn, nval, &nk, kval, &c_b172, &timmin, &a_ref(1, 1), &
a_ref(1, 2), iwork, reslts, &ldr1, &ldr2, &ldr3, &c__6, (
ftnlen)80);
} else if (lsamen_(&c__2, c2, "PB")) {
/* Positive definite banded matrices */
if (ldamok) {
if (mkmax > 272384) {
j2 = 2;
i2 = 544768 - mkmax + 1;
} else {
j2 = 3;
i2 = 272384 - mkmax + 1;
}
stimpb_(line, &nm, mval, &nn, nval, &nk, kval, &nnb, nbval, &nlda,
ldaval, &timmin, &a_ref(1, 1), &a_ref(i2, j2), iwork,
reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else {
s_wsfe(&io___93);
do_fio(&c__1, line, (ftnlen)6);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "PT")) {
/* Routines for positive definite tridiagonal matrices */
stimpt_(line, &nn, nval, &nk, kval, &nlda, ldaval, &timmin, &a_ref(1,
1), &a_ref(1, 2), reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)
80);
} else if (lsamen_(&c__2, c2, "SY")) {
/* Symmetric indefinite matrices */
stimsy_(line, &nn, nval, &nk, kval, &nnb, nbval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(1, 2), &a_ref(1, 3), iwork,
reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "SP")) {
/* Symmetric indefinite packed matrices */
stimsp_(line, &nn, nval, &nk, kval, &c_b172, &timmin, &a_ref(1, 1), &
a_ref(1, 2), &a_ref(1, 3), iwork, reslts, &ldr1, &ldr2, &ldr3,
&c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "TR")) {
/* Triangular matrices */
stimtr_(line, &nn, nval, &nk, kval, &nnb, nbval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(1, 2), reslts, &ldr1, &ldr2, &
ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "TP")) {
/* Triangular packed matrices */
stimtp_(line, &nn, nval, &nk, kval, &c_b172, &timmin, &a_ref(1, 1), &
a_ref(1, 2), reslts, &ldr1, &ldr2, &ldr3, &c__6, (ftnlen)80);
} else if (lsamen_(&c__2, c2, "TB")) {
/* Triangular band matrices */
if (ldamok) {
if (mkmax > 272384) {
j2 = 2;
i2 = 544768 - mkmax + 1;
} else {
j2 = 3;
i2 = 272384 - mkmax + 1;
}
stimtb_(line, &nm, mval, &nn, nval, &nk, kval, &nlda, ldaval, &
timmin, &a_ref(1, 1), &a_ref(i2, j2), reslts, &ldr1, &
ldr2, &ldr3, &c__6, (ftnlen)80);
} else {
s_wsfe(&io___94);
do_fio(&c__1, line, (ftnlen)6);
e_wsfe();
}
} else if (lsamen_(&c__2, c2, "LS")) {
/* Least squares drivers */
stimls_(line, &nm, mval, &nn, nval, &nk, kval, &nnb, nbval, nxval, &
nlda, ldaval, &timmin, &a_ref(1, 1), &a_ref(1, 2), &b_ref(1,
1), &b_ref(1, 2), s, &s[512], opctbl, timtbl, flptbl, work,
iwork, &c__6, (ftnlen)80);
} else {
s_wsfe(&io___101);
do_fio(&c__1, line, (ftnlen)6);
e_wsfe();
}
/* Read the next line of the input file. */
i__1 = s_rsfe(&io___102);
if (i__1 != 0) {
goto L100;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L100;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L100;
}
goto L90;
/* Branch to this line when the last record is read. */
L100:
s2 = second_();
s_wsfe(&io___104);
e_wsfe();
s_wsfe(&io___105);
r__1 = s2 - s1;
do_fio(&c__1, (char *)&r__1, (ftnlen)sizeof(real));
e_wsfe();
L110:
/* End of STIMAA */
return 0;
} /* MAIN__ */
/* ------------------------------------------------------------------ */
/* Main program */ int MAIN__(void)
{
/* Format strings */
static char fmt_6000[] = "(3x,1p5e13.5)";
static char fmt_6110[] = "(1x,\002!!! WARNING: NEGATIVE \002,a,\002XS WA"
"S DETECTED IN GROUP\002,i3)";
static char fmt_6120[] = "(1x,\002!!! WARNING: NEGATIVE \002,a,\002XS WA"
"S DETECTED : \002,\002FROM GROUP \002,i3,\002 TO GROUP \002,i3)";
static char fmt_6130[] = "(1x,\002!!! WARNING: NEGATIVE SCATTERIG XS ("
"=\002,1pe12.5,\002) WAS SET TO ZERO.\002,/,\002 IT WAS ADDED"
" TO TOTAL(TRANSPORT) XS OF GROUP \002,i3)";
static char fmt_6200[] = "(1x,\002IGG=\002,i3,2x,1p220e12.5:/(10x,1p220e"
"12.5:))";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
real r__1;
static real equiv_0[1000000];
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_wsfe(cilist *), e_wsfe(void), s_rsle(cilist *), e_rsle(void),
s_cmp(char *, char *, ftnlen, ftnlen), s_wsue(cilist *), do_uio(
integer *, char *, ftnlen), e_wsue(void);
/* Local variables */
static integer i__, k, l, m, ig;
static real en[108];
static integer ng;
static real wt[108];
static integer igg, idm[50], irc;
static real scm[1144900] /* was [107][107][2][50] */;
static integer nin, ldw, lgv, npl, iht, lup, lss;
static real sum, xsm[32100] /* was [107][3][2][50] */;
static integer nds1, npl1, imac;
static char etag[1];
static integer leng, nbin, isgg;
static real scat[16692] /* was [107][156] */;
static char ptag[1*6*2];
static real xkai[5350] /* was [107][50] */;
static integer itbl, idum, nmat;
static real xsec[1070] /* was [107][10] */;
static integer note, lsct, iprn, itmp, ipos, iout;
#define work (equiv_0)
static integer nout1, nout2;
static real delay[4815] /* was [15][107][3] */;
static integer msave;
extern /* Subroutine */ int pdsin_(char *, char *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer minsg, maxsg;
static char title[48];
static integer mcopt;
#define iwork ((integer *)equiv_0)
static integer mxdws, mxups;
extern /* Subroutine */ int macedt_(char *, integer *, integer *, char *,
integer *, real *, integer *, integer *, real *, real *, ftnlen,
ftnlen);
static integer idebug;
extern /* Subroutine */ int engedt_(char *, integer *, integer *, char *,
integer *, real *, real *, ftnlen, ftnlen);
static char member[8*50], dirnam[72], memnam[8];
extern /* Subroutine */ int uioset_(void);
/* Fortran I/O blocks */
static cilist io___10 = { 0, 0, 0, 0, 0 };
static cilist io___11 = { 0, 0, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 0, 0, 0, 0 };
static cilist io___16 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___18 = { 0, 0, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___20 = { 0, 0, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___24 = { 0, 0, 1, "(A72)", 0 };
static cilist io___31 = { 0, 0, 0, 0, 0 };
static cilist io___35 = { 0, 0, 0, 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, fmt_6000, 0 };
static cilist io___41 = { 0, 0, 0, 0, 0 };
static cilist io___42 = { 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, 0, 0 };
static cilist io___52 = { 0, 0, 0, 0, 0 };
static cilist io___55 = { 0, 0, 1, "(A8,I10)", 0 };
static cilist io___57 = { 0, 0, 0, 0, 0 };
static cilist io___64 = { 0, 0, 0, 0, 0 };
static cilist io___70 = { 0, 0, 0, 0, 0 };
static cilist io___71 = { 0, 0, 0, 0, 0 };
static cilist io___72 = { 0, 0, 0, 0, 0 };
static cilist io___78 = { 0, 0, 0, 0, 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, 0, 0 };
static cilist io___82 = { 0, 0, 0, 0, 0 };
static cilist io___83 = { 0, 0, 0, 0, 0 };
static cilist io___84 = { 0, 0, 0, 0, 0 };
static cilist io___85 = { 0, 0, 0, 0, 0 };
static cilist io___86 = { 0, 0, 0, 0, 0 };
static cilist io___87 = { 0, 0, 0, 0, 0 };
static cilist io___88 = { 0, 0, 0, 0, 0 };
static cilist io___89 = { 0, 0, 0, 0, 0 };
static cilist io___95 = { 0, 0, 0, 0, 0 };
static cilist io___96 = { 0, 0, 0, 0, 0 };
static cilist io___97 = { 0, 0, 0, 0, 0 };
static cilist io___98 = { 0, 0, 0, 0, 0 };
static cilist io___100 = { 0, 0, 0, 0, 0 };
static cilist io___101 = { 0, 0, 0, fmt_6000, 0 };
static cilist io___102 = { 0, 0, 0, 0, 0 };
static cilist io___104 = { 0, 0, 0, fmt_6110, 0 };
static cilist io___105 = { 0, 0, 0, fmt_6110, 0 };
static cilist io___106 = { 0, 0, 0, fmt_6110, 0 };
static cilist io___110 = { 0, 0, 0, fmt_6120, 0 };
static cilist io___111 = { 0, 0, 0, fmt_6130, 0 };
static cilist io___114 = { 0, 0, 0, fmt_6200, 0 };
static cilist io___116 = { 0, 0, 0, 0, 0 };
static cilist io___117 = { 0, 0, 0, 0, 0 };
static cilist io___118 = { 0, 0, 0, 0, 0 };
static cilist io___119 = { 0, 0, 0, 0, 0 };
static cilist io___120 = { 0, 0, 0, 0, 0 };
static cilist io___121 = { 0, 0, 0, 0, 0 };
/* ------------------------------------------------------------------ */
/* *********************************************************************** */
/* XSM(g,1,L,m) : absorption XS of m-th material (L-1 order) */
/* XSM(g,2,L,m) : production */
/* XSM(g,3,L,m) : total/transport */
/* SCM(g,g',L,m) : scattering matrix (g->g') of m-th material */
/* XKAI(g,m) : fission spectrum */
/* ----------------------------------------------------------------------- */
/* *********************************************************************** */
/* If you change I/O device number, */
/* Change subroutine (uiount) at the last. */
nin = 5;
nout1 = 6;
nout2 = 99;
nbin = 1;
iout = nout1;
iprn = 1;
note = 0;
uioset_();
/* *********************************************************************** */
/* LOGO PRINT (99) */
/* *********************************************************************** */
io___10.ciunit = nout1;
s_wsle(&io___10);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___11.ciunit = nout1;
s_wsle(&io___11);
do_lio(&c__9, &c__1, " SRAC UTILITY TO CONVERT MACROSCOPIC XS DATA", (
ftnlen)44);
e_wsle();
io___12.ciunit = nout1;
s_wsle(&io___12);
do_lio(&c__9, &c__1, " OF PDS TO ANISN TYPE BINARY LIBRARY DATA", (ftnlen)
41);
e_wsle();
io___13.ciunit = nout1;
s_wsle(&io___13);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___14.ciunit = nout2;
s_wsle(&io___14);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___15.ciunit = nout2;
s_wsle(&io___15);
do_lio(&c__9, &c__1, " SRAC UTILITY TO CONVERT MACROSCOPIC XS DATA", (
ftnlen)44);
e_wsle();
io___16.ciunit = nout2;
s_wsle(&io___16);
do_lio(&c__9, &c__1, " OF PDS TO ANISN TYPE BINARY LIBRARY DATA", (ftnlen)
41);
e_wsle();
io___17.ciunit = nout2;
s_wsle(&io___17);
do_lio(&c__9, &c__1, " ********************************************", (
ftnlen)45);
e_wsle();
io___18.ciunit = nout2;
s_wsle(&io___18);
do_lio(&c__9, &c__1, " THE BINARY DATA IS AVAILABLE IN ANISN, TWOTRAN", (
ftnlen)47);
do_lio(&c__9, &c__1, " GMVP, MORSE, ETC.", (ftnlen)18);
e_wsle();
io___19.ciunit = nout2;
s_wsle(&io___19);
do_lio(&c__9, &c__1, " NOTE: ANISN FORMAT DOSE NOT INCLUDE MATERIAL-", (
ftnlen)46);
do_lio(&c__9, &c__1, " DEPENDENT FISSION SPECTRA.", (ftnlen)27);
e_wsle();
io___20.ciunit = nout2;
s_wsle(&io___20);
do_lio(&c__9, &c__1, " USE THE PRINTED FISSION SPECTRA IF NECESSARY.", (
ftnlen)46);
e_wsle();
io___21.ciunit = nout2;
s_wsle(&io___21);
e_wsle();
/* *********************************************************************** */
/* SET PL-TAG OF SRAC MEMBERS IN MACRO(1) OR MACROWRK(2) */
/* (SET INITIAL CHARACTER DATA) */
/* *********************************************************************** */
s_copy(title, " ", (ftnlen)
48, (ftnlen)48);
*(unsigned char *)&ptag[0] = '0';
*(unsigned char *)&ptag[1] = '1';
*(unsigned char *)&ptag[2] = 'X';
*(unsigned char *)&ptag[3] = 'X';
*(unsigned char *)&ptag[4] = 'X';
*(unsigned char *)&ptag[5] = 'X';
*(unsigned char *)&ptag[6] = '4';
*(unsigned char *)&ptag[7] = '3';
*(unsigned char *)&ptag[8] = '5';
*(unsigned char *)&ptag[9] = '6';
*(unsigned char *)&ptag[10] = '7';
*(unsigned char *)&ptag[11] = '8';
/* *********************************************************************** */
/* READ DIRECTORY NAME OF MACRO/MACROWRK */
/* Check MACRO or MACROWRK */
/* READ ENERGY GROUP STRUCTURE FROM CONTA00[0,2] */
/* *********************************************************************** */
/* IMAC=1 : MACRO */
/* =2 : MACROWRK */
io___24.ciunit = nin;
i__1 = s_rsfe(&io___24);
if (i__1 != 0) {
goto L9999;
}
i__1 = do_fio(&c__1, dirnam, (ftnlen)72);
if (i__1 != 0) {
goto L9999;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L9999;
}
s_copy(memnam, "CONTA000", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 1;
*(unsigned char *)etag = 'A';
goto L100;
}
s_copy(memnam, "CONTA002", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 2;
*(unsigned char *)etag = 'A';
goto L100;
}
s_copy(memnam, "CONTF000", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 1;
*(unsigned char *)etag = 'F';
goto L100;
}
s_copy(memnam, "CONTF002", (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)8);
if (irc == 0) {
imac = 2;
*(unsigned char *)etag = 'F';
goto L100;
}
io___31.ciunit = nout1;
s_wsle(&io___31);
do_lio(&c__9, &c__1, " ERROR : PDSIN FAILED, IRC=", (ftnlen)27);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
s_stop("999", (ftnlen)3);
L100:
engedt_(dirnam, &iout, &iprn, memnam, &ng, wt, en, (ftnlen)72, (ftnlen)8);
io___35.ciunit = nout2;
s_wsle(&io___35);
do_lio(&c__9, &c__1, " NUMBER OF ENERGY GROUPS = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&ng, (ftnlen)sizeof(integer));
e_wsle();
io___36.ciunit = nout2;
s_wsle(&io___36);
e_wsle();
io___37.ciunit = nout2;
s_wsle(&io___37);
do_lio(&c__9, &c__1, " << ENERGY BOUNDARY OF MACROSCOPIC XS >>", (ftnlen)
40);
e_wsle();
io___38.ciunit = nout2;
s_wsle(&io___38);
e_wsle();
io___39.ciunit = nout2;
s_wsfe(&io___39);
i__1 = ng + 1;
for (ig = 1; ig <= i__1; ++ig) {
do_fio(&c__1, (char *)&en[ig - 1], (ftnlen)sizeof(real));
}
e_wsfe();
io___41.ciunit = nout2;
s_wsle(&io___41);
e_wsle();
/* *********************************************************************** */
/* READ PL ORDER AND Monte Carlo Option */
/* MCOPT = 0 : accept negative XS (caused by transport correction) */
/* = 1 : not accept negative scattering XS */
/* SIGT = SIGT + ABS(SIGS) and SIGS=0 */
/* MSAVE = 0 : down-scattering size is forced to be NG-1 (suggested) */
/* = 1 : down-scattering size is searched (additional input NDS1 */
/* is necessary in GMVP (output library may be not available */
/* in some codes (ex. MORSE) */
/* *********************************************************************** */
io___42.ciunit = nin;
s_rsle(&io___42);
do_lio(&c__3, &c__1, (char *)&npl, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&mcopt, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&idebug, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&msave, (ftnlen)sizeof(integer));
e_rsle();
io___47.ciunit = nout2;
s_wsle(&io___47);
do_lio(&c__9, &c__1, " INPUT PL ORDER (NPL) = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&npl, (ftnlen)sizeof(integer));
e_wsle();
io___48.ciunit = nout2;
s_wsle(&io___48);
do_lio(&c__9, &c__1, " OPTION FOR NEGATIVE XS = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&mcopt, (ftnlen)sizeof(integer));
e_wsle();
io___49.ciunit = nout2;
s_wsle(&io___49);
do_lio(&c__9, &c__1, " OPTION FOR DEBUG PRINT = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&idebug, (ftnlen)sizeof(integer));
e_wsle();
io___50.ciunit = nout2;
s_wsle(&io___50);
do_lio(&c__9, &c__1, " OPTION FOR MEMORY SAVVING = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&msave, (ftnlen)sizeof(integer));
e_wsle();
if (npl < 0) {
io___51.ciunit = nout1;
s_wsle(&io___51);
do_lio(&c__9, &c__1, " ERROR: INPUT PL-OREDER(=", (ftnlen)25);
do_lio(&c__3, &c__1, (char *)&npl, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS INVALID", (ftnlen)12);
e_wsle();
}
if (mcopt != 0) {
mcopt = 1;
}
if (npl > 1) {
io___52.ciunit = nout1;
s_wsle(&io___52);
do_lio(&c__9, &c__1, " ERROR: INPUT PL-OREDER IS GREATER THAN", (
ftnlen)39);
do_lio(&c__9, &c__1, " PROGRAM ARRAY SIZE (=", (ftnlen)22);
do_lio(&c__3, &c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
s_stop("777", (ftnlen)3);
}
if (npl == 0 && imac == 2) {
*(unsigned char *)&ptag[6] = '2';
}
npl1 = npl + 1;
/* *********************************************************************** */
/* READ MEMBERS (MATERIALS) */
/* *********************************************************************** */
nmat = 0;
L200:
io___55.ciunit = nin;
i__1 = s_rsfe(&io___55);
if (i__1 != 0) {
goto L210;
}
i__1 = do_fio(&c__1, memnam, (ftnlen)8);
if (i__1 != 0) {
goto L210;
}
i__1 = do_fio(&c__1, (char *)&idum, (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L210;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L210;
}
if (s_cmp(memnam, " ", (ftnlen)8, (ftnlen)8) == 0) {
goto L210;
}
++nmat;
if (nmat > 50) {
io___57.ciunit = nout1;
s_wsle(&io___57);
do_lio(&c__9, &c__1, " ERROR: NUMBER OF INPUT MEMBERS IS ", (ftnlen)
35);
do_lio(&c__9, &c__1, " GREATER THAN PROGRAM ARRAY SIZE (=", (ftnlen)
35);
do_lio(&c__3, &c__1, (char *)&c__50, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
s_stop("777", (ftnlen)3);
}
s_copy(member + (nmat - 1 << 3), memnam, (ftnlen)8, (ftnlen)8);
idm[nmat - 1] = idum;
goto L200;
L210:
/* *********************************************************************** */
/* SEARCH MAX UP-SCATTERING AND MAX DOWN-SCATTERIG SIZES */
/* AMONG MEMBERS */
/* *********************************************************************** */
mxups = 0;
mxdws = 0;
i__1 = nmat;
for (m = 1; m <= i__1; ++m) {
i__2 = npl1;
for (l = 1; l <= i__2; ++l) {
s_copy(memnam, member + (m - 1 << 3), (ftnlen)8, (ftnlen)8);
*(unsigned char *)&memnam[4] = *(unsigned char *)etag;
*(unsigned char *)&memnam[7] = *(unsigned char *)&ptag[l + imac *
6 - 7];
pdsin_(dirnam, memnam, work, &leng, &irc, &iout, (ftnlen)72, (
ftnlen)8);
if (irc != 0) {
io___64.ciunit = nout1;
s_wsle(&io___64);
do_lio(&c__9, &c__1, " ERROR : PDSIN FAILED, IRC=", (ftnlen)
27);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
s_stop("999", (ftnlen)3);
}
ipos = 0;
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
lss = iwork[ipos];
lgv = iwork[ipos + 1];
lup = lss - 1;
ldw = lgv - lss;
mxups = max(lup,mxups);
mxdws = max(ldw,mxdws);
ipos = ipos + 10 + lgv;
/* L320: */
}
/* L310: */
}
/* L300: */
}
if (msave == 0) {
io___70.ciunit = nout2;
s_wsle(&io___70);
do_lio(&c__9, &c__1, " REAL MAX. SIZE OF DOWN-SCATTERING (", (ftnlen)
36);
do_lio(&c__3, &c__1, (char *)&mxdws, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") WAS REPLACED BY ", (ftnlen)18);
i__1 = ng - 1;
do_lio(&c__3, &c__1, (char *)&i__1, (ftnlen)sizeof(integer));
e_wsle();
mxdws = ng - 1;
}
io___71.ciunit = nout2;
s_wsle(&io___71);
do_lio(&c__9, &c__1, " MAX. SIZE OF UP-SCATTERING = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&mxups, (ftnlen)sizeof(integer));
e_wsle();
io___72.ciunit = nout2;
s_wsle(&io___72);
do_lio(&c__9, &c__1, " MAX. SIZE OF DOWN-SCATTERING = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&mxdws, (ftnlen)sizeof(integer));
e_wsle();
/* *********************************************************************** */
/* READ MEMBER XS AND SET IT IN ANISN FORMAT */
/* *********************************************************************** */
/* IHT : position of total cross section in a group XS data */
/* ISGG: position of self-scattering in a group XS data */
/* ITBL: length of a group XS data */
/* LSCT: length of a scattering data in a group */
/* LENG: record length of all group XS data */
/* NDS1: size of down-scattering + 1(self-scattering) */
iht = 3;
isgg = iht + mxups + 1;
itbl = isgg + mxdws;
lsct = mxups + 1 + mxdws;
leng = ng * itbl;
nds1 = mxdws + 1;
io___78.ciunit = nout2;
s_wsle(&io___78);
do_lio(&c__9, &c__1, " SIZE OF SCATTERING VECTOR = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&lsct, (ftnlen)sizeof(integer));
e_wsle();
io___79.ciunit = nout2;
s_wsle(&io___79);
do_lio(&c__9, &c__1, " IHT : POSITION OF TOTAL XS = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&iht, (ftnlen)sizeof(integer));
e_wsle();
io___80.ciunit = nout2;
s_wsle(&io___80);
do_lio(&c__9, &c__1, " ISGG: POSITION OF SELF-SCATTERNG = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&isgg, (ftnlen)sizeof(integer));
e_wsle();
io___81.ciunit = nout2;
s_wsle(&io___81);
do_lio(&c__9, &c__1, " ITBL: LENGTH OF A GROUP XS DATA = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&itbl, (ftnlen)sizeof(integer));
e_wsle();
io___82.ciunit = nout2;
s_wsle(&io___82);
do_lio(&c__9, &c__1, " NDS1: LENGTH OF DOWN+SELF SCAT. = ", (ftnlen)36);
do_lio(&c__3, &c__1, (char *)&nds1, (ftnlen)sizeof(integer));
e_wsle();
/* ----- MACEDT ARRANGEMENT ------------------------------ */
/* XSEX(g,1): production */
/* XSEX(g,2): fission */
/* XSEX(g,3): capture defined as (absorption - fission) */
/* XSEX(g,4): absorption */
/* XSEX(g,5): fission spectrum */
/* XSEX(g,6): diffusion coefficient (D1) */
/* XSEX(g,7): diffusion coefficient (D2) */
/* XSEX(g,8): total or transport */
/* XSEX(g,9): velocity cross section */
/* SCAT(g,g'): full size of scattering matrix (g=>g') */
/* ----- FOR ANISN FORMAT */
/* XSM(g,1,L,m) : absorption XS of m-th material (L-1 order) */
/* XSM(g,2,L,m) : production */
/* XSM(g,3,L,m) : total/transport */
/* SCM(g,g',L,m) : scattering matrix (g->g') of m-th material */
/* ----- Sample when NG=9 -------------------------------------- */
/* 1 2 IHT, [MXUPS] ISGG [MXDWS] ITBL */
/* g=1 Ag, Pg, Tg, 0 .....3->1 2->1 1->1 0 0 0 ....... 0 */
/* g=2 Ag, Pg, Tg, 0 0 ...4->2 3->2 2->2 1->2 ....... 0 */
/* g=3 Ag, Pg, Tg, 0 0 0 0 ....4->3 3->3 2->3 1->3 .. 0 */
/* : : : : : : : : : : */
/* : : : : : : : : : : */
/* g=9 Ag, Pg, Tg, 0 0 0 0 ......0 9->9 8->9 7->9 .... */
/* ------------------------------------------------------------- */
io___83.ciunit = nout2;
s_wsle(&io___83);
e_wsle();
i__1 = nmat;
for (m = 1; m <= i__1; ++m) {
io___84.ciunit = nout2;
s_wsle(&io___84);
e_wsle();
io___85.ciunit = nout2;
s_wsle(&io___85);
do_lio(&c__9, &c__1, " ******************************", (ftnlen)31);
e_wsle();
io___86.ciunit = nout2;
s_wsle(&io___86);
do_lio(&c__9, &c__1, " INPUT MEMBER NAME = ", (ftnlen)22);
do_lio(&c__9, &c__1, member + (m - 1 << 3), (ftnlen)8);
e_wsle();
io___87.ciunit = nout2;
s_wsle(&io___87);
do_lio(&c__9, &c__1, " INPUT MATERIAL ID = ", (ftnlen)22);
do_lio(&c__3, &c__1, (char *)&idm[m - 1], (ftnlen)sizeof(integer));
e_wsle();
io___88.ciunit = nout2;
s_wsle(&io___88);
do_lio(&c__9, &c__1, " ******************************", (ftnlen)31);
e_wsle();
io___89.ciunit = nout2;
s_wsle(&io___89);
e_wsle();
i__2 = npl1;
for (l = 1; l <= i__2; ++l) {
s_copy(memnam, member + (m - 1 << 3), (ftnlen)8, (ftnlen)8);
*(unsigned char *)&memnam[4] = *(unsigned char *)etag;
*(unsigned char *)&memnam[7] = *(unsigned char *)&ptag[l + imac *
6 - 7];
macedt_(dirnam, &iout, &iprn, memnam, &ng, xsec, &minsg, &maxsg,
scat, delay, (ftnlen)72, (ftnlen)8);
if (idebug == 1) {
io___95.ciunit = nout2;
s_wsle(&io___95);
e_wsle();
io___96.ciunit = nout2;
s_wsle(&io___96);
do_lio(&c__9, &c__1, " << MEMBER NAME OF THE PL(=", (ftnlen)
27);
i__3 = l - 1;
do_lio(&c__3, &c__1, (char *)&i__3, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") COMPONENT : ", (ftnlen)14);
do_lio(&c__9, &c__1, memnam, (ftnlen)8);
do_lio(&c__9, &c__1, " >>", (ftnlen)3);
e_wsle();
io___97.ciunit = nout2;
s_wsle(&io___97);
e_wsle();
}
s_copy(title, memnam, (ftnlen)8, (ftnlen)8);
io___98.ciunit = nbin;
s_wsue(&io___98);
do_uio(&c__1, (char *)&ng, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&itbl, (ftnlen)sizeof(integer));
i__3 = l - 1;
do_uio(&c__1, (char *)&i__3, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&idm[m - 1], (ftnlen)sizeof(integer));
do_uio(&c__1, title, (ftnlen)48);
e_wsue();
if (l == 1) {
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
xkai[ig + m * 107 - 108] = xsec[ig + 427];
/* L400: */
}
io___100.ciunit = nout2;
s_wsle(&io___100);
do_lio(&c__9, &c__1, " << MATERIAL DEPENDENT FISSION SPECTRU"
"M >>", (ftnlen)42);
e_wsle();
io___101.ciunit = nout2;
s_wsfe(&io___101);
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
do_fio(&c__1, (char *)&xkai[ig + m * 107 - 108], (ftnlen)
sizeof(real));
}
e_wsfe();
io___102.ciunit = nout2;
s_wsle(&io___102);
e_wsle();
}
/* *********************************************************************** */
i__3 = ng;
for (ig = 1; ig <= i__3; ++ig) {
xsm[ig + ((l + (m << 1)) * 3 + 1) * 107 - 1071] = xsec[ig +
320];
xsm[ig + ((l + (m << 1)) * 3 + 2) * 107 - 1071] = xsec[ig - 1]
;
xsm[ig + ((l + (m << 1)) * 3 + 3) * 107 - 1071] = xsec[ig +
748];
/* -----------Check Negative XS */
if (l == 1) {
if (xsm[ig + ((l + (m << 1)) * 3 + 1) * 107 - 1071] < 0.f)
{
io___104.ciunit = nout2;
s_wsfe(&io___104);
do_fio(&c__1, "ABSORPTION", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
if (xsm[ig + ((l + (m << 1)) * 3 + 2) * 107 - 1071] < 0.f)
{
io___105.ciunit = nout2;
s_wsfe(&io___105);
do_fio(&c__1, "PRODUCTION", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
if (xsm[ig + ((l + (m << 1)) * 3 + 3) * 107 - 1071] < 0.f)
{
io___106.ciunit = nout2;
s_wsfe(&io___106);
do_fio(&c__1, "TOTAL(TRA)", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
}
sum = 0.f;
i__4 = ng;
for (igg = 1; igg <= i__4; ++igg) {
scm[ig + (igg + (l + (m << 1)) * 107) * 107 - 34455] =
scat[ig + igg * 107 + 5135];
/* -----------Check Negative Scattering XS */
if (l == 1) {
if (scm[ig + (igg + (l + (m << 1)) * 107) * 107 -
34455] < 0.f) {
io___110.ciunit = nout2;
s_wsfe(&io___110);
do_fio(&c__1, "SCATTERING", (ftnlen)10);
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer)
);
do_fio(&c__1, (char *)&igg, (ftnlen)sizeof(
integer));
e_wsfe();
++note;
if (mcopt != 0) {
sum += (r__1 = scm[ig + (igg + (l + (m << 1))
* 107) * 107 - 34455], dabs(r__1));
scm[ig + (igg + (l + (m << 1)) * 107) * 107 -
34455] = 0.f;
}
}
}
/* L420: */
}
if (l == 1 && sum != 0.f) {
xsm[ig + ((l + (m << 1)) * 3 + 3) * 107 - 1071] += sum;
io___111.ciunit = nout2;
s_wsfe(&io___111);
do_fio(&c__1, (char *)&sum, (ftnlen)sizeof(real));
do_fio(&c__1, (char *)&ig, (ftnlen)sizeof(integer));
e_wsfe();
++note;
}
/* L410: */
}
/* --------- set one group XS data(one record) in WORK dimension */
/* (Note : loop on sink group) */
ipos = 0;
i__3 = ng;
for (igg = 1; igg <= i__3; ++igg) {
work[ipos] = xsm[igg + ((l + (m << 1)) * 3 + 1) * 107 - 1071];
work[ipos + 1] = xsm[igg + ((l + (m << 1)) * 3 + 2) * 107 -
1071];
work[ipos + 2] = xsm[igg + ((l + (m << 1)) * 3 + 3) * 107 -
1071];
ipos += 3;
/* -----------SET SCATTERIG XS (LSCT=MXUPS+1+MXDWS) */
i__4 = lsct;
for (k = 1; k <= i__4; ++k) {
ig = igg + mxups + 1 - k;
if (ig <= ng && ig >= 1) {
work[ipos + k - 1] = scm[ig + (igg + (l + (m << 1)) *
107) * 107 - 34455];
} else {
work[ipos + k - 1] = 0.f;
}
/* L440: */
}
ipos += lsct;
if (idebug == 1) {
itmp = ipos - (lsct + 3) + 1;
io___114.ciunit = nout2;
s_wsfe(&io___114);
do_fio(&c__1, (char *)&igg, (ftnlen)sizeof(integer));
i__4 = ipos;
for (i__ = itmp; i__ <= i__4; ++i__) {
do_fio(&c__1, (char *)&work[i__ - 1], (ftnlen)sizeof(
real));
}
e_wsfe();
}
/* L430: */
}
io___116.ciunit = nbin;
s_wsue(&io___116);
i__3 = ipos;
for (i__ = 1; i__ <= i__3; ++i__) {
do_uio(&c__1, (char *)&work[i__ - 1], (ftnlen)sizeof(real));
}
e_wsue();
/* L1100: */
}
/* L1000: */
}
if (note != 0) {
io___117.ciunit = nout2;
s_wsle(&io___117);
e_wsle();
io___118.ciunit = nout2;
s_wsle(&io___118);
do_lio(&c__9, &c__1, " THERE ARE ", (ftnlen)11);
do_lio(&c__3, &c__1, (char *)¬e, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " WARNING MESSAGES MARKED ", (ftnlen)25);
do_lio(&c__9, &c__1, "BY (!!! WARNING:) ", (ftnlen)18);
e_wsle();
io___119.ciunit = nout2;
s_wsle(&io___119);
e_wsle();
}
io___120.ciunit = nout2;
s_wsle(&io___120);
e_wsle();
io___121.ciunit = nout2;
s_wsle(&io___121);
do_lio(&c__9, &c__1, " ================ NORMAL END ===================", (
ftnlen)48);
e_wsle();
/* *********************************************************************** */
L9999:
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* Subroutine */ int geoutg_(integer *iprt)
{
/* Initialized data */
static char elemnt[2*107] = " H" "He" "Li" "Be" " B" " C" " N" " O" " F"
"Ne" "Na" "Mg" "Al" "Si" " P" " S" "Cl" "Ar" " K" "Ca" "Sc" "Ti"
" V" "Cr" "Mn" "Fe" "Co" "Ni" "Cu" "Zn" "Ga" "Ge" "As" "Se" "Br"
"Kr" "Rb" "Sr" " Y" "Zr" "Nb" "Mo" "Tc" "Ru" "Rh" "Pd" "Ag" "Cd"
"In" "Sn" "Sb" "Te" " I" "Xe" "Cs" "Ba" "La" "Ce" "Pr" "Nd" "Pm"
"Sm" "Eu" "Gd" "Tb" "Dy" "Ho" "Er" "Tm" "Yb" "Lu" "Hf" "Ta" " W"
"Re" "Os" "Ir" "Pt" "Au" "Hg" "Tl" "Pb" "Bi" "Po" "At" "Rn" "Fr"
"Ra" "Ac" "Th" "Pa" " U" "Np" "Pu" "Am" "Cm" "Bk" "Cf" "XX" "Fm"
"Md" "Cb" "++" " +" "--" " -" "Tv";
static char type__[1*3] = "r" "a" "d";
/* System generated locals */
address a__1[3];
integer i__1, i__2[3], i__3, i__4;
doublereal d__1;
olist o__1;
alist al__1;
/* Builtin functions */
integer f_open(olist *);
double asin(doublereal);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer f_rew(alist *), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void), s_rsfe(cilist *), e_rsfe(void), s_cmp(char
*, char *, ftnlen, ftnlen);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_wsle(cilist *), e_wsle(void);
/* Local variables */
static integer i__, j, l, nbi, nci;
extern /* Subroutine */ int xxx_(char *, integer *, integer *, integer *,
integer *, char *, ftnlen, ftnlen);
static integer igeo[360] /* was [3][120] */;
static char line[15*3*120];
static integer nopt;
static char blank[80];
static doublereal degree;
static char optdat[14*360];
static integer maxtxt;
/* Fortran I/O blocks */
static cilist io___10 = { 0, 21, 0, "(F12.6)", 0 };
static cilist io___11 = { 0, 21, 0, "(F12.6)", 0 };
static cilist io___12 = { 0, 21, 0, "(A)", 0 };
static cilist io___17 = { 0, 0, 0, "(1X,A,I4,A,I4,A,I4,A,I4)", 0 };
static cilist io___18 = { 0, 0, 0, "(1X,A,I4,A,I4,A,I4,A,I4)", 0 };
static cilist io___19 = { 0, 0, 0, "(1X,A,I4,A,I4,A,I4,A,I4)", 0 };
static cilist io___21 = { 0, 0, 0, "(1X,A,I4,A,I4,A,I4,A,I4)", 0 };
static cilist io___22 = { 0, 0, 0, 0, 0 };
static cilist io___23 = { 0, 0, 0, "(A,F12.6)", 0 };
static cilist io___24 = { 0, 0, 0, "(A,F12.6)", 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 */
/* *********************************************************************** */
/* GEOUTG WRITES OUT THE GEOMETRY IN GAUSSIAN-8X STYLE */
/* *********************************************************************** */
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
/* L10: */
igeo[j + i__ * 3 - 4] = -1;
}
}
i__1 = geovar_1.nvar;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L20: */
igeo[geovar_1.loc[(i__ << 1) - 1] + geovar_1.loc[(i__ << 1) - 2] * 3
- 4] = -2;
}
i__1 = geosym_1.ndep;
for (i__ = 1; i__ <= i__1; ++i__) {
if (geosym_1.idepfn[i__ - 1] == 14) {
igeo[geosym_1.locdep[i__ - 1] * 3 - 1] = -geosym_1.locpar[i__ - 1]
;
} else {
if (geosym_1.idepfn[i__ - 1] > 3) {
goto L30;
}
igeo[geosym_1.idepfn[i__ - 1] + geosym_1.locdep[i__ - 1] * 3 - 4]
= geosym_1.locpar[i__ - 1];
}
L30:
;
}
o__1.oerr = 0;
o__1.ounit = 21;
o__1.ofnm = 0;
o__1.orl = 0;
o__1.osta = "SCRATCH";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
f_open(&o__1);
degree = 90. / asin(1.);
maxtxt = *(unsigned char *)atomtx_1.ltxt;
nopt = 0;
i__1 = geokst_1.natoms;
for (i__ = 1; i__ <= i__1; ++i__) {
for (j = 1; j <= 3; ++j) {
s_copy(line + (j + i__ * 3 - 4) * 15, " ", (ftnlen)15, (ftnlen)1);
if (igeo[j + i__ * 3 - 4] == -1) {
al__1.aerr = 0;
al__1.aunit = 21;
f_rew(&al__1);
if (j != 1) {
s_wsfe(&io___10);
d__1 = geom_1.geo[j + i__ * 3 - 4] * degree;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
s_wsfe(&io___11);
do_fio(&c__1, (char *)&geom_1.geo[j + i__ * 3 - 4], (
ftnlen)sizeof(doublereal));
e_wsfe();
}
al__1.aerr = 0;
al__1.aunit = 21;
f_rew(&al__1);
s_rsfe(&io___12);
do_fio(&c__1, line + (j + i__ * 3 - 4) * 15, (ftnlen)15);
e_rsfe();
} else if (igeo[j + i__ * 3 - 4] == -2) {
++nopt;
if (s_cmp(simbol_1.simbol + (nopt - 1) * 10, "---", (ftnlen)
10, (ftnlen)3) != 0) {
if (*(unsigned char *)&simbol_1.simbol[(nopt - 1) * 10] ==
'-') {
s_copy(line + ((j + i__ * 3 - 4) * 15 + 3),
simbol_1.simbol + ((nopt - 1) * 10 + 1), (
ftnlen)12, (ftnlen)9);
} else {
s_copy(line + ((j + i__ * 3 - 4) * 15 + 3),
simbol_1.simbol + (nopt - 1) * 10, (ftnlen)12,
(ftnlen)10);
}
} else {
nbi = geokst_1.nb[i__ - 1];
nci = geokst_1.nc[i__ - 1];
if (j != 3) {
nci = 0;
}
if (j == 1) {
nbi = 0;
}
xxx_(type__ + (j - 1), &i__, &geokst_1.na[i__ - 1], &nbi,
&nci, line + ((j + i__ * 3 - 4) * 15 + 3), (
ftnlen)1, (ftnlen)12);
}
s_copy(optdat + (nopt - 1) * 14, line + (j + i__ * 3 - 4) *
15, (ftnlen)14, (ftnlen)15);
} else if (igeo[j + i__ * 3 - 4] < 0) {
s_copy(line + (i__ * 3 - 1) * 15, line + (-igeo[j + i__ * 3 -
4] * 3 - 1) * 15, (ftnlen)15, (ftnlen)15);
*(unsigned char *)&line[(i__ * 3 - 1) * 15 + 2] = '-';
} else {
s_copy(line + (j + i__ * 3 - 4) * 15, line + (j + igeo[j +
i__ * 3 - 4] * 3 - 4) * 15, (ftnlen)15, (ftnlen)15);
}
/* L40: */
}
/* Writing concatenation */
i__2[0] = 2, a__1[0] = elemnt + (geokst_1.labels[i__ - 1] - 1 << 1);
i__2[1] = 8, a__1[1] = atomtx_1.txtatm + (i__ - 1 << 3);
i__2[2] = 2, a__1[2] = " ";
s_cat(blank, a__1, i__2, &c__3, (ftnlen)80);
if (geokst_1.labels[i__ - 1] == 99) {
*(unsigned char *)blank = ' ';
}
/* Computing MAX */
i__3 = 4, i__4 = maxtxt + 2;
j = max(i__3,i__4);
if (i__ == 1) {
io___17.ciunit = *iprt;
s_wsfe(&io___17);
do_fio(&c__1, blank, j);
e_wsfe();
} else if (i__ == 2) {
io___18.ciunit = *iprt;
s_wsfe(&io___18);
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&geokst_1.na[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 3) * 15, (ftnlen)15);
e_wsfe();
} else if (i__ == 3) {
io___19.ciunit = *iprt;
s_wsfe(&io___19);
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&geokst_1.na[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 3) * 15, (ftnlen)15);
do_fio(&c__1, (char *)&geokst_1.nb[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 2) * 15, (ftnlen)15);
e_wsfe();
} else {
l = 0;
io___21.ciunit = *iprt;
s_wsfe(&io___21);
do_fio(&c__1, blank, j);
do_fio(&c__1, (char *)&geokst_1.na[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 3) * 15, (ftnlen)15);
do_fio(&c__1, (char *)&geokst_1.nb[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 2) * 15, (ftnlen)15);
do_fio(&c__1, (char *)&geokst_1.nc[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, line + (i__ * 3 - 1) * 15, (ftnlen)15);
do_fio(&c__1, (char *)&l, (ftnlen)sizeof(integer));
e_wsfe();
}
/* L50: */
}
io___22.ciunit = *iprt;
s_wsle(&io___22);
e_wsle();
for (l = 1; l <= 3; ++l) {
i__1 = nopt;
for (i__ = 1; i__ <= i__1; ++i__) {
if (geovar_1.loc[(i__ << 1) - 1] == l) {
if (geovar_1.loc[(i__ << 1) - 1] != 1) {
io___23.ciunit = *iprt;
s_wsfe(&io___23);
do_fio(&c__1, optdat + (i__ - 1) * 14, (ftnlen)14);
d__1 = geom_1.geo[geovar_1.loc[(i__ << 1) - 1] +
geovar_1.loc[(i__ << 1) - 2] * 3 - 4] * degree;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___24.ciunit = *iprt;
s_wsfe(&io___24);
do_fio(&c__1, optdat + (i__ - 1) * 14, (ftnlen)14);
do_fio(&c__1, (char *)&geom_1.geo[geovar_1.loc[(i__ << 1)
- 1] + geovar_1.loc[(i__ << 1) - 2] * 3 - 4], (
ftnlen)sizeof(doublereal));
e_wsfe();
}
}
/* L60: */
}
/* L70: */
}
return 0;
} /* geoutg_ */
/* Subroutine */ int prcomf_0_(int n__, char *file, char *delim, char *
command, char *error, char *level, ftnlen file_len, ftnlen delim_len,
ftnlen command_len, ftnlen error_len, ftnlen level_len)
{
/* Initialized data */
static integer nest = 0;
/* System generated locals */
integer i__1;
cilist ci__1;
cllist cl__1;
/* Builtin functions */
integer s_rnge(char *, integer, char *, integer), f_clos(cllist *);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
i_indx(char *, char *, ftnlen, ftnlen);
/* Local variables */
extern logical have_(char *, ftnlen);
static integer i__, j;
static char files[80*8];
static integer units[8];
extern /* Subroutine */ int lbuild_(char *, integer *, char *, char *,
ftnlen, ftnlen, ftnlen);
extern integer lastnb_(char *, ftnlen);
static integer iostat;
extern /* Subroutine */ int rstbuf_(void), putbuf_(char *, ftnlen),
txtopr_(char *, integer *, ftnlen);
/* $ Abstract */
/* Keep track of nested command files. */
/* $ 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. */
/* $ Keywords */
/* PARSE */
/* $ Declarations */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* FILE I Command file. */
/* DELIM I Symbol delimiting the end of a command. */
/* COMMAND O Command read from FILE. */
/* ERROR O Error flag. */
/* LEVEL O A list of all files currently open. */
/* $ Detailed_Input */
/* FILE is the name of a file from which a sequence of commands */
/* is to be read. These commands may include commands to */
/* read from other files. */
/* DELIM is the character which delimits the end of each */
/* instruction in FILE. */
/* $ Detailed_Output */
/* COMMAND is a command read from the current file. */
/* If no files are currently open, COMMAND = DELIM. */
/* ERROR is a descriptive error message, which is blank when */
/* no error occurs. */
/* LEVEL is a list of the files currently open, in the order */
/* in which they were opened. It is provided for trace- */
/* back purposes. */
/* $ Detailed_Description */
/* PRCOMF opens, reads, and closes sets of (possibly nested) */
/* command files. For example, consider the following command */
/* files. */
/* FILE_A : A1 FILE_B : B1 FILE_C : C1 */
/* A2 START FILE_C C2 */
/* A3 B2 C3 */
/* START FILE_B B3 */
/* A4 B4 */
/* A5 */
/* If the command 'START FILE_A' were issued, we would expect the */
/* following sequence of commands to ensue: */
/* A1, A2, A3, B1, C1, C2, C3, B2, B3, B4, A4, A5. */
/* The first file immediately becomes, ipso facto, the current file. */
/* Subsequently, instructions are read from the current file until */
/* either a START or the end of the file is encountered. Each time */
/* a new START is encountered, the current file (that is, the */
/* location of the next command in the file) is placed on a stack, */
/* and the first command is read from the new file (which then */
/* becomes the current file). Each time the end of the current file */
/* is encountered, the previous file is popped off the top of the */
/* stack to become the current file. This continues until there are */
/* no files remaining on the stack. */
/* On occasion, the user may wish to exit from a file without */
/* reading the rest of the file. In this case, the previous file */
/* is popped off the stack without further ado. */
/* Also, the user may wish to abruptly stop an entire nested */
/* set of files. In this case, all of the files are popped off */
/* the stack, and no further commands are returned. */
/* PRCOMF and its entry points may be used to process any such */
/* set of files. These entry points are: */
/* - PRCLR ( ERROR ) */
/* This clears the stack. It may thus be used to implement */
/* a STOP command. In any case, it must be called before */
/* any of the other entry points are called. */
/* - PRSTRT ( FILE, ERROR ) */
/* This introduces a new file, causing the current file (if */
/* any) to be placed on the stack, and replacing it with FILE. */
/* It may thus be used to implement a START command. */
/* If the file cannot be opened, or the stack is already */
/* full (it can hold up to seven files), ERROR will contain */
/* a descriptive error message upon return. Otherwise, it */
/* will be blank. */
/* - PRREAD ( COMMAND ) */
/* This causes the next command to be read from the current */
/* file. If the end of the current file is reached, the */
/* previous file is popped off the stack, and the next command */
/* from this file is read instead. (If no files remain to be */
/* read, DELIM is returned.) */
/* - PREXIT */
/* This causes the previous file to be popped off the top of */
/* the stack to replace the current file. It may thus be used */
/* to implement an EXIT command. */
/* - PRTRCE ( LEVEL ) */
/* Should an error occur during the execution of a nested */
/* file, it may be helpful to know the sequence in which */
/* the nested files were invoked. PRTRCE returns a list of */
/* the files currently open, in the order in which they were */
/* invoked. */
/* $ Input_Files */
/* All files read by PRCOMF are opened with logical units */
/* determined at run time. */
/* $ Output_Files */
/* None. */
/* $ Input_Common */
/* None. */
/* $ Output_Common */
/* None. */
/* $ Examples */
/* See Detailed_Description. */
/* $ Restrictions */
/* The declared length of ERROR should be at least 80, to avoid */
/* truncationof error messages. */
/* $ Author_and_Institution */
/* W. L. Taber (JPL) */
/* I. M. Underwood (JPL) */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* Version 1, 6-SEP-1986 */
/* -& */
/* OPTLIB functions */
/* Local variables */
/* NFILES is the maximum number of files that may be open at */
/* any given time. THus, nesting of procedures is limited to */
/* a depth of NFILES. */
/* NEST is the number of files currently open. */
/* FILES are the names of the files on the stack. UNITS are */
/* the logical units to which they are connected. */
switch(n__) {
case 1: goto L_prclr;
case 2: goto L_prstrt;
case 3: goto L_prread;
case 4: goto L_prexit;
case 5: goto L_prtrce;
}
return 0;
/* $ Procedure PRCLR */
L_prclr:
/* $ Abstract */
/* Clear the file stack. */
/* $ 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. */
/* $ Brief_I/O */
/* None. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Pop all the files off the stack. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
while(nest > 0) {
cl__1.cerr = 0;
cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)326)];
cl__1.csta = 0;
f_clos(&cl__1);
--nest;
}
return 0;
/* $ Procedure PRSTRT */
L_prstrt:
/* $ Abstract */
/* Put the current file on the stack, and replace it with 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. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* FILE I New command file. */
/* ERROR O Error flag. */
/* $ Detailed_Input */
/* FILE is the new current file from which commands are */
/* to be read. */
/* $ Detailed_Output */
/* ERROR is blank when no error occurs, and otherwise contains */
/* a descriptive message. Possible errors are: */
/* - The stack is full. */
/* - FILE could not be opened. */
/* $ Input_Files */
/* FILE is opened with a logical unit determined at run time. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* If the stack is full, return an error. Otherwise, try to open */
/* FILE. If an error occurs, return immediately. Otherwise, put */
/* the current file on the stack, and increase the nesting level. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
/* No error yet. */
s_copy(error, " ", error_len, (ftnlen)1);
/* Proceed only if the stack is not full. */
if (nest == 8) {
s_copy(error, "PRSTRT: Command files are nested too deeply.",
error_len, (ftnlen)44);
return 0;
} else {
++nest;
}
/* Get a new logical unit. If none are available, abort. */
txtopr_(file, &units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
"units", i__1, "prcomf_", (ftnlen)445)], file_len);
if (have_(error, error_len)) {
--nest;
} else {
s_copy(files + ((i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
"files", i__1, "prcomf_", (ftnlen)450)) * 80, file, (ftnlen)
80, file_len);
}
return 0;
/* $ Procedure PRREAD */
L_prread:
/* $ Abstract */
/* Read the next command from the current 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. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* DELIM I Character delimiting the end of a command. */
/* COMMAND O Next command from the current file. */
/* $ Detailed_Input */
/* DELIM is the character used to delimit the end of a */
/* command within a command file. */
/* $ Detailed_Output */
/* COMMAND is the next command read from the current file. */
/* If there is no current file, COMMND = DELIM. */
/* $ Input_Files */
/* All files read by PRCOMF are opened with logical units */
/* determined at run time. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Attempt to read the next statement from the current file. */
/* If the end of the file is encountered, pop the previous file */
/* off the top of the stack, and try to read from it. Keep this */
/* up until a command is read, or until no files remain open. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
/* Don't even bother unless at least one file is open. */
if (nest == 0) {
s_copy(command, delim, command_len, (ftnlen)1);
return 0;
}
/* Keep trying to read until we run out of files. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 : s_rnge(
"units", i__1, "prcomf_", (ftnlen)558)];
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, command, command_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
while(iostat != 0 && nest > 0) {
cl__1.cerr = 0;
cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)562)];
cl__1.csta = 0;
f_clos(&cl__1);
--nest;
if (nest >= 1) {
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)566)];
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, command, command_len);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
;
}
}
rstbuf_();
if (nest == 0) {
s_copy(command, delim, command_len, (ftnlen)1);
putbuf_(command, command_len);
return 0;
}
putbuf_(command, command_len);
/* Okay, we have something. Keep reading until DELIM is found. */
/* (Or until the file ends.) Add each successive line read to */
/* the end of COMMAND. Do not return the delimiter itself. */
j = 1;
i__ = i_indx(command, delim, command_len, (ftnlen)1);
while(i__ == 0 && iostat == 0) {
j = lastnb_(command, command_len) + 1;
*(unsigned char *)&command[j - 1] = ' ';
++j;
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)597)];
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, command + (j - 1), command_len - (j - 1));
if (iostat != 0) {
goto L100003;
}
iostat = e_rsfe();
L100003:
putbuf_(command + (j - 1), command_len - (j - 1));
i__ = i_indx(command, delim, command_len, (ftnlen)1);
}
if (i__ > 0) {
s_copy(command + (i__ - 1), " ", command_len - (i__ - 1), (ftnlen)1);
}
return 0;
/* $ Procedure PREXIT */
L_prexit:
/* $ Abstract */
/* Replace the current file with the one at the top of the stack. */
/* $ 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. */
/* $ Brief_I/O */
/* None. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* None. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Close the current file. Pop the previous file off the top of */
/* the stack. If there is no current file, of if there are no */
/* files on the stack, that's cool too. */
/* $ Examples */
/* None. */
/* $ Restrictions */
/* None. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
if (nest > 0) {
cl__1.cerr = 0;
cl__1.cunit = units[(i__1 = nest - 1) < 8 && 0 <= i__1 ? i__1 :
s_rnge("units", i__1, "prcomf_", (ftnlen)695)];
cl__1.csta = 0;
f_clos(&cl__1);
--nest;
}
return 0;
/* $ Procedure PRTRCE */
L_prtrce:
/* $ Abstract */
/* Provide a list of the files currently open, in the order in */
/* which they were opened. */
/* $ 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. */
/* $ Brief_I/O */
/* VARIABLE I/O DESCRIPTION */
/* -------- --- --------------------------------------------------- */
/* LEVEL O List of all files currently open. */
/* $ Detailed_Input */
/* None. */
/* $ Detailed_Output */
/* LEVEL A list of all files that are currently open, in */
/* the order in which they were opened. For example, */
/* if FILE_A starts FILE_B, and FILE_B starts FILE_C, */
/* LEVEL would be 'FILE_A:FILE_B:_FILE_C'. */
/* $ Input_Files */
/* None. */
/* $ Output_Files */
/* None. */
/* $ Input_Output_Common */
/* None. */
/* $ Detailed_Description */
/* Just step through the stack, Jack. */
/* $ Examples */
/* See Detailed_Description. */
/* $ Restrictions */
/* LEVEL should be declared to be at least CHARACTER*640 by the */
/* calling program to ensure that enough space is available to */
/* list all open files. */
/* $ Version */
/* - Command Loop Configured Version 1.0.0, 3-MAY-1994 (WLT) */
/* This is the configured version of the Command Loop */
/* software as of May 4, 1994 */
/* - */
/* Not much to explain. Use LBUILD to build a list, delimited */
/* by colons. */
s_copy(level, " ", level_len, (ftnlen)1);
if (nest > 0) {
lbuild_(files, &nest, ":", level, (ftnlen)80, (ftnlen)1, level_len);
}
return 0;
} /* prcomf_ */
/* $Procedure PROMPT ( Prompt a user for a string ) */
/* Subroutine */ int prompt_(char *prmpt, char *string, ftnlen prmpt_len,
ftnlen string_len)
{
/* System generated locals */
integer i__1, i__2;
cilist ci__1;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
s_rsfe(cilist *), e_rsfe(void), i_len(char *, ftnlen);
/* Local variables */
extern /* Subroutine */ int chkin_(char *, ftnlen), errch_(char *, char *,
ftnlen, ftnlen), sigerr_(char *, ftnlen), chkout_(char *, ftnlen)
, setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
/* $ Abstract */
/* This routine prompts a user for keyboard input. */
/* $ 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 */
/* None. */
/* $ Keywords */
/* UTILITY */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* PRMPT I The prompt to use when asking for input. */
/* STRING O The response typed by a user. */
/* $ Detailed_Input */
/* PRMPT is a character string that will be displayed from the */
/* current cursor position and describes the input that */
/* the user is expected to enter. The string PRMPT should */
/* be relatively short, i.e., 50 or fewer characters, so */
/* that a response may be typed on the line where the */
/* prompt appears. */
/* All characters (including trailing blanks) in PRMPT */
/* are considered significant and will be displayed. */
/* $ Detailed_Output */
/* STRING is a character string that contains the string */
/* entered by the user. */
/* $ Parameters */
/* None. */
/* $ Exceptions */
/* This subroutine uses discovery check-in so that it may be called */
/* after an error has occurred. */
/* 1) If the attempt to write the prompt to the standard output */
/* device fails, returning an IOSTAT value not equal to zero, the */
/* error SPICE(WRITEFAILED) will be signalled. */
/* 2) If the attempt to read the response from the standard input */
/* device fails, returning an IOSTAT value not equal to zero, the */
/* error SPICE(READFAILED) will be signalled. */
/* $ Files */
/* None. */
/* $ Particulars */
/* This is a utility that allows you to "easily" request information */
/* from a program user. At a high level, it frees you from the */
/* peculiarities of a particular implementation of FORTRAN cursor */
/* control. */
/* $ Examples */
/* Suppose you wanted to ask a user to input an answer to */
/* a question such as "Do you want to try again? (Y/N) " */
/* and leave the cursor at the end of the question as shown here: */
/* Do you want to try again? (Y/N) _ */
/* (The underscore indicates the cursor position). */
/* The following line of code will do what you want. */
/* CALL PROMPT ( 'Do you want to try again? (Y/N) ', ANSWER ) */
/* $ Restrictions */
/* This routine is environment specific. Standard FORTRAN does not */
/* provide for user control of cursor position after write */
/* statements. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* K.R. Gehringer (JPL) */
/* W.L. Taber (JPL) */
/* $ Version */
/* - SPICELIB Version 3.25.0, 10-MAR-2014 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-INTEL. */
/* - SPICELIB Version 3.24.0, 10-MAR-2014 (BVS) */
/* Updated for PC-LINUX-64BIT-IFORT. */
/* - SPICELIB Version 3.23.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-GFORTRAN. */
/* - SPICELIB Version 3.22.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GFORTRAN. */
/* - SPICELIB Version 3.21.0, 10-MAR-2014 (BVS) */
/* Updated for PC-CYGWIN-64BIT-GCC_C. */
/* - SPICELIB Version 3.20.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL. */
/* - SPICELIB Version 3.19.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-CC_C. */
/* - SPICELIB Version 3.18.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-INTEL-64BIT-CC_C. */
/* - SPICELIB Version 3.17.0, 13-MAY-2010 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-NATIVE_C. */
/* - SPICELIB Version 3.16.0, 13-MAY-2010 (BVS) */
/* Updated for PC-WINDOWS-64BIT-IFORT. */
/* - SPICELIB Version 3.15.0, 13-MAY-2010 (BVS) */
/* Updated for PC-LINUX-64BIT-GFORTRAN. */
/* - SPICELIB Version 3.14.0, 13-MAY-2010 (BVS) */
/* Updated for PC-64BIT-MS_C. */
/* - SPICELIB Version 3.13.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-INTEL_C. */
/* - SPICELIB Version 3.12.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-IFORT. */
/* - SPICELIB Version 3.11.0, 13-MAY-2010 (BVS) */
/* Updated for MAC-OSX-64BIT-GFORTRAN. */
/* - SPICELIB Version 3.10.0, 18-MAR-2009 (BVS) */
/* Updated for PC-LINUX-GFORTRAN. */
/* - SPICELIB Version 3.9.0, 18-MAR-2009 (BVS) */
/* Updated for MAC-OSX-GFORTRAN. */
/* - SPICELIB Version 3.8.0, 19-FEB-2008 (BVS) */
/* Updated for PC-LINUX-IFORT. */
/* - SPICELIB Version 3.7.0, 14-NOV-2006 (BVS) */
/* Updated for PC-LINUX-64BIT-GCC_C. */
/* - SPICELIB Version 3.6.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-INTEL_C. */
/* - SPICELIB Version 3.5.0, 14-NOV-2006 (BVS) */
/* Updated for MAC-OSX-IFORT. */
/* - SPICELIB Version 3.4.0, 14-NOV-2006 (BVS) */
/* Updated for PC-WINDOWS-IFORT. */
/* - SPICELIB Version 3.3.0, 26-OCT-2005 (BVS) */
/* Updated for SUN-SOLARIS-64BIT-GCC_C. */
/* - SPICELIB Version 3.2.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN_C. */
/* - SPICELIB Version 3.1.0, 03-JAN-2005 (BVS) */
/* Updated for PC-CYGWIN. */
/* - SPICELIB Version 3.0.5, 17-JUL-2002 (BVS) */
/* Added MAC-OSX environments. */
/* - SPICELIB Version 3.0.4, 08-OCT-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are WIN-NT */
/* - SPICELIB Version 3.0.3, 24-SEP-1999 (NJB) */
/* CSPICE environments were added. Some typos were corrected. */
/* - SPICELIB Version 3.0.2, 28-JUL-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. New */
/* environments are PC-DIGITAL, SGI-O32 and SGI-N32. */
/* - SPICELIB Version 3.0.1, 18-MAR-1999 (WLT) */
/* The environment lines were expanded so that the supported */
/* environments are now explicitely given. Previously, */
/* environments such as SUN-SUNOS and SUN-SOLARIS were implied */
/* by the environment label SUN. */
/* - SPICELIB Version 3.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 20-JUL-1995 (WLT) (KRG) */
/* This routine now participates in error handling. It */
/* checks to make sure no I/O errors have occurred while */
/* attempting to write to standard output or read from standard */
/* input. It uses discovery checkin if an error is detected. */
/* Restructured the subroutine a little bit; the writing of the */
/* prompt is the only bit that is environment specific, so the */
/* code was rearranged to reflect this. There is now only a single */
/* READ statement. */
/* - SPICELIB Version 1.0.0, 15-OCT-1992 (WLT) */
/* -& */
/* $ Index_Entries */
/* Prompt for keyboard input */
/* Prompt for input with a user supplied message */
/* -& */
/* $ Revisions */
/* - SPICELIB Version 3.0.0, 08-APR-1998 (NJB) */
/* Module was updated for the PC-LINUX platform. */
/* - SPICELIB Version 2.0.0, 20-JUL-1995 (WLT) (KRG) */
/* This routine now participates in error handling. It */
/* checks to make sure no I/O errors have occurred while */
/* attempting to write to standard output or read from standard */
/* input. It uses discovery checkin if an error is detected. */
/* Restructured the subroutine a little bit; the writing of the */
/* prompt is the only bit that is environment specific, so the */
/* code was rearranged to reflect this. There is now only a single */
/* READ statement. */
/* -& */
/* Local variables */
/* The code below should be used in the following environments: */
/* SUN/Fortran, */
/* HP/HP-Fortran, */
/* Silicon Graphics/Silicon Graphics Fortran, */
/* DEC Alpha-OSF/1--DEC Fortran, */
/* NeXT/Absoft Fortran */
/* PC Linux/Fort77 */
ci__1.cierr = 1;
ci__1.ciunit = 6;
ci__1.cifmt = "(A,$)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, prmpt, prmpt_len);
if (iostat != 0) {
goto L100001;
}
iostat = e_wsfe();
L100001:
/* If none of the write statements above works on a particular */
/* unsupported platform, read on... */
/* Although, this isn't really what you want, if you need to port */
/* this quickly to an environment that does not support the format */
/* statement in any of the cases above, you can comment out the */
/* write statement above and un-comment the write statement below. */
/* In this way you can get a program working quickly in the new */
/* environment while you figure out how to control cursor */
/* positioning. */
/* WRITE (*,*, IOSTAT=IOSTAT ) PRMPT */
/* Check for a write error. It's not likely, but the standard output */
/* can be redirected. Better safe than confused later. */
if (iostat != 0) {
chkin_("PROMPT", (ftnlen)6);
setmsg_("An error occurred while attempting to write a prompt to the"
" standard output device, possibly because standard output ha"
"s been redirected to a file. There is not much that can be d"
"one about this if it happens. We do not try to determine whe"
"ther standard output has been redirected, so be sure that th"
"ere are sufficient resources available for the operation bei"
"ng performed.", (ftnlen)372);
sigerr_("SPICE(WRITEFAILED)", (ftnlen)18);
chkout_("PROMPT", (ftnlen)6);
return 0;
}
/* Now that we've written out the prompt and there was no error, we */
/* can read in the response. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = 5;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, string, string_len);
if (iostat != 0) {
goto L100002;
}
iostat = e_rsfe();
L100002:
if (iostat != 0) {
chkin_("PROMPT", (ftnlen)6);
setmsg_("An error occurred while attempting to retrieve a reply to t"
"he prompt \"#\". A possible cause is that you have exhauste"
"d the input buffer while attempting to type your response. "
"It may help if you limit your response to # or fewer charact"
"ers. ", (ftnlen)242);
errch_("#", prmpt, (ftnlen)1, prmpt_len);
/* Computing MIN */
i__2 = i_len(string, string_len);
i__1 = min(i__2,131);
errint_("#", &i__1, (ftnlen)1);
sigerr_("SPICE(READFAILED)", (ftnlen)17);
chkout_("PROMPT", (ftnlen)6);
return 0;
}
return 0;
} /* prompt_ */
/* Subroutine */ int alarqg_(char *path, integer *nmats, logical *dotype,
integer *ntypes, integer *nin, integer *nout)
{
/* Initialized data */
static char intstr[10] = "0123456789";
/* Format strings */
static char fmt_9995[] = "(//\002 *** Not enough matrix types on input l"
"ine\002,/a79)";
static char fmt_9994[] = "(\002 ==> Specify \002,i4,\002 matrix types on"
" this line or \002,\002adjust NTYPES on previous line\002)";
static char fmt_9996[] = "(//\002 *** Invalid integer value in column"
" \002,i2,\002 of input\002,\002 line:\002,/a79)";
static char fmt_9997[] = "(\002 *** Warning: duplicate request of matri"
"x type \002,i2,\002 for \002,a3)";
static char fmt_9999[] = "(\002 *** Invalid type request for \002,a3,"
"\002, type \002,i4,\002: must satisfy 1 <= type <= \002,i2)";
static char fmt_9998[] = "(/\002 *** End of file reached when trying to "
"read matrix \002,\002types for \002,a3,/\002 *** Check that you "
"are requesting the\002,\002 right number of types for each pat"
"h\002,/)";
/* System generated locals */
integer i__1;
cilist ci__1;
/* Local variables */
integer i__, j, k;
char c1[1];
integer i1, ic, nt;
char line[80];
integer lenp, nreq[100];
logical firstt;
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___19 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___20 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___21 = { 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 */
/* ======= */
/* ALARQG handles input for the LAPACK test program. It is called */
/* to evaluate the input line which requested NMATS matrix types for */
/* PATH. The flow of control is as follows: */
/* If NMATS = NTYPES then */
/* DOTYPE(1:NTYPES) = .TRUE. */
/* else */
/* Read the next input line for NMATS matrix types */
/* Set DOTYPE(I) = .TRUE. for each valid type I */
/* endif */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* An LAPACK path name for testing. */
/* NMATS (input) INTEGER */
/* The number of matrix types to be used in testing this path. */
/* DOTYPE (output) LOGICAL array, dimension (NTYPES) */
/* The vector of flags indicating if each type will be tested. */
/* NTYPES (input) INTEGER */
/* The maximum number of matrix types for this path. */
/* NIN (input) INTEGER */
/* The unit number for input. NIN >= 1. */
/* NOUT (input) INTEGER */
/* The unit number for output. NOUT >= 1. */
/* ====================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--dotype;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
if (*nmats >= *ntypes) {
/* Test everything if NMATS >= NTYPES. */
i__1 = *ntypes;
for (i__ = 1; i__ <= i__1; ++i__) {
dotype[i__] = TRUE_;
/* L10: */
}
} else {
i__1 = *ntypes;
for (i__ = 1; i__ <= i__1; ++i__) {
dotype[i__] = FALSE_;
/* L20: */
}
firstt = TRUE_;
/* Read a line of matrix types if 0 < NMATS < NTYPES. */
if (*nmats > 0) {
ci__1.cierr = 0;
ci__1.ciend = 1;
ci__1.ciunit = *nin;
ci__1.cifmt = "(A80)";
i__1 = s_rsfe(&ci__1);
if (i__1 != 0) {
goto L90;
}
i__1 = do_fio(&c__1, line, (ftnlen)80);
if (i__1 != 0) {
goto L90;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L90;
}
lenp = i_len(line, (ftnlen)80);
i__ = 0;
i__1 = *nmats;
for (j = 1; j <= i__1; ++j) {
nreq[j - 1] = 0;
i1 = 0;
L30:
++i__;
if (i__ > lenp) {
if (j == *nmats && i1 > 0) {
goto L60;
} else {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, line, (ftnlen)80);
e_wsfe();
io___10.ciunit = *nout;
s_wsfe(&io___10);
do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(
integer));
e_wsfe();
goto L80;
}
}
if (*(unsigned char *)&line[i__ - 1] != ' ' && *(unsigned
char *)&line[i__ - 1] != ',') {
i1 = i__;
*(unsigned char *)c1 = *(unsigned char *)&line[i1 - 1];
/* Check that a valid integer was read */
for (k = 1; k <= 10; ++k) {
if (*(unsigned char *)c1 == *(unsigned char *)&intstr[
k - 1]) {
ic = k - 1;
goto L50;
}
/* L40: */
}
io___14.ciunit = *nout;
s_wsfe(&io___14);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
do_fio(&c__1, line, (ftnlen)80);
e_wsfe();
io___15.ciunit = *nout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&(*nmats), (ftnlen)sizeof(integer));
e_wsfe();
goto L80;
L50:
nreq[j - 1] = nreq[j - 1] * 10 + ic;
goto L30;
} else if (i1 > 0) {
goto L60;
} else {
goto L30;
}
L60:
;
}
}
i__1 = *nmats;
for (i__ = 1; i__ <= i__1; ++i__) {
nt = nreq[i__ - 1];
if (nt > 0 && nt <= *ntypes) {
if (dotype[nt]) {
if (firstt) {
io___17.ciunit = *nout;
s_wsle(&io___17);
e_wsle();
}
firstt = FALSE_;
io___18.ciunit = *nout;
s_wsfe(&io___18);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
}
dotype[nt] = TRUE_;
} else {
io___19.ciunit = *nout;
s_wsfe(&io___19);
do_fio(&c__1, path, (ftnlen)3);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*ntypes), (ftnlen)sizeof(integer));
e_wsfe();
}
/* L70: */
}
L80:
;
}
return 0;
L90:
io___20.ciunit = *nout;
s_wsfe(&io___20);
do_fio(&c__1, path, (ftnlen)3);
e_wsfe();
io___21.ciunit = *nout;
s_wsle(&io___21);
e_wsle();
s_stop("", (ftnlen)0);
/* End of ALARQG */
return 0;
} /* alarqg_ */
/* $Procedure SPCT2B ( SPK and CK, text to binary ) */
/* Subroutine */ int spct2b_(integer *unit, char *binary, ftnlen binary_len)
{
/* System generated locals */
integer i__1;
cilist ci__1;
olist o__1;
cllist cl__1;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_cmp(char *, char *, ftnlen, ftnlen), f_open(olist *), s_wsfe(
cilist *), e_wsfe(void), f_clos(cllist *);
/* Local variables */
char line[1000];
extern /* Subroutine */ int spcac_(integer *, integer *, char *, char *,
ftnlen, ftnlen), chkin_(char *, ftnlen);
extern integer ltrim_(char *, ftnlen), rtrim_(char *, ftnlen);
extern /* Subroutine */ int daft2b_(integer *, char *, integer *, ftnlen);
integer handle;
extern /* Subroutine */ int dafcls_(integer *), dafopw_(char *, integer *,
ftnlen);
integer scrtch;
extern /* Subroutine */ int errfnm_(char *, integer *, ftnlen), sigerr_(
char *, ftnlen), chkout_(char *, ftnlen), getlun_(integer *),
setmsg_(char *, ftnlen);
integer iostat;
extern /* Subroutine */ int errint_(char *, integer *, ftnlen);
extern logical return_(void);
/* $ Abstract */
/* Reconstruct a binary SPK or CK file including comments */
/* 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 */
/* SPC */
/* $ Keywords */
/* FILES */
/* $ Declarations */
/* $ Brief_I/O */
/* Variable I/O Description */
/* -------- --- -------------------------------------------------- */
/* UNIT I Logical unit connected to the text format file. */
/* BINARY I Name of a binary SPK or CK file to be created. */
/* $ Detailed_Input */
/* UNIT is the logical unit connected to an existing text */
/* format SPK or CK file that may contain comments in */
/* the appropriate SPC format, as written by SPCB2A or */
/* SPCB2T. This file must be opened for read access */
/* using the routine TXTOPR. */
/* This file may contain text that precedes and */
/* follows the SPK or CK data and comments, however, */
/* when calling this routine, the file pointer must be */
/* in a position in the file such that the next line */
/* returned by a READ statement is */
/* ''NAIF/DAF'' */
/* which marks the beginning of the data. */
/* BINARY is the name of a binary SPK or CK file to be created. */
/* The binary file contains the same data and comments */
/* as the text file, but in the binary format required */
/* for use with the SPICELIB reader subroutines. */
/* $ Detailed_Output */
/* None. */
/* $ Parameters */
/* None. */
/* $ Files */
/* 1) See arguments UNIT and BINARY above. */
/* 2) This routine uses a Fortran scratch file to temporarily */
/* store the lines of comments if there are any. */
/* $ Exceptions */
/* 1) If there is a problem opening or writing to the binary */
/* file, a routine that SPCT2B calls diagnoses and signals */
/* an error. */
/* 2) If there is a problem reading from the text file, the */
/* error SPICE(FILEREADFAILED) is signalled. */
/* 3) If there is a problem opening a scratch file, the error */
/* SPICE(FILEOPENERROR) is signalled. */
/* 4) If there is a problem writing to the scratch file, the */
/* error SPICE(FILEWRITEFAILED) is signalled. */
/* $ Particulars */
/* The SPICELIB SPK and CK reader subroutines read binary files. */
/* However, because different computing environments have different */
/* binary representations of numbers, you must convert SPK and CK */
/* files to text format when porting from one system to another. */
/* After converting the file to text, you can transfer it using */
/* a transfer protocol program like Kermit or FTP. Then, convert */
/* the text file back to binary format. */
/* The following is a list of the SPICELIB routines that convert */
/* SPK and CK files between binary and text format: */
/* SPCA2B converts text to binary. It opens the text file, */
/* creates a new binary file, and closes both files. */
/* SPCB2A converts binary to text. It opens the binary file, */
/* creates a new text file, and closes both files. */
/* SPCT2B converts text to binary. It creates a new binary */
/* file and closes it. The text file is open on */
/* entrance and exit. */
/* SPCB2T converts binary to text. It opens the binary */
/* file and closes it. The text file is open on */
/* entrance and exit */
/* See the SPC required reading for more information */
/* about SPC routines and the SPK and CK file formats. */
/* $ Examples */
/* 1) The following code fragment creates a text file containing */
/* text format SPK data and comments preceded and followed */
/* by a standard label. */
/* The SPICELIB routine TXTOPN opens a new text file and TXTOPR */
/* opens an existing text file for read access. TEXT and */
/* BINARY are character strings that contain the names of the */
/* text and binary files. */
/* CALL TXTOPN ( TEXT, UNIT ) */
/* (Write header label to UNIT) */
/* CALL SPCB2T ( BINARY, UNIT ) */
/* (Write trailing label to UNIT) */
/* CLOSE ( UNIT ) */
/* The following code fragment reconverts the text format */
/* SPK data and comments back into binary format. */
/* CALL TXTOPR ( TEXT, UNIT ) */
/* (Read, or just read past, header label from UNIT) */
/* CALL SPCT2B ( UNIT, BINARY ) */
/* (Read trailing label from UNIT, if desired ) */
/* CLOSE ( UNIT ) */
/* 2) Suppose three text format SPK files have been appended */
/* together into one text file called THREE.TSP. The following */
/* code fragment converts each set of data and comments into */
/* its own binary file. */
/* CALL TXTOPR ( 'THREE.TSP', UNIT ) */
/* CALL SPCT2B ( UNIT, 'FIRST.BSP' ) */
/* CALL SPCT2B ( UNIT, 'SECOND.BSP' ) */
/* CALL SPCT2B ( UNIT, 'THIRD.BSP' ) */
/* CLOSE ( UNIT ) */
/* $ Restrictions */
/* 1) This routine assumes that the data and comments in the */
/* text format SPK or CK file come from a binary file */
/* and were written by one of the routines SPCB2A or SPCB2T. */
/* Data and/or comments written any other way may not be */
/* in the correct format and, therefore, may not be handled */
/* properly. */
/* 2) Older versions of SPK and CK files did not have a comment */
/* area. These files, in text format, may still be converted */
/* to binary using SPCT2B. However, upon exit, the file pointer */
/* will not be in position ready to read the first line of text */
/* after the data. Instead, the next READ statement after */
/* calling SPCT2B will return the second line of text after */
/* the data. Therefore, example 1 may not work as desired */
/* if the trailing label begins on the first line after the */
/* data. To solve this problem, use DAFT2B instead of SPCT2B. */
/* 3) UNIT must be obtained via TXTOPR. Use TXTOPR to open text */
/* files for read access and get the logical unit. System */
/* dependencies regarding opening text files have been isolated */
/* in the routines TXTOPN and TXTOPR. */
/* $ Literature_References */
/* None. */
/* $ Author_and_Institution */
/* J.E. McLean (JPL) */
/* $ Version */
/* - SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */
/* Comment section for permuted index source lines was added */
/* following the header. */
/* - SPICELIB Version 1.0.0, 05-APR-1991 (JEM) */
/* -& */
/* $ Index_Entries */
/* text spk or ck to binary */
/* -& */
/* SPICELIB functions */
/* Local parameters */
/* Local variables */
/* Standard SPICE error handling. */
if (return_()) {
return 0;
} else {
chkin_("SPCT2B", (ftnlen)6);
}
/* DAFT2B creates the new binary file and writes the data to */
/* it. If the 'NAIF/DAF' keyword is not the first line that */
/* it reads from the text file, it will signal an error. */
/* Initially, no records are reserved. */
daft2b_(unit, binary, &c__0, binary_len);
/* The comments follow the data and are surrounded by markers. */
/* BMARK should be the next line that we read. If it isn't, */
/* then this is an old file, created before the comment area */
/* existed. In this case, we've read one line too far, but */
/* we can't backspace because the file was written using list- */
/* directed formatting (See the ANSI standard). All we can do */
/* is check out, leaving the file pointer where it is, but */
/* that's better than signalling an error. */
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100001;
}
iostat = do_fio(&c__1, line, (ftnlen)1000);
if (iostat != 0) {
goto L100001;
}
iostat = e_rsfe();
L100001:
if (iostat > 0) {
setmsg_("Error reading the text file named FNM. Value of IOSTAT is "
"#.", (ftnlen)61);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", unit, (ftnlen)3);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
i__1 = ltrim_(line, (ftnlen)1000) - 1;
if (s_cmp(line + i__1, "~NAIF/SPC BEGIN COMMENTS~", 1000 - i__1, (ftnlen)
25) != 0 || iostat < 0) {
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
/* We're not at the end of the file, and the line we read */
/* is BMARK, so we write the comments to a scratch file. */
/* We do this because we have to use SPCAC to add the comments */
/* to the comment area of the binary file, and SPCAC rewinds */
/* the file. It's okay for SPCAC to rewind a scratch file, */
/* but it's not okay to rewind the file connected to UNIT -- */
/* we don't know the initial location of the file pointer. */
getlun_(&scrtch);
o__1.oerr = 1;
o__1.ounit = scrtch;
o__1.ofnm = 0;
o__1.orl = 0;
o__1.osta = "SCRATCH";
o__1.oacc = "SEQUENTIAL";
o__1.ofm = "FORMATTED";
o__1.oblnk = 0;
iostat = f_open(&o__1);
if (iostat != 0) {
setmsg_("Error opening a scratch file. File name was FNM. Value of"
" IOSTAT is #.", (ftnlen)72);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEOPENERROR)", (ftnlen)20);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
ci__1.cierr = 1;
ci__1.ciunit = scrtch;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100002;
}
iostat = do_fio(&c__1, line, rtrim_(line, (ftnlen)1000));
if (iostat != 0) {
goto L100002;
}
iostat = e_wsfe();
L100002:
if (iostat != 0) {
setmsg_("Error writing to scratch file. File name is FNM. Value of "
"IOSTAT is #.", (ftnlen)71);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
/* Continue reading lines from the text file and storing them */
/* in the scratch file until we get to the end marker. */
for(;;) { /* while(complicated condition) */
i__1 = ltrim_(line, (ftnlen)1000) - 1;
if (!(s_cmp(line + i__1, "~NAIF/SPC END COMMENTS~", 1000 - i__1, (
ftnlen)23) != 0))
break;
ci__1.cierr = 1;
ci__1.ciend = 1;
ci__1.ciunit = *unit;
ci__1.cifmt = "(A)";
iostat = s_rsfe(&ci__1);
if (iostat != 0) {
goto L100003;
}
iostat = do_fio(&c__1, line, (ftnlen)1000);
if (iostat != 0) {
goto L100003;
}
iostat = e_rsfe();
L100003:
if (iostat != 0) {
setmsg_("Error reading the text file named FNM. Value of IOSTAT"
" is #.", (ftnlen)61);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", unit, (ftnlen)3);
sigerr_("SPICE(FILEREADFAILED)", (ftnlen)21);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
ci__1.cierr = 1;
ci__1.ciunit = scrtch;
ci__1.cifmt = "(A)";
iostat = s_wsfe(&ci__1);
if (iostat != 0) {
goto L100004;
}
iostat = do_fio(&c__1, line, rtrim_(line, (ftnlen)1000));
if (iostat != 0) {
goto L100004;
}
iostat = e_wsfe();
L100004:
if (iostat != 0) {
setmsg_("Error writing to scratch file. File name is FNM. Valu"
"e of IOSTAT is #.", (ftnlen)72);
errint_("#", &iostat, (ftnlen)1);
errfnm_("FNM", &scrtch, (ftnlen)3);
sigerr_("SPICE(FILEWRITEFAILED)", (ftnlen)22);
chkout_("SPCT2B", (ftnlen)6);
return 0;
}
}
/* Open the new binary file and add the comments that have been */
/* stored temporarily in a scratch file. */
dafopw_(binary, &handle, binary_len);
spcac_(&handle, &scrtch, "~NAIF/SPC BEGIN COMMENTS~", "~NAIF/SPC END COM"
"MENTS~", (ftnlen)25, (ftnlen)23);
/* Close the files. The scratch file is automatically deleted. */
dafcls_(&handle);
cl__1.cerr = 0;
cl__1.cunit = scrtch;
cl__1.csta = 0;
f_clos(&cl__1);
chkout_("SPCT2B", (ftnlen)6);
return 0;
} /* spct2b_ */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int memlst_(integer *iomls, integer *nmem, char *memnam,
ftnlen memnam_len)
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer i__, ie, is;
static char line[255];
static integer lmem, isrc, ipos, lline;
/* Fortran I/O blocks */
static cilist io___4 = { 0, 0, 1, "(A255)", 0 };
/* Parameter adjustments */
memnam -= 8;
/* Function Body */
lline = 255;
ipos = 0;
*nmem = 0;
L1000:
isrc = 0;
io___4.ciunit = *iomls;
i__1 = s_rsfe(&io___4);
if (i__1 != 0) {
goto L9999;
}
i__1 = do_fio(&c__1, line, (ftnlen)255);
if (i__1 != 0) {
goto L9999;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L9999;
}
i__1 = lline;
for (i__ = 1; i__ <= i__1; ++i__) {
/* -- FIND NEW MEMBER NOW */
if (isrc == 0 && *(unsigned char *)&line[i__ - 1] != ' ') {
lmem = 1;
isrc = 1;
/* -- ALREADY FOUND */
} else if (isrc != 0 && *(unsigned char *)&line[i__ - 1] != ' ') {
++lmem;
}
/* -- END OF MEMBER */
if (isrc != 0 && *(unsigned char *)&line[i__ - 1] == ' ') {
++(*nmem);
is = i__ - lmem;
ie = i__ - 1;
s_copy(memnam + (*nmem << 3), line + (is - 1), (ftnlen)8, ie - (
is - 1));
isrc = 0;
}
/* L100: */
}
goto L1000;
L9999:
return 0;
} /* memlst_ */