Exemplo n.º 1
0
/* Cholesky factorization with complete pivoting */
void THLapack_(pstrf)(char uplo, int n, real *a, int lda, int *piv, int *rank, real tol, real *work, int *info)
{
#ifdef  USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
  dpstrf_(&uplo, &n, a, &lda, piv, rank, &tol, work, info);
#else
  spstrf_(&uplo, &n, a, &lda, piv, rank, &tol, work, info);
#endif
#else
  THError("pstrf: Lapack library not found at compile time\n");
#endif
}
Exemplo n.º 2
0
Arquivo: etcal.c Projeto: Dbelsa/coft
/* $Procedure            ETCAL ( Convert ET to Calendar format ) */
/* Subroutine */ int etcal_(doublereal *et, char *string, ftnlen string_len)
{
    /* Initialized data */

    static logical first = TRUE_;
    static integer extra[12] = { 0,0,1,1,1,1,1,1,1,1,1,1 };
    static integer dpjan0[12] = { 0,31,59,90,120,151,181,212,243,273,304,334 }
	    ;
    static integer dpbegl[12] = { 0,31,60,91,121,152,182,213,244,274,305,335 }
	    ;
    static char months[3*12] = "JAN" "FEB" "MAR" "APR" "MAY" "JUN" "JUL" 
	    "AUG" "SEP" "OCT" "NOV" "DEC";

    /* System generated locals */
    address a__1[12];
    integer i__1, i__2, i__3[12];
    doublereal d__1;

    /* Builtin functions */
    integer s_rnge(char *, integer, char *, integer);
    double d_int(doublereal *);
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
	     char **, integer *, integer *, ftnlen);

    /* Local variables */
    static integer dn2000;
    static doublereal dp2000, frac;
    static char date[180];
    static doublereal remd, secs;
    static integer year, mins;
    static char dstr[16], hstr[16], mstr[16], sstr[16], ystr[16];
    static doublereal halfd, q;
    static integer tsecs, dofyr, month, hours;
    extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
    static doublereal mynum;
    static integer bh, bm, iq;
    static doublereal secspd;
    static char messge[16];
    static integer offset;
    static doublereal dmnint;
    static logical adjust;
    static integer daynum;
    extern integer intmin_(void), intmax_(void);
    extern /* Subroutine */ int dpstrf_(doublereal *, integer *, char *, char 
	    *, ftnlen, ftnlen);
    static doublereal dmxint, mydnom;
    extern /* Subroutine */ int cmprss_(char *, integer *, char *, char *, 
	    ftnlen, ftnlen, ftnlen);
    extern integer lstlti_(integer *, integer *, integer *);
    extern /* Subroutine */ int intstr_(integer *, char *, ftnlen);
    static integer yr1, yr4;
    static char era[16];
    static integer day, rem;
    extern doublereal spd_(void);
    static integer yr100, yr400;

/* $ Abstract */


/*     Convert from an ephemeris epoch measured in seconds past */
/*     the epoch of J2000 to a calendar string format using a */
/*     formal calendar free of leapseconds. */

/* $ Disclaimer */

/*     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/*     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/*     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/*     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/*     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/*     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/*     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/*     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/*     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/*     SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */

/*     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/*     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/*     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/*     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/*     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/*     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */

/*     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/*     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/*     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/*     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */

/* $ Required_Reading */

/*     None. */

/* $ Keywords */

/*     TIME */

/* $ Declarations */
/* $ Brief_I/O */

/*     Variable  I/O  Description */
/*     --------  ---  -------------------------------------------------- */
/*     ET         I   Ephemeris time measured in seconds past J2000. */
/*     STRING     O   A standard calendar representation of ET. */

/* $ Detailed_Input */

/*     ET       is an epoch measured in ephemeris seconds */
/*              past the epoch of J2000. */

/* $ Detailed_Output */

/*     STRING   is a calendar string representing the input ephemeris */
/*              epoch.  This string is based upon extending the */
/*              Gregorian Calendar backward and forward indefinitely */
/*              keeping the same rules for determining leap years. */
/*              Moreover, there is no accounting for leapseconds. */

/*              To be sure that all of the date can be stored in */
/*              STRING, it should be declared to have length at */
/*              least 48 characters. */

/*              The string will have the following format */

/*                 year (era) mon day hr:mn:sc.sss */

/*              Where: */

/*                 year --- is the year */
/*                 era  --- is the chronological era associated with */
/*                          the date.  For years after 999 A.D. */
/*                          the era is omitted.  For years */
/*                          between 1 A.D. and 999 A.D. (inclusive) */
/*                          era is the string 'A.D.' For epochs */
/*                          before 1 A.D. Jan 1 00:00:00, era is */
/*                          given as 'B.C.' and the year is converted */
/*                          to years before the "Christian Era". */
/*                          The last B.C. epoch is */

/*                            1 B.C. DEC 31 23:59:59.999 */

/*                          The first A.D. epoch (which occurs .001 */
/*                          seconds after the last B.C. epoch) is: */

/*                             1 A.D. JAN 1 00:00:00.000 */

