本文整理汇总了C++中s_wsfe函数的典型用法代码示例。如果您正苦于以下问题：C++ s_wsfe函数的具体用法？C++ s_wsfe怎么用？C++ s_wsfe使用的例子？那么恭喜您, 这里精选的函数代码示例或许可以为您提供帮助。
在下文中一共展示了s_wsfe函数的15个代码示例，这些例子默认根据受欢迎程度排序。您可以为喜欢或者感觉有用的代码点赞，您的评价将有助于系统推荐出更棒的C++代码示例。
示例1: s_wsfe
/* Subroutine */ int itest1_(integer *icomp, integer *itrue)
{
/* Format strings */
static char fmt_99999[] = "(\002 F"
"AIL\002)";
static char fmt_99998[] = "(/\002 CASE N INCX INCY MODE "
" \002,\002 COMP TRU"
"E DIFFERENCE\002,/1x)";
static char fmt_99997[] = "(1x,i4,i3,3i5,2i36,i12)";
/* Builtin functions */
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
integer id;
/* Fortran I/O blocks */
static cilist io___110 = { 0, 6, 0, fmt_99999, 0 };
static cilist io___111 = { 0, 6, 0, fmt_99998, 0 };
static cilist io___113 = { 0, 6, 0, fmt_99997, 0 };
/* ********************************* ITEST1 ************************* */
/* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR */
/* EQUALITY. */
/* C. L. LAWSON, JPL, 1974 DEC 10 */
/* .. Parameters .. */
/* .. Scalar Arguments .. */
/* .. Scalars in Common .. */
/* .. Local Scalars .. */
/* .. Common blocks .. */
/* .. Executable Statements .. */
if (*icomp == *itrue) {
goto L40;
}
/* HERE ICOMP IS NOT EQUAL TO ITRUE. */
if (! combla_1.pass) {
goto L20;
}
/* PRINT FAIL MESSAGE AND HEADER. */
combla_1.pass = FALSE_;
s_wsfe(&io___110);
e_wsfe();
s_wsfe(&io___111);
e_wsfe();
L20:
id = *icomp - *itrue;
s_wsfe(&io___113);
do_fio(&c__1, (char *)&combla_1.icase, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.incx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.incy, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&combla_1.mode, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*icomp), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*itrue), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&id, (ftnlen)sizeof(integer));
e_wsfe();
L40:
return 0;
} /* itest1_ */示例2: test
/* Subroutine */ int zdrvpp_(logical *dotype, integer *nn, integer *nval,
integer *nrhs, doublereal *thresh, logical *tsterr, integer *nmax,
doublecomplex *a, doublecomplex *afac, doublecomplex *asav,
doublecomplex *b, doublecomplex *bsav, doublecomplex *x,
doublecomplex *xact, doublereal *s, doublecomplex *work, doublereal *
rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
static char facts[1*3] = "F" "N" "E";
static char packs[1*2] = "C" "R";
static char equeds[1*2] = "N" "Y";
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002, UPLO='\002,a1,\002', N =\002,i5"
",\002, type \002,i1,\002, test(\002,i1,\002)=\002,g12.5)";
static char fmt_9997[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, EQUED='\002,a1,\002', type \002,i1,\002"
", test(\002,i1,\002)=\002,g12.5)";
static char fmt_9998[] = "(1x,a6,\002, FACT='\002,a1,\002', UPLO='\002,a"
"1,\002', N=\002,i5,\002, type \002,i1,\002, test(\002,i1,\002)"
"=\002,g12.5)";
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3, i__4, i__5[2];
char ch__1[2];
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, k, n, k1, in, kl, ku, nt, lda, npp;
char fact[1];
integer ioff, mode;
doublereal amax;
char path[3];
integer imat, info;
char dist[1], uplo[1], type__[1];
integer nrun, ifact, nfail, iseed[4], nfact;
extern doublereal dget06_(doublereal *, doublereal *);
extern logical lsame_(char *, char *);
char equed[1];
doublereal roldc, rcond, scond;
integer nimat;
doublereal anorm;
extern /* Subroutine */ int zget04_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *
);
logical equil;
integer iuplo, izero, nerrs;
extern /* Subroutine */ int zppt01_(char *, integer *, doublecomplex *,
doublecomplex *, doublereal *, doublereal *), zppt02_(
char *, integer *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *);
logical zerot;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zppt05_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublereal *, doublereal *,
doublereal *);
char xtype[1];
extern /* Subroutine */ int zppsv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *),
zlatb4_(char *, integer *, integer *, integer *, char *, integer *
, integer *, doublereal *, integer *, doublereal *, char *), aladhd_(integer *, char *),
alaerh_(char *, char *, integer *, integer *, char *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *);
logical prefac;
doublereal rcondc;
logical nofact;
char packit[1];
integer iequed;
extern /* Subroutine */ int alasvm_(char *, integer *, integer *, integer
*, integer *);
doublereal cndnum;
extern /* Subroutine */ int zlaipd_(integer *, doublecomplex *, integer *,
integer *);
doublereal ainvnm;
extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
doublereal *);
extern /* Subroutine */ int zlaqhp_(char *, integer *, doublecomplex *,
doublereal *, doublereal *, doublereal *, char *),
zlacpy_(char *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zlarhs_(char *, char *,
char *, char *, integer *, integer *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, integer *, integer *), zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublecomplex *, integer *, doublecomplex *,
integer *);
doublereal result[6];
extern /* Subroutine */ int zppequ_(char *, integer *, doublecomplex *,
doublereal *, doublereal *, doublereal *, integer *),
//.........这里部分代码省略.........
示例3: s_wsfe
/* Subroutine */ int dchkqr_(logical *dotype, integer *nm, integer *mval,
integer *nn, integer *nval, integer *nnb, integer *nbval, integer *
nxval, integer *nrhs, doublereal *thresh, logical *tsterr, integer *
nmax, doublereal *a, doublereal *af, doublereal *aq, doublereal *ar,
doublereal *ac, doublereal *b, doublereal *x, doublereal *xact,
doublereal *tau, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
/* Format strings */
static char fmt_9999[] = "(\002 M=\002,i5,\002, N=\002,i5,\002, K=\002,i"
"5,\002, NB=\002,i4,\002, NX=\002,i5,\002, type \002,i2,\002, tes"
"t(\002,i2,\002)=\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, m, n, nb, ik, im, in, kl, nk, ku, nt, nx, lda, inb, mode,
imat, info;
char path[3];
integer kval[4];
char dist[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), dget02_(
char *, integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
doublereal *);
integer nfail, iseed[4];
extern /* Subroutine */ int dqrt01_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *);
doublereal anorm;
extern /* Subroutine */ int dqrt02_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *
);
integer minmn;
extern /* Subroutine */ int dqrt03_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *
);
integer nerrs, lwork;
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
extern logical dgennd_(integer *, integer *, doublereal *, integer *);
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
doublereal cndnum;
extern /* Subroutine */ int dgeqrs_(integer *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *), dlatms_(integer *, integer *,
char *, integer *, char *, doublereal *, integer *, doublereal *,
doublereal *, integer *, integer *, char *, doublereal *,
integer *, doublereal *, integer *),
xlaenv_(integer *, integer *), derrqr_(char *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKQR tests DGEQRF, DORGQR and DORMQR. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
//.........这里部分代码省略.........
示例4: s_rsfe
/* 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();
//.........这里部分代码省略.........
示例5: i_len
/* Subroutine */ int pdvout_(integer *comm, integer *lout, integer *n,
doublereal *sx, integer *idigit, char *ifmt, ftnlen ifmt_len)
{
/* Format strings */
static char fmt_9999[] = "(/1x,a,/1x,a)";
static char fmt_9998[] = "(1x,i4,\002 - \002,i4,\002:\002,1p,10d12.3)";
static char fmt_9997[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,8d14.5)";
static char fmt_9996[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,6d18.9)";
static char fmt_9995[] = "(1x,i4,\002 - \002,i4,\002:\002,1x,1p,5d24.13)";
static char fmt_9994[] = "(1x,\002 \002)";
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer i_len(char *, ftnlen), s_wsfe(cilist *), do_fio(integer *, char *,
ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, k1, k2, lll;
static char line[80];
static integer ierr, myid;
extern /* Subroutine */ int mpi_comm_rank__(integer *, integer *, integer
*);
static integer ndigit;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___12 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___13 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___14 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___15 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9994, 0 };
/* ... */
/* .. MPI VARIABLES AND FUNCTIONS .. */
/* .. Variable Declaration .. */
/* /+ */
/* * */
/* * (C) 1993 by Argonne National Laboratory and Mississipi State University. */
/* * All rights reserved. See COPYRIGHT in top-level directory. */
/* +/ */
/* /+ user include file for MPI programs, with no dependencies +/ */
/* /+ return codes +/ */
/* We handle datatypes by putting the variables that hold them into */
/* common. This way, a Fortran program can directly use the various */
/* datatypes and can even give them to C programs. */
/* MPI_BOTTOM needs to be a known address; here we put it at the */
/* beginning of the common block. The point-to-point and collective */
/* routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not. */
/* The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL. */
/* Their values are zero if they are not available. Note that */
/* using these reduces the portability of code (though may enhance */
/* portability between Crays and other systems) */
/* All other MPI routines are subroutines */
/* The attribute copy/delete functions are symbols that can be passed */
/* to MPI routines */
/* ... SPECIFICATIONS FOR ARGUMENTS */
/* ... */
/* ... SPECIFICATIONS FOR LOCAL VARIABLES */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* ... */
/* ... FIRST EXECUTABLE STATEMENT */
/* Determine processor configuration */
/* Parameter adjustments */
--sx;
/* Function Body */
//.........这里部分代码省略.........
示例6: s_copy
//.........这里部分代码省略.........
}
} else {
d__1 = 1. / eps;
dlatms_(&m, &n, "Uniform", iseed, "Nonsymm", ©s[1], &
mode, &d__1, &c_b16, &m, &n, "No packing", ©a[
1], &lda, &work[1], &info);
if (imode >= 4) {
if (imode == 4) {
ilow = 1;
istep = 1;
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ihigh = max(i__3,i__4);
} else if (imode == 5) {
/* Computing MAX */
i__3 = 1, i__4 = n / 2;
ilow = max(i__3,i__4);
istep = 1;
ihigh = n;
} else if (imode == 6) {
ilow = 1;
istep = 2;
ihigh = n;
}
i__3 = ihigh;
i__4 = istep;
for (i__ = ilow; i__4 < 0 ? i__ >= i__3 : i__ <= i__3;
i__ += i__4) {
iwork[i__] = 1;
/* L40: */
}
}
dlaord_("Decreasing", &mnmin, ©s[1], &c__1);
}
/* Save A and its singular values */
dlacpy_("All", &m, &n, ©a[1], &lda, &a[1], &lda);
/* Compute the QR factorization with pivoting of A */
s_copy(srnamc_1.srnamt, "DGEQPF", (ftnlen)32, (ftnlen)6);
dgeqpf_(&m, &n, &a[1], &lda, &iwork[1], &tau[1], &work[1], &
info);
/* Compute norm(svd(a) - svd(r)) */
result[0] = dqrt12_(&m, &n, &a[1], &lda, ©s[1], &work[1],
&lwork);
/* Compute norm( A*P - Q*R ) */
result[1] = dqpt01_(&m, &n, &mnmin, ©a[1], &a[1], &lda, &
tau[1], &iwork[1], &work[1], &lwork);
/* Compute Q'*Q */
result[2] = dqrt11_(&m, &mnmin, &a[1], &lda, &tau[1], &work[1]
, &lwork);
/* Print information about the tests that did not pass */
/* the threshold. */
for (k = 1; k <= 3; ++k) {
if (result[k - 1] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imode, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[k - 1], (ftnlen)sizeof(
doublereal));
e_wsfe();
++nfail;
}
/* L50: */
}
nrun += 3;
L60:
;
}
/* L70: */
}
/* L80: */
}
/* Print a summary of the results. */
alasum_(path, nout, &nfail, &nrun, &nerrs);
/* End of DCHKQP */
return 0;
} /* dchkqp_ */示例7: test
//.........这里部分代码省略.........
if (info != 0) {
/* Writing concatenation */
i__2[0] = 1, a__1[0] = uplo;
i__2[1] = 1, a__1[1] = diag;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
alaerh_(path, "STPTRI", &info, &c__0, ch__1, &n, &n, &
c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, nout);
}
/* Compute the infinity-norm condition number of A. */
anorm = slantp_("I", uplo, diag, &n, &ap[1], &rwork[1]);
ainvnm = slantp_("I", uplo, diag, &n, &ainvp[1], &rwork[1]);
if (anorm <= 0.f || ainvnm <= 0.f) {
rcondi = 1.f;
} else {
rcondi = 1.f / anorm / ainvnm;
}
/* Compute the residual for the triangular matrix times its */
/* inverse. Also compute the 1-norm condition number of A. */
stpt01_(uplo, diag, &n, &ap[1], &ainvp[1], &rcondo, &rwork[1],
result);
/* Print the test ratio if it is .GE. THRESH. */
if (result[0] >= *thresh) {
if (nfail == 0 && nerrs == 0) {
alahd_(nout, path);
}
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, uplo, (ftnlen)1);
do_fio(&c__1, diag, (ftnlen)1);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c__1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[0], (ftnlen)sizeof(real));
e_wsfe();
++nfail;
}
++nrun;
i__3 = *nns;
for (irhs = 1; irhs <= i__3; ++irhs) {
nrhs = nsval[irhs];
*(unsigned char *)xtype = 'N';
for (itran = 1; itran <= 3; ++itran) {
/* Do for op(A) = A, A**T, or A**H. */
*(unsigned char *)trans = *(unsigned char *)&transs[
itran - 1];
if (itran == 1) {
*(unsigned char *)norm = 'O';
rcondc = rcondo;
} else {
*(unsigned char *)norm = 'I';
rcondc = rcondi;
}
/* + TEST 2 */
/* Solve and compute residual for op(A)*x = b. */示例8: s_wsle
/* Subroutine */ int derrac_(integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 drivers passed the tests of the er"
"ror exits\002)";
static char fmt_9998[] = "(\002 *** \002,a6,\002 drivers failed the test"
"s of the error \002,\002exits ***\002)";
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
doublereal a[16] /* was [4][4] */, b[4], c__[4];
integer i__, j;
doublereal r__[4], w[8], x[4], r1[4], r2[4], af[16] /* was [4][4] */;
integer info, iter;
doublereal work[16];
real swork[16];
extern /* Subroutine */ int chkxer_(char *, integer *, integer *, logical
*, logical *), dsposv_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, real *, integer *, integer *);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___18 = { 0, 0, 0, fmt_9998, 0 };
/* -- LAPACK test routine (version 3.1.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* May 2007 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DERRAC tests the error exits for DSPOSV. */
/* Arguments */
/* ========= */
/* NUNIT (input) INTEGER */
/* The unit number for output. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Scalars in Common .. */
/* .. */
/* .. Common blocks .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
/* Set the variables to innocuous values. */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
af[i__ + (j << 2) - 5] = 1. / (doublereal) (i__ + j);
/* L10: */
}
b[j - 1] = 0.;
r1[j - 1] = 0.;
r2[j - 1] = 0.;
w[j - 1] = 0.;
x[j - 1] = 0.;
c__[j - 1] = 0.;
r__[j - 1] = 0.;
/* L20: */
}
infoc_1.ok = TRUE_;
s_copy(srnamc_1.srnamt, "DSPOSV", (ftnlen)32, (ftnlen)6);
infoc_1.infot = 1;
dsposv_("/", &c__0, &c__0, a, &c__1, b, &c__1, x, &c__1, work, swork, &
iter, &info);
chkxer_("DSPOSV", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dsposv_("U", &c_n1, &c__0, a, &c__1, b, &c__1, x, &c__1, work, swork, &
//.........这里部分代码省略.........
示例9: i_dceiling
/* Subroutine */ int dchkps_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nrank, integer *rankval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *perm, integer *piv, doublereal *work,
doublereal *rwork, integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"RANK =\002,i3,\002, Diff =\002,i5,\002, NB =\002,i4,\002, type"
" \002,i2,\002, Ratio =\002,g12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_dceiling(doublereal *), s_wsfe(cilist *), do_fio(integer *,
char *, ftnlen), e_wsfe(void);
/* Local variables */
integer rankdiff, comprank, i__, n, nb, in, kl, ku, lda, inb;
doublereal tol;
integer mode, imat, info, rank;
char path[3], dist[1], uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *);
integer nfail, iseed[4], irank, nimat;
extern /* Subroutine */ int dpst01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *, doublereal *, doublereal *, integer *);
doublereal anorm;
integer iuplo, izero, nerrs;
extern /* Subroutine */ int dlatb5_(char *, integer *, integer *, char *,
integer *, integer *, doublereal *, integer *, doublereal *, char
*), alaerh_(char *, char *, integer *,
integer *, char *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *), dlacpy_(char *, integer *, integer *, doublereal
*, integer *, doublereal *, integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatmt_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, integer *, char *, doublereal *, integer *,
doublereal *, integer *), xlaenv_(integer
*, integer *), derrps_(char *, integer *), dpstrf_(char *,
integer *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *);
doublereal result;
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DCHKPS tests DPSTRF. */
/* Arguments */
/* ========= */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* The matrix types to be used for testing. Matrices of type j */
/* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = */
/* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. */
/* NN (input) INTEGER */
/* The number of values of N contained in the vector NVAL. */
/* NVAL (input) INTEGER array, dimension (NN) */
/* The values of the matrix dimension N. */
/* NNB (input) INTEGER */
/* The number of values of NB contained in the vector NBVAL. */
/* NBVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the block size NB. */
/* NRANK (input) INTEGER */
/* The number of values of RANK contained in the vector RANKVAL. */
/* RANKVAL (input) INTEGER array, dimension (NBVAL) */
/* The values of the block size NB. */
//.........这里部分代码省略.........
示例10: dlamch_
//.........这里部分代码省略.........
}
e_rsle();
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___14.ciunit = *nin;
s_rsle(&io___14);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&e[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L20: */
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
io___17.ciunit = *nin;
s_rsle(&io___17);
i__2 = n;
for (j = 1; j <= i__2; ++j) {
do_lio(&c__7, &c__1, (char *)&ein[i__ + j * 20 - 21], (ftnlen)
sizeof(doublecomplex));
}
e_rsle();
/* L30: */
}
++knt;
zgebak_("B", "R", &n, &ilo, &ihi, scale, &n, e, &c__20, &info);
if (info != 0) {
++ninfo;
lmax[0] = knt;
}
vmax = 0.;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = n;
for (j = 1; j <= i__2; ++j) {
i__3 = i__ + j * 20 - 21;
i__4 = i__ + j * 20 - 21;
z__2.r = e[i__3].r - ein[i__4].r, z__2.i = e[i__3].i - ein[i__4]
.i;
z__1.r = z__2.r, z__1.i = z__2.i;
x = ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)
)) / eps;
i__3 = i__ + j * 20 - 21;
if ((d__1 = e[i__3].r, abs(d__1)) + (d__2 = d_imag(&e[i__ + j *
20 - 21]), abs(d__2)) > safmin) {
i__4 = i__ + j * 20 - 21;
x /= (d__3 = e[i__4].r, abs(d__3)) + (d__4 = d_imag(&e[i__ +
j * 20 - 21]), abs(d__4));
}
vmax = max(vmax,x);
/* L40: */
}
/* L50: */
}
if (vmax > rmax) {
lmax[1] = knt;
rmax = vmax;
}
goto L10;
L60:
io___22.ciunit = *nout;
s_wsfe(&io___22);
e_wsfe();
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&rmax, (ftnlen)sizeof(doublereal));
e_wsfe();
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&lmax[0], (ftnlen)sizeof(integer));
e_wsfe();
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&lmax[1], (ftnlen)sizeof(integer));
e_wsfe();
io___26.ciunit = *nout;
s_wsfe(&io___26);
do_fio(&c__1, (char *)&ninfo, (ftnlen)sizeof(integer));
e_wsfe();
io___27.ciunit = *nout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&knt, (ftnlen)sizeof(integer));
e_wsfe();
return 0;
/* End of ZCHKBK */
} /* zchkbk_ */示例11: sqrt
/* Subroutine */ int zchkhs_(integer *nsizes, integer *nn, integer *ntypes,
logical *dotype, integer *iseed, doublereal *thresh, integer *nounit,
doublecomplex *a, integer *lda, doublecomplex *h__, doublecomplex *t1,
doublecomplex *t2, doublecomplex *u, integer *ldu, doublecomplex *
z__, doublecomplex *uz, doublecomplex *w1, doublecomplex *w3,
doublecomplex *evectl, doublecomplex *evectr, doublecomplex *evecty,
doublecomplex *evectx, doublecomplex *uu, doublecomplex *tau,
doublecomplex *work, integer *nwork, doublereal *rwork, integer *
iwork, logical *select, doublereal *result, integer *info)
{
/* Initialized data */
static integer ktype[21] = { 1,2,3,4,4,4,4,4,6,6,6,6,6,6,6,6,6,6,9,9,9 };
static integer kmagn[21] = { 1,1,1,1,1,1,2,3,1,1,1,1,1,1,1,1,2,3,1,2,3 };
static integer kmode[21] = { 0,0,0,4,3,1,4,4,4,3,1,5,4,3,1,5,5,5,4,3,1 };
static integer kconds[21] = { 0,0,0,0,0,0,0,0,1,1,1,1,2,2,2,2,2,2,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 ZCHKHS: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(\002 ZCHKHS: \002,a,\002 Eigenvectors from"
" \002,a,\002 incorrectly \002,\002normalized.\002,/\002 Bits of "
"error=\002,0p,g10.3,\002,\002,9x,\002N=\002,i6,\002, JTYPE=\002,"
"i6,\002, ISEED=(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9997[] = "(\002 ZCHKHS: Selected \002,a,\002 Eigenvector"
"s from \002,a,\002 do not match other eigenvectors \002,9x,\002N="
"\002,i6,\002, JTYPE=\002,i6,\002, ISEED=(\002,3(i5,\002,\002),i5,"
"\002)\002)";
/* System generated locals */
integer a_dim1, a_offset, evectl_dim1, evectl_offset, evectr_dim1,
evectr_offset, evectx_dim1, evectx_offset, evecty_dim1,
evecty_offset, h_dim1, h_offset, t1_dim1, t1_offset, t2_dim1,
t2_offset, u_dim1, u_offset, uu_dim1, uu_offset, uz_dim1,
uz_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
double z_abs(doublecomplex *);
/* Local variables */
integer i__, j, k, n, n1, jj, in, ihi, ilo;
doublereal ulp, cond;
integer jcol, nmax;
doublereal unfl, ovfl, temp1, temp2;
logical badnn, match;
integer imode;
doublereal dumma[4];
integer iinfo;
doublereal conds;
extern /* Subroutine */ int zget10_(integer *, integer *, doublecomplex *,
integer *, doublecomplex *, integer *, doublecomplex *,
doublereal *, doublereal *);
doublereal aninv, anorm;
extern /* Subroutine */ int zget22_(char *, char *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, doublereal *, doublereal *), zgemm_(char *, char *, integer *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *);
integer nmats, jsize, nerrs, itype, jtype, ntest;
extern /* Subroutine */ int zhst01_(integer *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *,
doublereal *, doublereal *), zcopy_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
doublereal rtulp;
extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
extern doublereal dlamch_(char *);
doublecomplex cdumma[4];
integer idumma[1];
extern /* Subroutine */ int dlafts_(char *, integer *, integer *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), zgehrd_(
integer *, integer *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *), dlasum_(
char *, integer *, integer *, integer *), zlatme_(integer
*, char *, integer *, doublecomplex *, integer *, doublereal *,
doublecomplex *, char *, char *, char *, char *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
doublecomplex *, integer *, doublecomplex *, integer *), zhsein_(char *, char *, char *,
logical *, integer *, doublecomplex *, integer *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *
, integer *, doublecomplex *, doublereal *, integer *, integer *,
integer *), zlacpy_(char *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *), zlaset_(char *, integer *, integer *, doublecomplex *,
doublecomplex *, doublecomplex *, integer *), zlatmr_(
integer *, integer *, char *, integer *, char *, doublecomplex *,
integer *, doublereal *, doublecomplex *, char *, char *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, char *, doublecomplex *, integer *,
integer *, integer *);
doublereal rtunfl, rtovfl, rtulpi, ulpinv;
//.........这里部分代码省略.........
示例12: test
/* Subroutine */ int dchkpo_(logical *dotype, integer *nn, integer *nval,
integer *nnb, integer *nbval, integer *nns, integer *nsval,
doublereal *thresh, logical *tsterr, integer *nmax, doublereal *a,
doublereal *afac, doublereal *ainv, doublereal *b, doublereal *x,
doublereal *xact, doublereal *work, doublereal *rwork, integer *iwork,
integer *nout)
{
/* Initialized data */
static integer iseedy[4] = { 1988,1989,1990,1991 };
static char uplos[1*2] = "U" "L";
/* Format strings */
static char fmt_9999[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NB =\002,i4,\002, type \002,i2,\002, test \002,i2,\002, ratio "
"=\002,g12.5)";
static char fmt_9998[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002, "
"NRHS=\002,i3,\002, type \002,i2,\002, test(\002,i2,\002) =\002,g"
"12.5)";
static char fmt_9997[] = "(\002 UPLO = '\002,a1,\002', N =\002,i5,\002"
",\002,10x,\002 type \002,i2,\002, test(\002,i2,\002) =\002,g12.5)"
;
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, k, n, nb, in, kl, ku, lda, inb, ioff, mode, imat, info;
char path[3], dist[1];
integer irhs, nrhs;
char uplo[1], type__[1];
integer nrun;
extern /* Subroutine */ int alahd_(integer *, char *), dget04_(
integer *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *);
integer nfail, iseed[4];
extern doublereal dget06_(doublereal *, doublereal *);
doublereal rcond;
extern /* Subroutine */ int dpot01_(char *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, doublereal *);
integer nimat;
extern /* Subroutine */ int dpot02_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *), dpot03_(char *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *), dpot05_(char *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *);
doublereal anorm;
integer iuplo, izero, nerrs;
logical zerot;
char xtype[1];
extern /* Subroutine */ int dlatb4_(char *, integer *, integer *, integer
*, char *, integer *, integer *, doublereal *, integer *,
doublereal *, char *), alaerh_(char *,
char *, integer *, integer *, char *, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *);
doublereal rcondc;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
dlarhs_(char *, char *, char *, char *, integer *, integer *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *), alasum_(char *,
integer *, integer *, integer *, integer *);
doublereal cndnum;
extern /* Subroutine */ int dlatms_(integer *, integer *, char *, integer
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, char *, doublereal *, integer *, doublereal
*, integer *), dpocon_(char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int derrpo_(char *, integer *), dporfs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, integer *), dpotrf_(char *, integer *, doublereal *, integer *,
integer *), xlaenv_(integer *, integer *), dpotri_(char *,
integer *, doublereal *, integer *, integer *), dpotrs_(
char *, integer *, integer *, doublereal *, integer *, doublereal
*, integer *, integer *);
doublereal result[8];
/* Fortran I/O blocks */
static cilist io___33 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___36 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___38 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
//.........这里部分代码省略.........
示例13: s_wsfe
/* Subroutine */ int alasvm_(char *type__, integer *nout, integer *nfail,
integer *nrun, integer *nerrs)
{
/* Format strings */
static char fmt_9999[] = "(1x,a3,\002 drivers: \002,i6,\002 out of \002,"
"i6,\002 tests failed to pass the threshold\002)";
static char fmt_9998[] = "(/1x,\002All tests for \002,a3,\002 drivers p"
"assed the \002,\002threshold (\002,i6,\002 tests run)\002)";
static char fmt_9997[] = "(14x,i6,\002 error messages recorded\002)";
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___2 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___3 = { 0, 0, 0, fmt_9997, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ALASVM prints a summary of results from one of the -DRV- routines. */
/* Arguments */
/* ========= */
/* TYPE (input) CHARACTER*3 */
/* The LAPACK path name. */
/* NOUT (input) INTEGER */
/* The unit number on which results are to be printed. */
/* NOUT >= 0. */
/* NFAIL (input) INTEGER */
/* The number of tests which did not pass the threshold ratio. */
/* NRUN (input) INTEGER */
/* The total number of tests. */
/* NERRS (input) INTEGER */
/* The number of error messages recorded. */
/* ===================================================================== */
/* .. Executable Statements .. */
if (*nfail > 0) {
io___1.ciunit = *nout;
s_wsfe(&io___1);
do_fio(&c__1, type__, (ftnlen)3);
do_fio(&c__1, (char *)&(*nfail), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___2.ciunit = *nout;
s_wsfe(&io___2);
do_fio(&c__1, type__, (ftnlen)3);
do_fio(&c__1, (char *)&(*nrun), (ftnlen)sizeof(integer));
e_wsfe();
}
if (*nerrs > 0) {
io___3.ciunit = *nout;
s_wsfe(&io___3);
do_fio(&c__1, (char *)&(*nerrs), (ftnlen)sizeof(integer));
e_wsfe();
}
return 0;
/* End of ALASVM */
} /* alasvm_ */示例14: i_indx
/* Subroutine */ int hcore_(doublereal *coord, doublereal *h__, doublereal *w,
doublereal *wj, doublereal *wk, doublereal *enuclr)
{
/* Initialized data */
static integer icalcn = 0;
/* Format strings */
static char fmt_120[] = "(10f8.4)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
/* Builtin functions */
integer i_indx(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer i__, j, i1, i2, j1, j2, ia, ib, ic;
static doublereal di[81] /* was [9][9] */;
static integer ja, jb, jc, ii, jj, ni, nj, kr;
static doublereal xf, yf, zf, e1b[10], e2a[10];
static integer im1, io1, jo1;
static doublereal wjd[100], wkd[100];
static integer kro;
static doublereal half;
static integer ione;
static doublereal fnuc, enuc;
extern doublereal reada_(char *, integer *, ftnlen);
static logical debug, fldon, first;
extern /* Subroutine */ int h1elec_(integer *, integer *, doublereal *,
doublereal *, doublereal *), addhcr_(doublereal *), addnuc_(
doublereal *);
static doublereal fldcon, hterme, cutoff;
extern /* Subroutine */ int rotate_(integer *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *), vecprt_(doublereal *, integer *);
static char tmpkey[241];
extern /* Subroutine */ int solrot_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *);
/* Fortran I/O blocks */
static cilist io___11 = { 0, 6, 0, "(/10X,'THE ELECTRIC FIELD IS',3F10.5)"
, 0 };
static cilist io___12 = { 0, 6, 0, "(10X,'IN 8*A.U. (8*27.21/0.529 VOLTS"
"/ANGSTROM)',/)", 0 };
static cilist io___44 = { 0, 6, 0, "(//10X,'ONE-ELECTRON MATRIX FROM HCO"
"RE')", 0 };
static cilist io___45 = { 0, 6, 0, "(//10X,'TWO-ELECTRON MATRIX IN HCORE"
"'/)", 0 };
static cilist io___46 = { 0, 6, 0, fmt_120, 0 };
static cilist io___47 = { 0, 6, 0, "(//10X,'TWO-ELECTRON J MATRIX IN HCO"
"RE'/)", 0 };
static cilist io___48 = { 0, 6, 0, fmt_120, 0 };
static cilist io___49 = { 0, 6, 0, "(//10X,'TWO-ELECTRON K MATRIX IN HCO"
"RE'/)", 0 };
static cilist io___50 = { 0, 6, 0, fmt_120, 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 */
/* COSMO change */
/* end of COSMO change */
/* *********************************************************************** */
/* HCORE GENERATES THE ONE-ELECTRON MATRIX AND TWO ELECTRON INTEGRALS */
//.........这里部分代码省略.........
示例15: sqrt
/* Subroutine */ int newuob_(integer *n, integer *npt, doublereal *x,
doublereal *rhobeg, doublereal *rhoend, integer *iprint, integer *
maxfun, doublereal *xbase, doublereal *xopt, doublereal *xnew,
doublereal *xpt, doublereal *fval, doublereal *gq, doublereal *hq,
doublereal *pq, doublereal *bmat, doublereal *zmat, integer *ndim,
doublereal *d__, doublereal *vlag, doublereal *w, S_fp calfun)
{
/* Format strings */
static char fmt_320[] = "(/4x,\002Return from NEWUOA because CALFUN has "
"been\002,\002 called MAXFUN times.\002)";
static char fmt_330[] = "(/4x,\002Function number\002,i6,\002 F =\002"
",1pd18.10,\002 The corresponding X is:\002/(2x,5d15.6))";
static char fmt_370[] = "(/4x,\002Return from NEWUOA because a trus"
"t\002,\002 region step has failed to reduce Q.\002)";
static char fmt_500[] = "(5x)";
static char fmt_510[] = "(/4x,\002New RHO =\002,1pd11.4,5x,\002Number o"
"f\002,\002 function values =\002,i6)";
static char fmt_520[] = "(4x,\002Least value of F =\002,1pd23.15,9x,\002"
"The corresponding X is:\002/(2x,5d15.6))";
static char fmt_550[] = "(/4x,\002At the return from NEWUOA\002,5x,\002N"
"umber of function values =\002,i6)";
/* System generated locals */
integer xpt_dim1, xpt_offset, bmat_dim1, bmat_offset, zmat_dim1,
zmat_offset, i__1, i__2, i__3;
doublereal d__1, d__2, d__3;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Local variables */
static doublereal f;
static integer i__, j, k, ih, nf, nh, ip, jp;
static doublereal dx;
static integer np, nfm;
static doublereal one;
static integer idz;
static doublereal dsq, rho;
static integer ipt, jpt;
static doublereal sum, fbeg, diff, half, beta;
static integer nfmm;
static doublereal gisq;
static integer knew;
static doublereal temp, suma, sumb, fopt, bsum, gqsq;
static integer kopt, nptm;
static doublereal zero, xipt, xjpt, sumz, diffa, diffb, diffc, hdiag,
alpha, delta, recip, reciq, fsave;
static integer ksave, nfsav, itemp;
static doublereal dnorm, ratio, dstep, tenth, vquad;
static integer ktemp;
static doublereal tempq;
static integer itest;
static doublereal rhosq;
extern /* Subroutine */ int biglag_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), bigden_(
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *), update_(integer *,
integer *, doublereal *, doublereal *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *);
static doublereal detrat, crvmin;
static integer nftest;
static doublereal distsq;
extern /* Subroutine */ int trsapp_(integer *, integer *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *);
static doublereal xoptsq;
/* Fortran I/O blocks */
static cilist io___55 = { 0, 6, 0, fmt_320, 0 };
static cilist io___56 = { 0, 6, 0, fmt_330, 0 };
static cilist io___61 = { 0, 6, 0, fmt_370, 0 };
static cilist io___68 = { 0, 6, 0, fmt_500, 0 };
static cilist io___69 = { 0, 6, 0, fmt_510, 0 };
static cilist io___70 = { 0, 6, 0, fmt_520, 0 };
static cilist io___71 = { 0, 6, 0, fmt_550, 0 };
static cilist io___72 = { 0, 6, 0, fmt_520, 0 };
/* The arguments N, NPT, X, RHOBEG, RHOEND, IPRINT and MAXFUN are identical */
/* to the corresponding arguments in SUBROUTINE NEWUOA. */
/* XBASE will hold a shift of origin that should reduce the contributions */
/* from rounding errors to values of the model and Lagrange functions. */
/* XOPT will be set to the displacement from XBASE of the vector of */
/* variables that provides the least calculated F so far. */
/* XNEW will be set to the displacement from XBASE of the vector of */
/* variables for the current calculation of F. */
/* XPT will contain the interpolation point coordinates relative to XBASE. */
/* FVAL will hold the values of F at the interpolation points. */
/* GQ will hold the gradient of the quadratic model at XBASE. */
/* HQ will hold the explicit second derivatives of the quadratic model. */
/* PQ will contain the parameters of the implicit second derivatives of */
/* the quadratic model. */
/* BMAT will hold the last N columns of H. */
//.........这里部分代码省略.........