当前位置: 首页>>代码示例>>C++>>正文


C++ s_wsfe函数代码示例

本文整理汇总了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_ */
开发者ID:kstraube,项目名称:hysim,代码行数:66,代码来源:sblat1.c

示例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 *),
//.........这里部分代码省略.........
开发者ID:kstraube,项目名称:hysim,代码行数:101,代码来源:zdrvpp.c

示例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. */
//.........这里部分代码省略.........
开发者ID:3deggi,项目名称:levmar-ndk,代码行数:101,代码来源:dchkqr.c

示例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();
//.........这里部分代码省略.........
开发者ID:daju1,项目名称:winlibghemical,代码行数:101,代码来源:gettxt.c

示例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 */
//.........这里部分代码省略.........
开发者ID:BenJamesbabala,项目名称:pspectralclustering,代码行数:101,代码来源:pdvout.c

示例6: s_copy


//.........这里部分代码省略.........
		    }
		} else {
		    d__1 = 1. / eps;
		    dlatms_(&m, &n, "Uniform", iseed, "Nonsymm", &copys[1], &
			    mode, &d__1, &c_b16, &m, &n, "No packing", &copya[
			    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, &copys[1], &c__1);
		}

/*              Save A and its singular values */

		dlacpy_("All", &m, &n, &copya[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, &copys[1], &work[1], 
			&lwork);

/*              Compute norm( A*P - Q*R ) */

		result[1] = dqpt01_(&m, &n, &mnmin, &copya[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_ */
开发者ID:juanjosegarciaripoll,项目名称:cblapack,代码行数:101,代码来源:dchkqp.c

示例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. */
开发者ID:juanjosegarciaripoll,项目名称:cblapack,代码行数:67,代码来源:schktp.c

示例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, &
//.........这里部分代码省略.........
开发者ID:3deggi,项目名称:levmar-ndk,代码行数:101,代码来源:derrac.c

示例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. */

//.........这里部分代码省略.........
开发者ID:3deggi,项目名称:levmar-ndk,代码行数:101,代码来源:dchkps.c

示例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_ */
开发者ID:juanjosegarciaripoll,项目名称:cblapack,代码行数:101,代码来源:zchkbk.c

示例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;
//.........这里部分代码省略.........
开发者ID:3deggi,项目名称:levmar-ndk,代码行数:101,代码来源:zchkhs.c

示例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 */

//.........这里部分代码省略.........
开发者ID:kstraube,项目名称:hysim,代码行数:101,代码来源:dchkpo.c

示例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_ */
开发者ID:3deggi,项目名称:levmar-ndk,代码行数:81,代码来源:alasvm.c

示例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 */
//.........这里部分代码省略.........
开发者ID:LACunha,项目名称:MOPAC,代码行数:101,代码来源:hcore.c

示例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. */
//.........这里部分代码省略.........
开发者ID:dailypips,项目名称:adevs,代码行数:101,代码来源:newuob.c


注:本文中的s_wsfe函数示例由纯净天空整理自Github/MSDocs等开源代码及文档管理平台,相关代码片段筛选自各路编程大神贡献的开源项目,源码版权归原作者所有,传播和使用请参考对应项目的License;未经允许,请勿转载。