/*                          Note: there is no year 0 A.D. or 0 B.C. */
/*                 mon  --- is a 3-letter abbreviation for the month */
/*                          in all capital letters. */
/*                 day  --- is the day of the month */
/*                 hr   --- is the hour of the day (between 0 and 23) */
/*                          leading zeros are added to hr if the */
/*                          numeric value is less than 10. */
/*                 mn   --- is the minute of the hour (0 to 59) */
/*                          leading zeros are added to mn if the */
/*                          numeric value is less than 10. */
/*                 sc.sss   is the second of the minute to 3 decimal */
/*                          places ( 0 to 59.999).  Leading zeros */
/*                          are added if the numeric value is less */
/*                          than 10.  Seconds are truncated, not */
/*                          rounded. */


/* $ Parameters */

/*     None. */

/* $ Exceptions */

/*     Error free. */

/*     1) If the input ET is so large that the corresponding */
/*        number of days since 1 A.D. Jan 1, 00:00:00 is */
/*        within 1 of overflowing or underflowing an integer, */
/*        ET will not be converted to the correct string */
/*        representation rather, the string returned will */
/*        state that the epoch was before or after the day */
/*        that is INTMIN +1 or INTMAX - 1 days after */
/*        1 A.D. Jan 1, 00:00:00. */

/*     2) If the output string is not sufficiently long to hold */
/*        the full date, it will be truncated on the right. */

/* $ Files */

/*     None. */

/* $ Particulars */

/*     This is an error free routine for converting ephemeris epochs */
/*     represented as seconds past the J2000 epoch to formal */
/*     calendar strings based upon the Gregorian Calendar.  This formal */
/*     time is often useful when one needs a human recognizable */
/*     form of an ephemeris epoch.  There is no accounting for leap */
/*     seconds in the output times produced. */

/*     Note: The calendar epochs produced are not the same as the */
/*           UTC calendar epochs that correspond to ET. The strings */
/*           produced by this routine may vary from the corresponding */
/*           UTC epochs by more than 1 minute. */

/*     This routine can be used in creating error messages or */
/*     in routines and programs in which one prefers to report */
/*     times without employing leapseconds to produce exact UTC */
/*     epochs. */


/* $ Examples */

/*     Suppose you wish to  report that no data is */
/*     available at a particular ephemeris epoch ET.  The following */
/*     code shows how you might accomplish this task. */

/*     CALL DPSTRF ( ET,  6, 'F', ETSTR  ) */
/*     CALL ETCAL  ( ET,          STRING ) */

/*     E1 = RTRIM   (             STRING ) */
/*     E2 = RTRIM   (             ETSTR  ) */

/*     WRITE (*,*) 'There is no data available for the body ' */
/*     WRITE (*,*) 'at requested time: ' */
/*     WRITE (*,*) '   ', STRING(1:E1), ' (', ETSTR(1:E2), ')' */


/* $ Restrictions */

/*     One must keep in mind when using this routine that */
/*     ancient times are not based upon the Gregorian */
/*     calendar.  For example the 0 point of the Julian */
/*     Date system is 4713 B.C. Jan 1, 12:00:00 on the Julian */
/*     Calendar.  If one formalized the Gregorian calendar */
/*     and extended it indefinitely, the zero point of the Julian */
/*     date system corresponds to 4714 B.C. NOV 24 12:00:00 on */
/*     the Gregorian calendar.  There are several reasons for this. */
/*     Leap years in the Julian calendar occur every */
/*     4 years (including *all* centuries).  Moreover,  the */
/*     Gregorian calendar "effectively" begins on 15 Oct, 1582 A.D. */
/*     which is 5 Oct, 1582 A.D. in the Julian Calendar. */

/*     Therefore you must be careful in your interpretation */
/*     of ancient dates produced by this routine. */

/* $ Literature_References */

/*     1. "From Sundial to Atomic Clocks---Understanding Time and */
/*         Frequency" by James Jespersen and Jane Fitz-Randolph */
/*         Dover Publications, Inc. New York (1982). */

/* $ Author_and_Institution */

/*     W.L. Taber      (JPL) */
/*     K.R. Gehringer  (JPL) */

/* $ Version */

/* -     SPICELIB Version 2.2.0, 05-MAR-1998 (WLT) */

/*         The documentation concerning the appearance of the output */
/*         time string was corrected so that it does not suggest */
/*         a comma is inserted after the day of the month.  The */
/*         comma was removed from the output string in Version 2.0.0 */
/*         (see the note below) but the documentation was not upgraded */
/*         accordingly. */

/* -     SPICELIB Version 2.1.0, 20-MAY-1996 (WLT) */

/*         Two arrays that were initialized but never used were */
/*         removed. */

/* -     SPICELIB Version 2.0.0, 16-AUG-1995 (KRG) */

/*         If the day number was less than 10, the spacing was off for */
/*         the rest of the time by one space, that for the "tens" digit. */
/*         This has been fixed by using a leading zero when the number of */
/*         days is < 10. */

/*         Also, the comma that appeared between the month/day/year */
/*         and the hour:minute:seconds tokens has been removed. This was */
/*         done in order to make the calendar date format of ETCAL */
/*         consistent with the calendar date format of ET2UTC. */


/* -     SPICELIB Version 1.0.0, 14-DEC-1993 (WLT) */

/* -& */
/* $ Index_Entries */

/*     Convert ephemeris time to a formal calendar date */

/* -& */
/* $ Revisions */

/* -     SPICELIB Version 2.1.0, 20-MAY-1996 (WLT) */

/*         Two arrays that were initialized but never used were */
/*         removed. */

/* -     SPICELIB Version 2.0.0, 16-AUG-1995 (KRG) */

/*         If the day number was less than 10, the spacing was off for */
/*         the rest of the time by one space, that for the "tens" digit. */
/*         This has been fixed byusing a leading zero when the number of */
/*         days is < 10. */

/*         Also, the comma that appeared between the month/day/year */
/*         and the hour:minute:seconds tokens has been removed. This was */
/*         done in order to make the calendar date format of ETCAL */
/*         consistent with the calendar date format of ET2UTC. */

/* -     SPICELIB Version 1.0.0, 14-DEC-1993 (WLT) */

/* -& */

/*     Spicelib Functions. */


/*     We declare the variables that contain the number of days in */
/*     400 years, 100 years, 4 years and 1 year. */


/*     The following integers give the number of days during the */
/*     associated month of a non-leap year. */


/*     The integers that follow give the number of days in a normal */
/*     year that precede the first of the month. */


/*     The integers that follow give the number of days in a leap */
/*     year that precede the first of the month. */


/*     The variables below hold the components of the output string */
/*     before they are put together. */


/*     We will construct our string using the local variable DATE */
/*     and transfer the results to the output STRING when we are */
/*     done. */


/*     MONTHS contains 3-letter abbreviations for the months of the year */


/*     The array EXTRA contains the number of additional days that */
/*     appear before the first of a month during a leap year (as opposed */
/*     to a non-leap year). */


/*     DPJAN0(I) gives the number of days that occur before the I'th */
/*     month of a normal year. */


/*     Definitions of statement functions. */


/*     The number of days elapsed since Jan 1, of year 1 A.D. to */
/*     Jan 1 of YEAR is given by: */


/*     The number of leap days in a year is given by: */


/*     To compute the day of the year we */

/*        look up the number of days to the beginning of the month, */

/*        add on the number leap days that occurred prior to that */
/*        time */

/*        add on the number of days into the month */


/*     The number of days since 1 Jan 1 A.D. is given by: */

    if (first) {
	first = FALSE_;
	halfd = spd_() / 2.;
	secspd = spd_();
	dn2000 = (c__2000 - 1) * 365 + (c__2000 - 1) / 4 - (c__2000 - 1) / 
		100 + (c__2000 - 1) / 400 + (dpjan0[(i__1 = c__1 - 1) < 12 && 
		0 <= i__1 ? i__1 : s_rnge("dpjan0", i__1, "etcal_", (ftnlen)
		571)] + extra[(i__2 = c__1 - 1) < 12 && 0 <= i__2 ? i__2 : 
		s_rnge("extra", i__2, "etcal_", (ftnlen)571)] * ((c__2000 / 4 
		<< 2) / c__2000 - c__2000 / 100 * 100 / c__2000 + c__2000 / 
		400 * 400 / c__2000) + c__1) - 1;
	dmxint = (doublereal) intmax_();
	dmnint = (doublereal) intmin_();
    }

/*     Now we "in-line" compute the following call. */

/*        call rmaind ( et + halfd, secspd, dp2000, secs ) */

/*     because we can't make a call to rmaind. */

/*     The reader may wonder why we use et + halfd.  The value */
/*     et is seconds past the ephemeris epoch of J2000 which */
/*     is at 2000 Jan 1, 12:00:00.  We want to compute days past */
/*     2000 Jan 1, 00:00:00.  The seconds past THAT epoch is et + halfd. */
/*     We add on 0.0005 seconds so that the string produced will be */
/*     rounded to the nearest millisecond. */

    mydnom = secspd;
    mynum = *et + halfd;
    d__1 = mynum / mydnom;
    q = d_int(&d__1);
    remd = mynum - q * mydnom;
    if (remd < 0.) {
	q += -1.;
	remd += mydnom;
    }
    secs = remd;
    dp2000 = q;

/*     Do something about the problem when ET is vastly */
/*     out of range.  (Day number outside MAX and MIN integer). */

    if (dp2000 + dn2000 < dmnint + 1) {
	dp2000 = dmnint - dn2000 + 1;
	s_copy(messge, "Epoch before ", (ftnlen)16, (ftnlen)13);
	secs = 0.;
    } else if (dp2000 + dn2000 > dmxint - 1) {
	dp2000 = dmxint - dn2000 - 1;
	s_copy(messge, "Epoch after ", (ftnlen)16, (ftnlen)12);
	secs = 0.;
    } else {
	s_copy(messge, " ", (ftnlen)16, (ftnlen)1);
    }

/*     Compute the number of days since 1 .A.D. Jan 1, 00:00:00. */
/*     From the tests in the previous IF-ELSE IF-ELSE block this */
/*     addition is guaranteed not to overflow. */

    daynum = (integer) (dp2000 + (doublereal) dn2000);

/*     If the number of days is negative, we need to do a little */
/*     work so that we can represent the date in the B.C. era. */
/*     We add enough multiples of 400 years so that the year will */
/*     be positive and then we subtract off the appropriate multiple */
/*     of 400 years later. */

    if (daynum < 0) {

/*        Since we can't make the call below and remain */
/*        error free, we compute it ourselves. */

/*        call rmaini ( daynum, dp400y, offset, daynum ) */

	iq = daynum / 146097;
	rem = daynum - iq * 146097;
	if (rem < 0) {
	    --iq;
	    rem += 146097;
	}
	offset = iq;
	daynum = rem;
	adjust = TRUE_;
    } else {
	adjust = FALSE_;
    }

/*     Next we compute the year.  Divide out multiples of 400, 100 */
/*     4 and 1 year.  Finally combine these to get the correct */
/*     value for year.  (Note this is all integer arithmetic.) */

/*     Recall that DP1Y   =    365 */
/*                 DP4Y   =  4*DPY    + 1 */
/*                 DP100Y = 25*DP4Y   - 1 */
/*                 DP400Y =  4*DP100Y + 1 */

    yr400 = daynum / 146097;
    rem = daynum - yr400 * 146097;
/* Computing MIN */
    i__1 = 3, i__2 = rem / 36524;
    yr100 = min(i__1,i__2);
    rem -= yr100 * 36524;
/* Computing MIN */
    i__1 = 24, i__2 = rem / 1461;
    yr4 = min(i__1,i__2);
    rem -= yr4 * 1461;
/* Computing MIN */
    i__1 = 3, i__2 = rem / 365;
    yr1 = min(i__1,i__2);
    rem -= yr1 * 365;
    dofyr = rem + 1;
    year = yr400 * 400 + yr100 * 100 + (yr4 << 2) + yr1 + 1;

/*     Get the month, and day of month (depending upon whether */
/*     we have a leap year or not). */

    if ((year / 4 << 2) / year - year / 100 * 100 / year + year / 400 * 400 / 
	    year == 0) {
	month = lstlti_(&dofyr, &c__12, dpjan0);
	day = dofyr - dpjan0[(i__1 = month - 1) < 12 && 0 <= i__1 ? i__1 : 
		s_rnge("dpjan0", i__1, "etcal_", (ftnlen)698)];
    } else {
	month = lstlti_(&dofyr, &c__12, dpbegl);
	day = dofyr - dpbegl[(i__1 = month - 1) < 12 && 0 <= i__1 ? i__1 : 
		s_rnge("dpbegl", i__1, "etcal_", (ftnlen)701)];
    }

/*     If we had to adjust the year to make it positive, we now */
/*     need to correct it and then convert it to a B.C. year. */

    if (adjust) {
	year += offset * 400;
	year = -year + 1;
	s_copy(era, " B.C. ", (ftnlen)16, (ftnlen)6);
    } else {

/*        If the year is less than 1000, we can't just write it */
/*        out.  We need to add the era.  If we don't do this */
/*        the dates look very confusing. */

	if (year < 1000) {
	    s_copy(era, " A.D. ", (ftnlen)16, (ftnlen)6);
	} else {
	    s_copy(era, " ", (ftnlen)16, (ftnlen)1);
	}
    }

/*     Convert Seconds to Hours, Minute and Seconds. */
/*     We work with thousandths of a second in integer arithmetic */
/*     so that all of the truncation work with seconds will already */
/*     be done.  (Note that we already know that SECS is greater than */
/*     or equal to zero so we'll have no problems with HOURS, MINS */
/*     or SECS becoming negative.) */

    tsecs = (integer) (secs * 1e3);
    frac = secs - (doublereal) tsecs;
    hours = tsecs / 3600000;
    tsecs -= hours * 3600000;
    mins = tsecs / 60000;
    tsecs -= mins * 60000;
    secs = (doublereal) tsecs / 1e3;

/*     We round seconds if we can do so without getting seconds to be */
/*     bigger than 60. */

    if (secs + 5e-4 < 60.) {
	secs += 5e-4;
    }

/*     Finally, get the components of our date string. */

    intstr_(&year, ystr, (ftnlen)16);
    if (day >= 10) {
	intstr_(&day, dstr, (ftnlen)16);
    } else {
	s_copy(dstr, "0", (ftnlen)16, (ftnlen)1);
	intstr_(&day, dstr + 1, (ftnlen)15);
    }

/*     We want to zero pad the hours minutes and seconds. */

    if (hours < 10) {
	bh = 2;
    } else {
	bh = 1;
    }
    if (mins < 10) {
	bm = 2;
    } else {
	bm = 1;
    }
    s_copy(mstr, "00", (ftnlen)16, (ftnlen)2);
    s_copy(hstr, "00", (ftnlen)16, (ftnlen)2);
    s_copy(sstr, " ", (ftnlen)16, (ftnlen)1);

/*     Now construct the string components for hours, minutes and */
/*     seconds. */

    secs = (integer) (secs * 1e3) / 1e3;
    intstr_(&hours, hstr + (bh - 1), 16 - (bh - 1));
    intstr_(&mins, mstr + (bm - 1), 16 - (bm - 1));
    dpstrf_(&secs, &c__6, "F", sstr, (ftnlen)1, (ftnlen)16);

/*     The form of the output for SSTR has a leading blank followed by */
/*     the first significant digit.  If a decimal point is in the */
/*     third slot, then SSTR is of the form ' x.xxxxx'  and we need */
/*     to insert a leading zero. */

    if (*(unsigned char *)&sstr[2] == '.') {
	*(unsigned char *)sstr = '0';
    }

/*     We don't want any leading spaces in SSTR, (HSTR and MSTR don't */
/*     have leading spaces by construction. */

    ljust_(sstr, sstr, (ftnlen)16, (ftnlen)16);

/*     Now form the date string, squeeze out extra spaces and */
/*     left justify the whole thing. */

/* Writing concatenation */
    i__3[0] = 16, a__1[0] = messge;
    i__3[1] = 16, a__1[1] = ystr;
    i__3[2] = 16, a__1[2] = era;
    i__3[3] = 3, a__1[3] = months + ((i__1 = month - 1) < 12 && 0 <= i__1 ? 
	    i__1 : s_rnge("months", i__1, "etcal_", (ftnlen)810)) * 3;
    i__3[4] = 1, a__1[4] = " ";
    i__3[5] = 3, a__1[5] = dstr;
    i__3[6] = 1, a__1[6] = " ";
    i__3[7] = 2, a__1[7] = hstr;
    i__3[8] = 1, a__1[8] = ":";
    i__3[9] = 2, a__1[9] = mstr;
    i__3[10] = 1, a__1[10] = ":";
    i__3[11] = 6, a__1[11] = sstr;
    s_cat(date, a__1, i__3, &c__12, (ftnlen)180);
    cmprss_(" ", &c__1, date, date, (ftnlen)1, (ftnlen)180, (ftnlen)180);
    ljust_(date, date, (ftnlen)180, (ftnlen)180);
    s_copy(string, date, string_len, (ftnlen)180);
    return 0;
} /* etcal_ */
Exemplo n.º 3
0
/* Subroutine */ int derrps_(char *path, integer *nunit)
{
    /* Builtin functions */
    integer s_wsle(cilist *), e_wsle(void);
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    doublereal a[16]	/* was [4][4] */;
    integer i__, j, piv[4], info;
    doublereal work[8];
    extern /* Subroutine */ int dpstf2_(char *, integer *, doublereal *, 
	    integer *, integer *, integer *, doublereal *, doublereal *, 
	    integer *), alaesm_(char *, logical *, integer *),
	     chkxer_(char *, integer *, integer *, logical *, logical *), dpstrf_(char *, integer *, doublereal *, integer *, 
	    integer *, integer *, doublereal *, doublereal *, integer *);

    /* Fortran I/O blocks */
    static cilist io___1 = { 0, 0, 0, 0, 0 };



/*  -- LAPACK test routine (version 3.1) -- */
/*     Craig Lucas, University of Manchester / NAG Ltd. */
/*     October, 2008 */

/*     .. Scalar Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DERRPS tests the error exits for the DOUBLE PRECISION routines */
/*  for DPSTRF. */

/*  Arguments */
/*  ========= */

/*  PATH    (input) CHARACTER*3 */
/*          The LAPACK path name for the routines to be tested. */

/*  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);

/* L100: */
	}
	piv[j - 1] = j;
	work[j - 1] = 0.;
	work[j + 3] = 0.;

/* L110: */
    }
    infoc_1.ok = TRUE_;


/*        Test error exits of the routines that use the Cholesky */
/*        decomposition of a symmetric positive semidefinite matrix. */

/*        DPSTRF */

    s_copy(srnamc_1.srnamt, "DPSTRF", (ftnlen)32, (ftnlen)6);
    infoc_1.infot = 1;
    dpstrf_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, work, &info);
    chkxer_("DPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
	    infoc_1.ok);
    infoc_1.infot = 2;
    dpstrf_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, work, &info);
    chkxer_("DPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
	    infoc_1.ok);
    infoc_1.infot = 4;
    dpstrf_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, work, &info);
    chkxer_("DPSTRF", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
	    infoc_1.ok);

/*        DPSTF2 */

    s_copy(srnamc_1.srnamt, "DPSTF2", (ftnlen)32, (ftnlen)6);
    infoc_1.infot = 1;
    dpstf2_("/", &c__0, a, &c__1, piv, &c__1, &c_b9, work, &info);
    chkxer_("DPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
	    infoc_1.ok);
    infoc_1.infot = 2;
    dpstf2_("U", &c_n1, a, &c__1, piv, &c__1, &c_b9, work, &info);
    chkxer_("DPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
	    infoc_1.ok);
    infoc_1.infot = 4;
    dpstf2_("U", &c__2, a, &c__1, piv, &c__1, &c_b9, work, &info);
    chkxer_("DPSTF2", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
	    infoc_1.ok);


/*     Print a summary line. */

    alaesm_(path, &infoc_1.ok, &infoc_1.nout);

    return 0;

/*     End of DERRPS */

} /* derrps_ */
Exemplo n.º 4
0
/* 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. */

/*  THRESH  (input) DOUBLE PRECISION */
/*          The threshold value for the test ratios.  A result is */
/*          included in the output file if RESULT >= THRESH.  To have */
/*          every test ratio printed, use THRESH = 0. */

/*  TSTERR  (input) LOGICAL */
/*          Flag that indicates whether error exits are to be tested. */

/*  NMAX    (input) INTEGER */
/*          The maximum value permitted for N, used in dimensioning the */
/*          work arrays. */

/*  A       (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */

/*  AFAC    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */

/*  PERM    (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) */

/*  PIV     (workspace) INTEGER array, dimension (NMAX) */

/*  WORK    (workspace) DOUBLE PRECISION array, dimension (NMAX*3) */

/*  RWORK   (workspace) DOUBLE PRECISION array, dimension (NMAX) */

/*  NOUT    (input) INTEGER */
/*          The unit number for output. */

/*  ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. Local Arrays .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Scalars in Common .. */
/*     .. */
/*     .. Common blocks .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Data statements .. */
    /* Parameter adjustments */
    --rwork;
    --work;
    --piv;
    --perm;
    --afac;
    --a;
    --rankval;
    --nbval;
    --nval;
    --dotype;

    /* Function Body */
/*     .. */
/*     .. Executable Statements .. */

/*     Initialize constants and the random number seed. */

    s_copy(path, "Double precision", (ftnlen)1, (ftnlen)16);
    s_copy(path + 1, "PS", (ftnlen)2, (ftnlen)2);
    nrun = 0;
    nfail = 0;
    nerrs = 0;
    for (i__ = 1; i__ <= 4; ++i__) {
	iseed[i__ - 1] = iseedy[i__ - 1];
/* L100: */
    }

/*     Test the error exits */

    if (*tsterr) {
	derrps_(path, nout);
    }
    infoc_1.infot = 0;
    xlaenv_(&c__2, &c__2);

/*     Do for each value of N in NVAL */

    i__1 = *nn;
    for (in = 1; in <= i__1; ++in) {
	n = nval[in];
	lda = max(n,1);
	nimat = 9;
	if (n <= 0) {
	    nimat = 1;
	}

	izero = 0;
	i__2 = nimat;
	for (imat = 1; imat <= i__2; ++imat) {

/*           Do the tests only if DOTYPE( IMAT ) is true. */

	    if (! dotype[imat]) {
		goto L140;
	    }

/*              Do for each value of RANK in RANKVAL */

	    i__3 = *nrank;
	    for (irank = 1; irank <= i__3; ++irank) {

/*              Only repeat test 3 to 5 for different ranks */
/*              Other tests use full rank */

		if ((imat < 3 || imat > 5) && irank > 1) {
		    goto L130;
		}

		d__1 = n * (doublereal) rankval[irank] / 100.;
		rank = i_dceiling(&d__1);


/*           Do first for UPLO = 'U', then for UPLO = 'L' */

		for (iuplo = 1; iuplo <= 2; ++iuplo) {
		    *(unsigned char *)uplo = *(unsigned char *)&uplos[iuplo - 
			    1];

/*              Set up parameters with DLATB5 and generate a test matrix */
/*              with DLATMT. */

		    dlatb5_(path, &imat, &n, type__, &kl, &ku, &anorm, &mode, 
			    &cndnum, dist);

		    s_copy(srnamc_1.srnamt, "DLATMT", (ftnlen)32, (ftnlen)6);
		    dlatmt_(&n, &n, dist, iseed, type__, &rwork[1], &mode, &
			    cndnum, &anorm, &rank, &kl, &ku, uplo, &a[1], &
			    lda, &work[1], &info);

/*              Check error code from DLATMT. */

		    if (info != 0) {
			alaerh_(path, "DLATMT", &info, &c__0, uplo, &n, &n, &
				c_n1, &c_n1, &c_n1, &imat, &nfail, &nerrs, 
				nout);
			goto L120;
		    }

/*              Do for each value of NB in NBVAL */

		    i__4 = *nnb;
		    for (inb = 1; inb <= i__4; ++inb) {
			nb = nbval[inb];
			xlaenv_(&c__1, &nb);

/*                 Compute the pivoted L*L' or U'*U factorization */
/*                 of the matrix. */

			dlacpy_(uplo, &n, &n, &a[1], &lda, &afac[1], &lda);
			s_copy(srnamc_1.srnamt, "DPSTRF", (ftnlen)32, (ftnlen)
				6);

/*                 Use default tolerance */

			tol = -1.;
			dpstrf_(uplo, &n, &afac[1], &lda, &piv[1], &comprank, 
				&tol, &work[1], &info);

/*                 Check error code from DPSTRF. */

			if (info < izero || info != izero && rank == n || 
				info <= izero && rank < n) {
			    alaerh_(path, "DPSTRF", &info, &izero, uplo, &n, &
				    n, &c_n1, &c_n1, &nb, &imat, &nfail, &
				    nerrs, nout);
			    goto L110;
			}

/*                 Skip the test if INFO is not 0. */

			if (info != 0) {
			    goto L110;
			}

/*                 Reconstruct matrix from factors and compute residual. */

/*                 PERM holds permuted L*L^T or U^T*U */

			dpst01_(uplo, &n, &a[1], &lda, &afac[1], &lda, &perm[
				1], &lda, &piv[1], &rwork[1], &result, &
				comprank);

/*                 Print information about the tests that did not pass */
/*                 the threshold or where computed rank was not RANK. */

			if (n == 0) {
			    comprank = 0;
			}
			rankdiff = rank - comprank;
			if (result >= *thresh) {
			    if (nfail == 0 && nerrs == 0) {
				alahd_(nout, path);
			    }
			    io___33.ciunit = *nout;
			    s_wsfe(&io___33);
			    do_fio(&c__1, uplo, (ftnlen)1);
			    do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer))
				    ;
			    do_fio(&c__1, (char *)&rank, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&rankdiff, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer)
				    );
			    do_fio(&c__1, (char *)&imat, (ftnlen)sizeof(
				    integer));
			    do_fio(&c__1, (char *)&result, (ftnlen)sizeof(
				    doublereal));
			    e_wsfe();
			    ++nfail;
			}
			++nrun;
L110:
			;
		    }

L120:
		    ;
		}
L130:
		;
	    }
L140:
	    ;
	}
/* L150: */
    }

/*     Print a summary of the results. */

    alasum_(path, nout, &nfail, &nrun, &nerrs);

    return 0;

/*     End of DCHKPS */

} /* dchkps_ */
Exemplo n.º 5
0
/* $Procedure  REPMF  ( Replace marker with formatted d.p. value ) */
/* Subroutine */ int repmf_(char *in, char *marker, doublereal *value, 
	integer *sigdig, char *format, char *out, ftnlen in_len, ftnlen 
	marker_len, ftnlen format_len, ftnlen out_len)
{
    /* System generated locals */
    integer i__1, i__2;

    /* Builtin functions */
    integer s_cmp(char *, char *, ftnlen, ftnlen);
    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
    integer i_indx(char *, char *, ftnlen, ftnlen);

    /* Local variables */
    extern /* Subroutine */ int zzrepsub_(char *, integer *, integer *, char *
	    , char *, ftnlen, ftnlen, ftnlen), ucase_(char *, char *, ftnlen, 
	    ftnlen);
    char gdfmt[1];
    extern /* Subroutine */ int ljust_(char *, char *, ftnlen, ftnlen);
    extern integer lastnb_(char *, ftnlen), frstnb_(char *, ftnlen);
    extern /* Subroutine */ int dpstrf_(doublereal *, integer *, char *, char 
	    *, ftnlen, ftnlen);
    integer mrkpos;
    char substr[56];

/* $ Abstract */

/*     Replace a marker in a string with a formatted double precision */
/*     value. */

/* $ Disclaimer */

/*     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE */
/*     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S. */
/*     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE */
/*     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE */
/*     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS" */
/*     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY */
/*     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A */
/*     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC */
/*     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE */
/*     SOFTWARE AND RELATED MATERIALS, HOWEVER USED. */

/*     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA */
/*     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT */
/*     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND, */
/*     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS, */
/*     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE */
/*     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY. */

/*     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF */
/*     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY */
/*     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE */
/*     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE. */

/* $ Required_Reading */

/*     None. */

/* $ Keywords */

/*     CHARACTER */
/*     CONVERSION */
/*     STRING */

/* $ Declarations */
/* $ Brief_I/O */

/*     VARIABLE  I/O  DESCRIPTION */
/*     --------  ---  -------------------------------------------------- */
/*     IN         I   Input string. */
/*     MARKER     I   Marker to be replaced. */
/*     VALUE      I   Replacement value. */
/*     SIGDIG     I   Significant digits in replacement text. */
/*     FORMAT     I   Format: 'E' or 'F'. */
/*     OUT        O   Output string. */
/*     MAXLFD     P   Maximum length of a formatted DP number. */

/* $ Detailed_Input */

/*     IN             is an arbitrary character string. */

/*     MARKER         is an arbitrary character string. The first */
/*                    occurrence of MARKER in the input string is */
/*                    to be replaced by VALUE. */

/*                    Leading and trailing blanks in MARKER are NOT */
/*                    significant. In particular, no substitution is */
/*                    performed if MARKER is blank. */

/*     VALUE          is an arbitrary double precision number. */

/*     SIGDIG         is the number of significant digits with */
/*                    which VALUE is to be represented. SIGDIG */
/*                    must be greater than zero and less than 15. */

/*     FORMAT         is the format in which VALUE is to be represented. */
/*                    FORMAT may be any of the following: */

/*                       FORMAT  Meaning      Example */
/*                       ------  -----------  ---------------- */
/*                       E, e    Scientific   3.14159E+03 */
/*                               (exponent) */
/*                               notation */

/*                       F, f    Fixed-point  3141.59 */
/*                               notation */

/* $ Detailed_Output */

/*     OUT            is the string obtained by substituting the text */
/*                    representation of VALUE for the first occurrence */
/*                    of MARKER in the input string. */

/*                    The text representation of VALUE is in scientific */
/*                    (exponent) or fixed-point notation, depending on */
/*                    having the value of FORMAT, and having the number */
/*                    of significant digits specified by SIGDIG. */
/*                    The representation of VALUE is produced by the */
/*                    routine DPSTRF; see that routine for details */
/*                    concerning the representation of double precision */
/*                    numbers. */

/*                    OUT and IN must be identical or disjoint. */

/* $ Parameters */

/*     MAXLFD         is the maximum expected length of the text */
/*                    representation of a formatted double precision */
/*                    number. 56 characters are sufficient to hold any */
/*                    result returned by DPSTRF. (See $Restrictions.) */
/* $ Files */

/*     None. */

/* $ Exceptions */

/*     Error Free. */

/*     1) If OUT does not have sufficient length to accommodate the */
/*        result of the substitution, the result will be truncated on */
/*        the right. */

/*     2) If MARKER is blank, or if MARKER is not a substring of IN, */
/*        no substitution is performed. (OUT and IN are identical.) */

/* $ Particulars */

/*     This is one of a family of related routines for inserting values */
/*     into strings. They are typically to construct messages that */
/*     are partly fixed, and partly determined at run time. For example, */
/*     a message like */

/*        'Fifty-one pictures were found in directory [USER.DATA].' */

/*     might be constructed from the fixed string */

/*        '#1 pictures were found in directory #2.' */

/*     by the calls */

/*        CALL REPMCT ( STRING, '#1', N_PICS,  'C', STRING ) */
/*        CALL REPMC  ( STRING, '#2', DIR_NAME,     STRING ) */

/*     which substitute the cardinal text 'Fifty-one' and the character */
/*     string '[USER.DATA]' for the markers '#1' and '#2' respectively. */

/*     The complete list of routines is shown below. */

/*        REPMC    ( Replace marker with character string value ) */
/*        REPMD    ( Replace marker with double precision value ) */
/*        REPMF    ( Replace marker with formatted d.p. value ) */
/*        REPMI    ( Replace marker with integer value ) */
/*        REPMCT   ( Replace marker with cardinal text) */
/*        REPMOT   ( Replace marker with ordinal text ) */

/* $ Examples */


/*     1. Let */

/*           IN = 'Invalid operation value.  The value was #.' */

/*        Then following the call, */

/*           CALL REPMF ( IN, '#', 5.0D1, 2, 'E', IN  ) */

/*        IN is */

/*           'Invalid operation value.  The value was 5.0E+01.' */


/*     2. Let */

/*           IN = 'Left endpoint exceeded right endpoint.  The left */
/*                 endpoint was: XX.  The right endpoint was: XX.' */

/*        Then following the call, */

/*           CALL REPMF ( IN, '  XX  ',  -5.2D-9, 3, 'E', OUT ) */

/*        OUT is */

/*           'Left endpoint exceeded right endpoint.  The left */
/*            endpoint was: -5.20E-09.  The right endpoint was: XX.' */


/*     3. Let */

/*           IN = 'Invalid operation value.  The value was # units.' */

/*        Then following the call, */

/*           CALL REPMF ( IN, '#', 5.0D1, 3, 'F', IN  ) */

/*        IN is */

/*           'Invalid operation value.  The value was 50.0 units..' */


/*     4. In the above example, if SIGDIG is 1 instead of 3, IN becomes */

/*           'Invalid operation value.  The value was 50 units.' */


/*     5. Let */

/*           IN = 'Invalid operation value.  The value was #.' */

/*        Then following the call, */

/*           CALL REPMF ( IN, '#', 5.0D1, 100, 'E', IN  ) */

/*        IN is */

/*           'Invalid operation value.  The value was */
/*            5.0000000000000E+01.' */

/*        Note that even though 100 digits of precision were requested, */
/*        only 14 were returned. */


/*     6. Let */

/*           MARKER = '&' */
/*           NUM    = 23 */
/*           CHANCE = 'fair' */
/*           SCORE  = 4.665D0 */

/*        Then following the sequence of calls, */

/*           CALL REPMI ( 'There are & routines that have a '  // */
/*          .             '& chance of meeting your needs.'    // */
/*          .             'The maximum score was &.', */
/*          .             '&', */
/*          .             NUM, */
/*          .             MSG  ) */

/*           CALL REPMC ( MSG, '&', CHANCE, MSG ) */

/*           CALL REPMF ( MSG, '&', SCORE, 4, 'F', MSG ) */

/*        MSG is */

/*           'There are 23 routines that have a fair chance of */
/*            meeting your needs.  The maximum score was 4.665.' */

/* $ Restrictions */

/*     1) The maximum number of significant digits returned is 14. */

/*     2) This routine makes explicit use of the format of the string */
/*        returned by DPSTRF; should that routine change, substantial */
/*        work may be required to bring this routine back up to snuff. */

/* $ Literature_References */

/*     None. */

/* $ Author_and_Institution */

/*     N.J. Bachman   (JPL) */
/*     I.M. Underwood (JPL) */

/* $ Version */

/* -    SPICELIB Version 1.1.0, 15-AUG-2002 (WLT) */

/*        The routine is now error free. */

/* -    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT) */

/*        Comment section for permuted index source lines was added */
/*        following the header. */

/* -    SPICELIB Version 1.0.0, 30-AUG-1990 (NJB) (IMU) */

/* -& */
/* $ Index_Entries */

/*     replace marker with formatted d.p. value */

/* -& */

/*     SPICELIB functions */


/*     Local variables */


/*     If MARKER is blank, no substitution is possible. */

    if (s_cmp(marker, " ", marker_len, (ftnlen)1) == 0) {
	s_copy(out, in, out_len, in_len);
	return 0;
    }

/*     Locate the leftmost occurrence of MARKER, if there is one */
/*     (ignoring leading and trailing blanks). If MARKER is not */
/*     a substring of IN, no substitution can be performed. */

    i__1 = frstnb_(marker, marker_len) - 1;
    mrkpos = i_indx(in, marker + i__1, in_len, lastnb_(marker, marker_len) - 
	    i__1);
    if (mrkpos == 0) {
	s_copy(out, in, out_len, in_len);
	return 0;
    }

/*     Okay, MARKER is non-blank and has been found. Convert the */
/*     number to text, and substitute the text for the marker. */

    ljust_(format, gdfmt, format_len, (ftnlen)1);
    ucase_(gdfmt, gdfmt, (ftnlen)1, (ftnlen)1);
    dpstrf_(value, sigdig, gdfmt, substr, (ftnlen)1, (ftnlen)56);
    if (lastnb_(substr, (ftnlen)56) != 0) {
	i__1 = frstnb_(substr, (ftnlen)56) - 1;
	i__2 = mrkpos + lastnb_(marker, marker_len) - frstnb_(marker, 
		marker_len);
	zzrepsub_(in, &mrkpos, &i__2, substr + i__1, out, in_len, lastnb_(
		substr, (ftnlen)56) - i__1, out_len);
    }
    return 0;
} /* repmf_ */