/* DECK DBOLSM */
/* Subroutine */ int dbolsm_(doublereal *w, integer *mdw, integer *minput,
integer *ncols, doublereal *bl, doublereal *bu, integer *ind, integer
*iopt, doublereal *x, doublereal *rnorm, integer *mode, doublereal *
rw, doublereal *ww, doublereal *scl, integer *ibasis, integer *ibb)
{
/* System generated locals */
address a__1[3], a__2[4], a__3[6], a__4[5], a__5[2], a__6[7];
integer w_dim1, w_offset, i__1[3], i__2[4], i__3, i__4[6], i__5[5], i__6[
2], i__7[7], i__8, i__9, i__10;
doublereal d__1, d__2;
char ch__1[47], ch__2[50], ch__3[79], ch__4[53], ch__5[94], ch__6[75],
ch__7[83], ch__8[92], ch__9[105], ch__10[102], ch__11[61], ch__12[
110], ch__13[134], ch__14[44], ch__15[76];
/* Local variables */
static integer i__, j;
static doublereal t, t1, t2, sc;
static integer ip, jp, lp;
static doublereal ss, wt, cl1, cl2, cl3, fac, big;
static integer lds;
static doublereal bou, beta;
static integer jbig, jmag, ioff, jcol;
static doublereal wbig;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal wmag;
static integer mval, iter;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal xnew;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static char xern1[8], xern2[8], xern3[16], xern4[16];
static doublereal alpha;
static logical found;
static integer nsetb;
extern /* Subroutine */ int drotg_(doublereal *, doublereal *, doublereal
*, doublereal *), dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer igopr, itmax, itemp;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer lgopr;
extern /* Subroutine */ int dmout_(integer *, integer *, integer *,
doublereal *, char *, integer *, ftnlen);
static integer jdrop;
extern doublereal d1mach_(integer *);
extern /* Subroutine */ int dvout_(integer *, doublereal *, char *,
integer *, ftnlen), ivout_(integer *, integer *, char *, integer *
, ftnlen);
static integer mrows, jdrop1, jdrop2, jlarge;
static doublereal colabv, colblo, wlarge, tolind;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static integer iprint;
static logical constr;
static doublereal tolsze;
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___3 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___9 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___10 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___12 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___14 = { 0, xern4, 0, "(1PD15.6)", 16, 1 };
static icilist io___15 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___16 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___17 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___18 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___31 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___32 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___33 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___34 = { 0, xern4, 0, "(1PD15.6)", 16, 1 };
static icilist io___35 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___36 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___37 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___38 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___39 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___40 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___41 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___42 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___43 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___44 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___45 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___54 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE DBOLSM */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBOCLS and DBOLS */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SBOLSM-S, DBOLSM-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* **** Double Precision Version of SBOLSM **** */
/* **** All INPUT and OUTPUT real variables are DOUBLE PRECISION **** */
/* Solve E*X = F (least squares sense) with bounds on */
/* selected X values. */
/* The user must have DIMENSION statements of the form: */
/* DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS), */
/* * X(NCOLS+NX), RW(NCOLS), WW(NCOLS), SCL(NCOLS) */
/* INTEGER IND(NCOLS), IOPT(1+NI), IBASIS(NCOLS), IBB(NCOLS) */
/* (Here NX=number of extra locations required for options 1,...,7; */
/* NX=0 for no options; here NI=number of extra locations possibly */
/* required for options 1-7; NI=0 for no options; NI=14 if all the */
/* options are simultaneously in use.) */
/* INPUT */
/* ----- */
/* -------------------- */
/* W(MDW,*),MINPUT,NCOLS */
/* -------------------- */
/* The array W(*,*) contains the matrix [E:F] on entry. The matrix */
/* [E:F] has MINPUT rows and NCOLS+1 columns. This data is placed in */
/* the array W(*,*) with E occupying the first NCOLS columns and the */
/* right side vector F in column NCOLS+1. The row dimension, MDW, of */
/* the array W(*,*) must satisfy the inequality MDW .ge. MINPUT. */
/* Other values of MDW are errors. The values of MINPUT and NCOLS */
/* must be positive. Other values are errors. */
/* ------------------ */
/* BL(*),BU(*),IND(*) */
/* ------------------ */
/* These arrays contain the information about the bounds that the */
/* solution values are to satisfy. The value of IND(J) tells the */
/* type of bound and BL(J) and BU(J) give the explicit values for */
/* the respective upper and lower bounds. */
/* 1. For IND(J)=1, require X(J) .ge. BL(J). */
/* 2. For IND(J)=2, require X(J) .le. BU(J). */
/* 3. For IND(J)=3, require X(J) .ge. BL(J) and */
/* X(J) .le. BU(J). */
/* 4. For IND(J)=4, no bounds on X(J) are required. */
/* The values of BL(*),BL(*) are modified by the subprogram. Values */
/* other than 1,2,3 or 4 for IND(J) are errors. In the case IND(J)=3 */
/* (upper and lower bounds) the condition BL(J) .gt. BU(J) is an */
/* error. */
/* ------- */
/* IOPT(*) */
/* ------- */
/* This is the array where the user can specify nonstandard options */
/* for DBOLSM. Most of the time this feature can be ignored by */
/* setting the input value IOPT(1)=99. Occasionally users may have */
/* needs that require use of the following subprogram options. For */
/* details about how to use the options see below: IOPT(*) CONTENTS. */
/* Option Number Brief Statement of Purpose */
/* ----- ------ ----- --------- -- ------- */
/* 1 Move the IOPT(*) processing pointer. */
/* 2 Change rank determination tolerance. */
/* 3 Change blow-up factor that determines the */
/* size of variables being dropped from active */
/* status. */
/* 4 Reset the maximum number of iterations to use */
/* in solving the problem. */
/* 5 The data matrix is triangularized before the */
/* problem is solved whenever (NCOLS/MINPUT) .lt. */
/* FAC. Change the value of FAC. */
/* 6 Redefine the weighting matrix used for */
/* linear independence checking. */
/* 7 Debug output is desired. */
/* 99 No more options to change. */
/* ---- */
/* X(*) */
/* ---- */
/* This array is used to pass data associated with options 1,2,3 and */
/* 5. Ignore this input parameter if none of these options are used. */
/* Otherwise see below: IOPT(*) CONTENTS. */
/* ---------------- */
/* IBASIS(*),IBB(*) */
/* ---------------- */
/* These arrays must be initialized by the user. The values */
/* IBASIS(J)=J, J=1,...,NCOLS */
/* IBB(J) =1, J=1,...,NCOLS */
/* are appropriate except when using nonstandard features. */
/* ------ */
/* SCL(*) */
/* ------ */
/* This is the array of scaling factors to use on the columns of the */
/* matrix E. These values must be defined by the user. To suppress */
/* any column scaling set SCL(J)=1.0, J=1,...,NCOLS. */
/* OUTPUT */
/* ------ */
/* ---------- */
/* X(*),RNORM */
/* ---------- */
/* The array X(*) contains a solution (if MODE .ge. 0 or .eq. -22) */
/* for the constrained least squares problem. The value RNORM is the */
/* minimum residual vector length. */
/* ---- */
/* MODE */
/* ---- */
/* The sign of mode determines whether the subprogram has completed */
/* normally, or encountered an error condition or abnormal status. */
/* A value of MODE .ge. 0 signifies that the subprogram has completed */
/* normally. The value of MODE (.ge. 0) is the number of variables */
/* in an active status: not at a bound nor at the value ZERO, for */
/* the case of free variables. A negative value of MODE will be one */
/* of the 18 cases -38,-37,...,-22, or -1. Values .lt. -1 correspond */
/* to an abnormal completion of the subprogram. To understand the */
/* abnormal completion codes see below: ERROR MESSAGES for DBOLSM */
/* An approximate solution will be returned to the user only when */
/* maximum iterations is reached, MODE=-22. */
/* ----------- */
/* RW(*),WW(*) */
/* ----------- */
/* These are working arrays each with NCOLS entries. The array RW(*) */
/* contains the working (scaled, nonactive) solution values. The */
/* array WW(*) contains the working (scaled, active) gradient vector */
/* values. */
/* ---------------- */
/* IBASIS(*),IBB(*) */
/* ---------------- */
/* These arrays contain information about the status of the solution */
/* when MODE .ge. 0. The indices IBASIS(K), K=1,...,MODE, show the */
/* nonactive variables; indices IBASIS(K), K=MODE+1,..., NCOLS are */
/* the active variables. The value (IBB(J)-1) is the number of times */
/* variable J was reflected from its upper bound. (Normally the user */
/* can ignore these parameters.) */
/* IOPT(*) CONTENTS */
/* ------- -------- */
/* The option array allows a user to modify internal variables in */
/* the subprogram without recompiling the source code. A central */
/* goal of the initial software design was to do a good job for most */
/* people. Thus the use of options will be restricted to a select */
/* group of users. The processing of the option array proceeds as */
/* follows: a pointer, here called LP, is initially set to the value */
/* 1. The value is updated as the options are processed. At the */
/* pointer position the option number is extracted and used for */
/* locating other information that allows for options to be changed. */
/* The portion of the array IOPT(*) that is used for each option is */
/* fixed; the user and the subprogram both know how many locations */
/* are needed for each option. A great deal of error checking is */
/* done by the subprogram on the contents of the option array. */
/* Nevertheless it is still possible to give the subprogram optional */
/* input that is meaningless. For example, some of the options use */
/* the location X(NCOLS+IOFF) for passing data. The user must manage */
/* the allocation of these locations when more than one piece of */
/* option data is being passed to the subprogram. */
/* 1 */
/* - */
/* Move the processing pointer (either forward or backward) to the */
/* location IOPT(LP+1). The processing pointer is moved to location */
/* LP+2 of IOPT(*) in case IOPT(LP)=-1. For example to skip over */
/* locations 3,...,NCOLS+2 of IOPT(*), */
/* IOPT(1)=1 */
/* IOPT(2)=NCOLS+3 */
/* (IOPT(I), I=3,...,NCOLS+2 are not defined here.) */
/* IOPT(NCOLS+3)=99 */
/* CALL DBOLSM */
/* CAUTION: Misuse of this option can yield some very hard-to-find */
/* bugs. Use it with care. */
/* 2 */
/* - */
/* The algorithm that solves the bounded least squares problem */
/* iteratively drops columns from the active set. This has the */
/* effect of joining a new column vector to the QR factorization of */
/* the rectangular matrix consisting of the partially triangularized */
/* nonactive columns. After triangularizing this matrix a test is */
/* made on the size of the pivot element. The column vector is */
/* rejected as dependent if the magnitude of the pivot element is */
/* .le. TOL* magnitude of the column in components strictly above */
/* the pivot element. Nominally the value of this (rank) tolerance */
/* is TOL = SQRT(R1MACH(4)). To change only the value of TOL, for */
/* example, */
/* X(NCOLS+1)=TOL */
/* IOPT(1)=2 */
/* IOPT(2)=1 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=TOL */
/* IOPT(LP)=2 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The required length of IOPT(*) is increased by 2 if option 2 is */
/* used; The required length of X(*) is increased by 1. A value of */
/* IOFF .le. 0 is an error. A value of TOL .le. R1MACH(4) gives a */
/* warning message; it is not considered an error. */
/* 3 */
/* - */
/* A solution component is left active (not used) if, roughly */
/* speaking, it seems too large. Mathematically the new component is */
/* left active if the magnitude is .ge.((vector norm of F)/(matrix */
/* norm of E))/BLOWUP. Nominally the factor BLOWUP = SQRT(R1MACH(4)). */
/* To change only the value of BLOWUP, for example, */
/* X(NCOLS+2)=BLOWUP */
/* IOPT(1)=3 */
/* IOPT(2)=2 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=BLOWUP */
/* IOPT(LP)=3 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The required length of IOPT(*) is increased by 2 if option 3 is */
/* used; the required length of X(*) is increased by 1. A value of */
/* IOFF .le. 0 is an error. A value of BLOWUP .le. 0.0 is an error. */
/* 4 */
/* - */
/* Normally the algorithm for solving the bounded least squares */
/* problem requires between NCOLS/3 and NCOLS drop-add steps to */
/* converge. (this remark is based on examining a small number of */
/* test cases.) The amount of arithmetic for such problems is */
/* typically about twice that required for linear least squares if */
/* there are no bounds and if plane rotations are used in the */
/* solution method. Convergence of the algorithm, while */
/* mathematically certain, can be much slower than indicated. To */
/* avoid this potential but unlikely event ITMAX drop-add steps are */
/* permitted. Nominally ITMAX=5*(MAX(MINPUT,NCOLS)). To change the */
/* value of ITMAX, for example, */
/* IOPT(1)=4 */
/* IOPT(2)=ITMAX */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* IOPT(LP)=4 */
/* IOPT(LP+1)=ITMAX */
/* . */
/* CALL DBOLSM */
/* The value of ITMAX must be .gt. 0. Other values are errors. Use */
/* of this option increases the required length of IOPT(*) by 2. */
/* 5 */
/* - */
/* For purposes of increased efficiency the MINPUT by NCOLS+1 data */
/* matrix [E:F] is triangularized as a first step whenever MINPUT */
/* satisfies FAC*MINPUT .gt. NCOLS. Nominally FAC=0.75. To change the */
/* value of FAC, */
/* X(NCOLS+3)=FAC */
/* IOPT(1)=5 */
/* IOPT(2)=3 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=FAC */
/* IOPT(LP)=5 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The value of FAC must be nonnegative. Other values are errors. */
/* Resetting FAC=0.0 suppresses the initial triangularization step. */
/* Use of this option increases the required length of IOPT(*) by 2; */
/* The required length of of X(*) is increased by 1. */
/* 6 */
/* - */
/* The norm used in testing the magnitudes of the pivot element */
/* compared to the mass of the column above the pivot line can be */
/* changed. The type of change that this option allows is to weight */
/* the components with an index larger than MVAL by the parameter */
/* WT. Normally MVAL=0 and WT=1. To change both the values MVAL and */
/* WT, where LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=WT */
/* IOPT(LP)=6 */
/* IOPT(LP+1)=IOFF */
/* IOPT(LP+2)=MVAL */
/* Use of this option increases the required length of IOPT(*) by 3. */
/* The length of X(*) is increased by 1. Values of MVAL must be */
/* nonnegative and not greater than MINPUT. Other values are errors. */
/* The value of WT must be positive. Any other value is an error. If */
/* either error condition is present a message will be printed. */
/* 7 */
/* - */
/* Debug output, showing the detailed add-drop steps for the */
/* constrained least squares problem, is desired. This option is */
/* intended to be used to locate suspected bugs. */
/* 99 */
/* -- */
/* There are no more options to change. */
/* The values for options are 1,...,7,99, and are the only ones */
/* permitted. Other values are errors. Options -99,-1,...,-7 mean */
/* that the repective options 99,1,...,7 are left at their default */
/* values. An example is the option to modify the (rank) tolerance: */
/* X(NCOLS+1)=TOL */
/* IOPT(1)=-2 */
/* IOPT(2)=1 */
/* IOPT(3)=99 */
/* Error Messages for DBOLSM */
/* ----- -------- --- --------- */
/* -22 MORE THAN ITMAX = ... ITERATIONS SOLVING BOUNDED LEAST */
/* SQUARES PROBLEM. */
/* -23 THE OPTION NUMBER = ... IS NOT DEFINED. */
/* -24 THE OFFSET = ... BEYOND POSTION NCOLS = ... MUST BE POSITIVE */
/* FOR OPTION NUMBER 2. */
/* -25 THE TOLERANCE FOR RANK DETERMINATION = ... IS LESS THAN */
/* MACHINE PRECISION = .... */
/* -26 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE */
/* FOR OPTION NUMBER 3. */
/* -27 THE RECIPROCAL OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES */
/* MUST BE POSITIVE. NOW = .... */
/* -28 THE MAXIMUM NUMBER OF ITERATIONS = ... MUST BE POSITIVE. */
/* -29 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE */
/* FOR OPTION NUMBER 5. */
/* -30 THE FACTOR (NCOLS/MINPUT) WHERE PRETRIANGULARIZING IS */
/* PERFORMED MUST BE NONNEGATIVE. NOW = .... */
/* -31 THE NUMBER OF ROWS = ... MUST BE POSITIVE. */
/* -32 THE NUMBER OF COLUMNS = ... MUST BE POSTIVE. */
/* -33 THE ROW DIMENSION OF W(,) = ... MUST BE .GE. THE NUMBER OF */
/* ROWS = .... */
/* -34 FOR J = ... THE CONSTRAINT INDICATOR MUST BE 1-4. */
/* -35 FOR J = ... THE LOWER BOUND = ... IS .GT. THE UPPER BOUND = */
/* .... */
/* -36 THE INPUT ORDER OF COLUMNS = ... IS NOT BETWEEN 1 AND NCOLS */
/* = .... */
/* -37 THE BOUND POLARITY FLAG IN COMPONENT J = ... MUST BE */
/* POSITIVE. NOW = .... */
/* -38 THE ROW SEPARATOR TO APPLY WEIGHTING (...) MUST LIE BETWEEN */
/* 0 AND MINPUT = .... WEIGHT = ... MUST BE POSITIVE. */
/* ***SEE ALSO DBOCLS, DBOLS */
/* ***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, DMOUT, DNRM2, DROT, */
/* DROTG, DSWAP, DVOUT, IVOUT, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 821220 DATE WRITTEN */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 920422 Fixed usage of MINPUT. (WRB) */
/* 901009 Editorial changes, code now reads from top to bottom. (RWC) */
/* ***END PROLOGUE DBOLSM */
/* PURPOSE */
/* ------- */
/* THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE BOUNDED */
/* LEAST SQUARES PROBLEM. THE PROBLEM SOLVED HERE IS: */
/* SOLVE E*X = F (LEAST SQUARES SENSE) */
/* WITH BOUNDS ON SELECTED X VALUES. */
/* TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN */
/* EDITING AT THE CARD 'C++'. */
/* CHANGE THE SUBPROGRAM NAME TO DBOLSM AND THE STRINGS */
/* /SAXPY/ TO /DAXPY/, /SCOPY/ TO /DCOPY/, */
/* /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/, */
/* /SROT/ TO /DROT/, /SROTG/ TO /DROTG/, /R1MACH/ TO /D1MACH/, */
/* /SVOUT/ TO /DVOUT/, /SMOUT/ TO /DMOUT/, */
/* /SSWAP/ TO /DSWAP/, /E0/ TO /D0/, */
/* /REAL / TO /DOUBLE PRECISION/. */
/* ++ */
/* ***FIRST EXECUTABLE STATEMENT DBOLSM */
/* Verify that the problem dimensions are defined properly. */
/* Parameter adjustments */
w_dim1 = *mdw;
w_offset = 1 + w_dim1;
w -= w_offset;
--bl;
--bu;
--ind;
--iopt;
--x;
--rw;
--ww;
--scl;
--ibasis;
--ibb;
/* Function Body */
if (*minput <= 0) {
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 21, a__1[0] = "THE NUMBER OF ROWS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)47);
xermsg_("SLATEC", "DBOLSM", ch__1, &c__31, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)47);
*mode = -31;
return 0;
}
if (*ncols <= 0) {
s_wsfi(&io___3);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 24, a__1[0] = "THE NUMBER OF COLUMNS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)50);
xermsg_("SLATEC", "DBOLSM", ch__2, &c__32, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)50);
*mode = -32;
return 0;
}
if (*mdw < *minput) {
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*mdw), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 28, a__2[0] = "THE ROW DIMENSION OF W(,) = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 35, a__2[2] = " MUST BE .GE. THE NUMBER OF ROWS = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__3, a__2, i__2, &c__4, (ftnlen)79);
xermsg_("SLATEC", "DBOLSM", ch__3, &c__33, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)79);
*mode = -33;
return 0;
}
/* Verify that bound information is correct. */
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] < 1 || ind[j] > 4) {
s_wsfi(&io___8);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___9);
do_fio(&c__1, (char *)&ind[j], (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 8, a__1[0] = "FOR J = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 37, a__1[2] = " THE CONSTRAINT INDICATOR MUST BE 1-4";
s_cat(ch__4, a__1, i__1, &c__3, (ftnlen)53);
xermsg_("SLATEC", "DBOLSM", ch__4, &c__34, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)53);
*mode = -34;
return 0;
}
/* L10: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] == 3) {
if (bu[j] < bl[j]) {
s_wsfi(&io___10);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___12);
do_fio(&c__1, (char *)&bl[j], (ftnlen)sizeof(doublereal));
e_wsfi();
s_wsfi(&io___14);
do_fio(&c__1, (char *)&bu[j], (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__4[0] = 8, a__3[0] = "FOR J = ";
i__4[1] = 8, a__3[1] = xern1;
i__4[2] = 19, a__3[2] = " THE LOWER BOUND = ";
i__4[3] = 16, a__3[3] = xern3;
i__4[4] = 27, a__3[4] = " IS .GT. THE UPPER BOUND = ";
i__4[5] = 16, a__3[5] = xern4;
s_cat(ch__5, a__3, i__4, &c__6, (ftnlen)94);
xermsg_("SLATEC", "DBOLSM", ch__5, &c__35, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)94);
*mode = -35;
return 0;
}
}
/* L20: */
}
/* Check that permutation and polarity arrays have been set. */
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ibasis[j] < 1 || ibasis[j] > *ncols) {
s_wsfi(&io___15);
do_fio(&c__1, (char *)&ibasis[j], (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___16);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 29, a__2[0] = "THE INPUT ORDER OF COLUMNS = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 30, a__2[2] = " IS NOT BETWEEN 1 AND NCOLS = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__6, a__2, i__2, &c__4, (ftnlen)75);
xermsg_("SLATEC", "DBOLSM", ch__6, &c__36, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)75);
*mode = -36;
return 0;
}
if (ibb[j] <= 0) {
s_wsfi(&io___17);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___18);
do_fio(&c__1, (char *)&ibb[j], (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 41, a__2[0] = "THE BOUND POLARITY FLAG IN COMPONENT J "
"= ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 26, a__2[2] = " MUST BE POSITIVE.$$NOW = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__7, a__2, i__2, &c__4, (ftnlen)83);
xermsg_("SLATEC", "DBOLSM", ch__7, &c__37, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)83);
*mode = -37;
return 0;
}
/* L30: */
}
/* Process the option array. */
fac = .75;
tolind = sqrt(d1mach_(&c__4));
tolsze = sqrt(d1mach_(&c__4));
itmax = max(*minput,*ncols) * 5;
wt = 1.;
mval = 0;
iprint = 0;
/* Changes to some parameters can occur through the option array, */
/* IOPT(*). Process this array looking carefully for input data */
/* errors. */
lp = 0;
lds = 0;
/* Test for no more options. */
L590:
lp += lds;
ip = iopt[lp + 1];
jp = abs(ip);
if (ip == 99) {
goto L470;
} else if (jp == 99) {
lds = 1;
} else if (jp == 1) {
/* Move the IOPT(*) processing pointer. */
if (ip > 0) {
lp = iopt[lp + 2] - 1;
lds = 0;
} else {
lds = 2;
}
} else if (jp == 2) {
/* Change tolerance for rank determination. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___31);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___32);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 2.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__24, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -24;
return 0;
}
tolind = x[*ncols + ioff];
if (tolind < d1mach_(&c__4)) {
s_wsfi(&io___33);
do_fio(&c__1, (char *)&tolind, (ftnlen)sizeof(doublereal));
e_wsfi();
s_wsfi(&io___34);
d__1 = d1mach_(&c__4);
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__2[0] = 39, a__2[0] = "THE TOLERANCE FOR RANK DETERMINATIO"
"N = ";
i__2[1] = 16, a__2[1] = xern3;
i__2[2] = 34, a__2[2] = " IS LESS THAN MACHINE PRECISION = ";
i__2[3] = 16, a__2[3] = xern4;
s_cat(ch__9, a__2, i__2, &c__4, (ftnlen)105);
xermsg_("SLATEC", "DBOLSM", ch__9, &c__25, &c__0, (ftnlen)6, (
ftnlen)6, (ftnlen)105);
*mode = -25;
}
}
lds = 2;
} else if (jp == 3) {
/* Change blowup factor for allowing variables to become */
/* inactive. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___35);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___36);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 3.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__26, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -26;
return 0;
}
tolsze = x[*ncols + ioff];
if (tolsze <= 0.) {
s_wsfi(&io___37);
do_fio(&c__1, (char *)&tolsze, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__6[0] = 86, a__5[0] = "THE RECIPROCAL OF THE BLOW-UP FACTO"
"R FOR REJECTING VARIABLES MUST BE POSITIVE.$$NOW = ";
i__6[1] = 16, a__5[1] = xern3;
s_cat(ch__10, a__5, i__6, &c__2, (ftnlen)102);
xermsg_("SLATEC", "DBOLSM", ch__10, &c__27, &c__1, (ftnlen)6,
(ftnlen)6, (ftnlen)102);
*mode = -27;
return 0;
}
}
lds = 2;
} else if (jp == 4) {
/* Change the maximum number of iterations allowed. */
if (ip > 0) {
itmax = iopt[lp + 2];
if (itmax <= 0) {
s_wsfi(&io___38);
do_fio(&c__1, (char *)&itmax, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 35, a__1[0] = "THE MAXIMUM NUMBER OF ITERATIONS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__11, a__1, i__1, &c__3, (ftnlen)61);
xermsg_("SLATEC", "DBOLSM", ch__11, &c__28, &c__1, (ftnlen)6,
(ftnlen)6, (ftnlen)61);
*mode = -28;
return 0;
}
}
lds = 2;
} else if (jp == 5) {
/* Change the factor for pretriangularizing the data matrix. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___39);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___40);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 5.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__29, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -29;
return 0;
}
fac = x[*ncols + ioff];
if (fac < 0.) {
s_wsfi(&io___41);
do_fio(&c__1, (char *)&fac, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__6[0] = 94, a__5[0] = "THE FACTOR (NCOLS/MINPUT) WHERE PRE"
"-TRIANGULARIZING IS PERFORMED MUST BE NON-NEGATIVE.$"
"$NOW = ";
i__6[1] = 16, a__5[1] = xern3;
s_cat(ch__12, a__5, i__6, &c__2, (ftnlen)110);
xermsg_("SLATEC", "DBOLSM", ch__12, &c__30, &c__0, (ftnlen)6,
(ftnlen)6, (ftnlen)110);
*mode = -30;
return 0;
}
}
lds = 2;
} else if (jp == 6) {
/* Change the weighting factor (from 1.0) to apply to components */
/* numbered .gt. MVAL (initially set to 1.) This trick is needed */
/* for applications of this subprogram to the heavily weighted */
/* least squares problem that come from equality constraints. */
if (ip > 0) {
ioff = iopt[lp + 2];
mval = iopt[lp + 3];
wt = x[*ncols + ioff];
}
if (mval < 0 || mval > *minput || wt <= 0.) {
s_wsfi(&io___42);
do_fio(&c__1, (char *)&mval, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___43);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___44);
do_fio(&c__1, (char *)&wt, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__7[0] = 38, a__6[0] = "THE ROW SEPARATOR TO APPLY WEIGHTING (";
i__7[1] = 8, a__6[1] = xern1;
i__7[2] = 34, a__6[2] = ") MUST LIE BETWEEN 0 AND MINPUT = ";
i__7[3] = 8, a__6[3] = xern2;
i__7[4] = 12, a__6[4] = ".$$WEIGHT = ";
i__7[5] = 16, a__6[5] = xern3;
i__7[6] = 18, a__6[6] = " MUST BE POSITIVE.";
s_cat(ch__13, a__6, i__7, &c__7, (ftnlen)134);
xermsg_("SLATEC", "DBOLSM", ch__13, &c__38, &c__0, (ftnlen)6, (
ftnlen)6, (ftnlen)134);
*mode = -38;
return 0;
}
lds = 3;
} else if (jp == 7) {
/* Turn on debug output. */
if (ip > 0) {
iprint = 1;
}
lds = 2;
} else {
s_wsfi(&io___45);
do_fio(&c__1, (char *)&ip, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 20, a__1[0] = "THE OPTION NUMBER = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 16, a__1[2] = " IS NOT DEFINED.";
s_cat(ch__14, a__1, i__1, &c__3, (ftnlen)44);
xermsg_("SLATEC", "DBOLSM", ch__14, &c__23, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)44);
*mode = -23;
return 0;
}
goto L590;
/* Pretriangularize rectangular arrays of certain sizes for */
/* increased efficiency. */
L470:
if (fac * *minput > (doublereal) (*ncols)) {
i__3 = *ncols + 1;
for (j = 1; j <= i__3; ++j) {
i__8 = j + mval + 1;
for (i__ = *minput; i__ >= i__8; --i__) {
drotg_(&w[i__ - 1 + j * w_dim1], &w[i__ + j * w_dim1], &sc, &
ss);
w[i__ + j * w_dim1] = 0.;
i__9 = *ncols - j + 1;
drot_(&i__9, &w[i__ - 1 + (j + 1) * w_dim1], mdw, &w[i__ + (j
+ 1) * w_dim1], mdw, &sc, &ss);
/* L480: */
}
/* L490: */
}
mrows = *ncols + mval + 1;
} else {
mrows = *minput;
}
/* Set the X(*) array to zero so all components are defined. */
dcopy_(ncols, &c_b185, &c__0, &x[1], &c__1);
/* The arrays IBASIS(*) and IBB(*) are initialized by the calling */
/* program and the column scaling is defined in the calling program. */
/* 'BIG' is plus infinity on this machine. */
big = d1mach_(&c__2);
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] == 1) {
bu[j] = big;
} else if (ind[j] == 2) {
bl[j] = -big;
} else if (ind[j] == 4) {
bl[j] = -big;
bu[j] = big;
}
/* L550: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (bl[j] <= 0. && 0. <= bu[j] && (d__1 = bu[j], abs(d__1)) < (d__2 =
bl[j], abs(d__2)) || bu[j] < 0.) {
t = bu[j];
bu[j] = -bl[j];
bl[j] = -t;
scl[j] = -scl[j];
i__8 = mrows;
for (i__ = 1; i__ <= i__8; ++i__) {
w[i__ + j * w_dim1] = -w[i__ + j * w_dim1];
/* L560: */
}
}
/* Indices in set T(=TIGHT) are denoted by negative values */
/* of IBASIS(*). */
if (bl[j] >= 0.) {
ibasis[j] = -ibasis[j];
t = -bl[j];
bu[j] += t;
daxpy_(&mrows, &t, &w[j * w_dim1 + 1], &c__1, &w[(*ncols + 1) *
w_dim1 + 1], &c__1);
}
/* L570: */
}
nsetb = 0;
iter = 0;
if (iprint > 0) {
i__3 = *ncols + 1;
dmout_(&mrows, &i__3, mdw, &w[w_offset], "(' PRETRI. INPUT MATRIX')",
&c_n4, (ftnlen)25);
dvout_(ncols, &bl[1], "(' LOWER BOUNDS')", &c_n4, (ftnlen)17);
dvout_(ncols, &bu[1], "(' UPPER BOUNDS')", &c_n4, (ftnlen)17);
}
L580:
++iter;
if (iter > itmax) {
s_wsfi(&io___54);
do_fio(&c__1, (char *)&itmax, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 18, a__1[0] = "MORE THAN ITMAX = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 50, a__1[2] = " ITERATIONS SOLVING BOUNDED LEAST SQUARES P"
"ROBLEM.";
s_cat(ch__15, a__1, i__1, &c__3, (ftnlen)76);
xermsg_("SLATEC", "DBOLSM", ch__15, &c__22, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)76);
*mode = -22;
/* Rescale and translate variables. */
igopr = 1;
goto L130;
}
/* Find a variable to become non-active. */
/* T */
/* Compute (negative) of gradient vector, W = E *(F-E*X). */
dcopy_(ncols, &c_b185, &c__0, &ww[1], &c__1);
i__3 = *ncols;
for (j = nsetb + 1; j <= i__3; ++j) {
jcol = (i__8 = ibasis[j], abs(i__8));
i__8 = mrows - nsetb;
/* Computing MIN */
i__9 = nsetb + 1;
/* Computing MIN */
i__10 = nsetb + 1;
ww[j] = ddot_(&i__8, &w[min(i__9,mrows) + j * w_dim1], &c__1, &w[min(
i__10,mrows) + (*ncols + 1) * w_dim1], &c__1) * (d__1 = scl[
jcol], abs(d__1));
/* L200: */
}
if (iprint > 0) {
dvout_(ncols, &ww[1], "(' GRADIENT VALUES')", &c_n4, (ftnlen)20);
ivout_(ncols, &ibasis[1], "(' INTERNAL VARIABLE ORDER')", &c_n4, (
ftnlen)28);
ivout_(ncols, &ibb[1], "(' BOUND POLARITY')", &c_n4, (ftnlen)19);
}
/* If active set = number of total rows, quit. */
L210:
if (nsetb == mrows) {
found = FALSE_;
goto L120;
}
/* Choose an extremal component of gradient vector for a candidate */
/* to become non-active. */
wlarge = -big;
wmag = -big;
i__3 = *ncols;
for (j = nsetb + 1; j <= i__3; ++j) {
t = ww[j];
if (t == big) {
goto L220;
}
itemp = ibasis[j];
jcol = abs(itemp);
i__8 = mval - nsetb;
/* Computing MIN */
i__9 = nsetb + 1;
t1 = dnrm2_(&i__8, &w[min(i__9,mrows) + j * w_dim1], &c__1);
if (itemp < 0) {
if (ibb[jcol] % 2 == 0) {
t = -t;
}
if (t < 0.) {
goto L220;
}
if (mval > nsetb) {
t = t1;
}
if (t > wlarge) {
wlarge = t;
jlarge = j;
}
} else {
if (mval > nsetb) {
t = t1;
}
if (abs(t) > wmag) {
wmag = abs(t);
jmag = j;
}
}
L220:
;
}
/* Choose magnitude of largest component of gradient for candidate. */
jbig = 0;
wbig = 0.;
if (wlarge > 0.) {
jbig = jlarge;
wbig = wlarge;
}
if (wmag >= wbig) {
jbig = jmag;
wbig = wmag;
}
if (jbig == 0) {
found = FALSE_;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' FOUND NO VARIABLE TO ENTER')", &c_n4, (
ftnlen)31);
}
goto L120;
}
/* See if the incoming column is sufficiently independent. This */
/* test is made before an elimination is performed. */
if (iprint > 0) {
ivout_(&c__1, &jbig, "(' TRY TO BRING IN THIS COL.')", &c_n4, (ftnlen)
30);
}
if (mval <= nsetb) {
cl1 = dnrm2_(&mval, &w[jbig * w_dim1 + 1], &c__1);
i__3 = nsetb - mval;
/* Computing MIN */
i__8 = mval + 1;
cl2 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
i__3 = mrows - nsetb;
/* Computing MIN */
i__8 = nsetb + 1;
cl3 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
drotg_(&cl1, &cl2, &sc, &ss);
colabv = abs(cl1);
colblo = cl3;
} else {
cl1 = dnrm2_(&nsetb, &w[jbig * w_dim1 + 1], &c__1);
i__3 = mval - nsetb;
/* Computing MIN */
i__8 = nsetb + 1;
cl2 = dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &c__1);
i__3 = mrows - mval;
/* Computing MIN */
i__8 = mval + 1;
cl3 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
colabv = cl1;
drotg_(&cl2, &cl3, &sc, &ss);
colblo = abs(cl2);
}
if (colblo <= tolind * colabv) {
ww[jbig] = big;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' VARIABLE IS DEPENDENT, NOT USED.')", &
c_n4, (ftnlen)37);
}
goto L210;
}
/* Swap matrix columns NSETB+1 and JBIG, plus pointer information, */
/* and gradient values. */
++nsetb;
if (nsetb != jbig) {
dswap_(&mrows, &w[nsetb * w_dim1 + 1], &c__1, &w[jbig * w_dim1 + 1], &
c__1);
dswap_(&c__1, &ww[nsetb], &c__1, &ww[jbig], &c__1);
itemp = ibasis[nsetb];
ibasis[nsetb] = ibasis[jbig];
ibasis[jbig] = itemp;
}
/* Eliminate entries below the pivot line in column NSETB. */
if (mrows > nsetb) {
i__3 = nsetb + 1;
for (i__ = mrows; i__ >= i__3; --i__) {
if (i__ == mval + 1) {
goto L230;
}
drotg_(&w[i__ - 1 + nsetb * w_dim1], &w[i__ + nsetb * w_dim1], &
sc, &ss);
w[i__ + nsetb * w_dim1] = 0.;
i__8 = *ncols - nsetb + 1;
drot_(&i__8, &w[i__ - 1 + (nsetb + 1) * w_dim1], mdw, &w[i__ + (
nsetb + 1) * w_dim1], mdw, &sc, &ss);
L230:
;
}
if (mval >= nsetb && mval < mrows) {
drotg_(&w[nsetb + nsetb * w_dim1], &w[mval + 1 + nsetb * w_dim1],
&sc, &ss);
w[mval + 1 + nsetb * w_dim1] = 0.;
i__3 = *ncols - nsetb + 1;
drot_(&i__3, &w[nsetb + (nsetb + 1) * w_dim1], mdw, &w[mval + 1 +
(nsetb + 1) * w_dim1], mdw, &sc, &ss);
}
}
if (w[nsetb + nsetb * w_dim1] == 0.) {
ww[nsetb] = big;
--nsetb;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' PIVOT IS ZERO, NOT USED.')", &c_n4, (
ftnlen)29);
}
goto L210;
}
/* Check that new variable is moving in the right direction. */
itemp = ibasis[nsetb];
jcol = abs(itemp);
xnew = w[nsetb + (*ncols + 1) * w_dim1] / w[nsetb + nsetb * w_dim1] / (
d__1 = scl[jcol], abs(d__1));
if (itemp < 0) {
/* IF(WW(NSETB).GE.ZERO.AND.XNEW.LE.ZERO) exit(quit) */
/* IF(WW(NSETB).LE.ZERO.AND.XNEW.GE.ZERO) exit(quit) */
if (ww[nsetb] >= 0. && xnew <= 0. || ww[nsetb] <= 0. && xnew >= 0.) {
goto L240;
}
}
found = TRUE_;
goto L120;
L240:
ww[nsetb] = big;
--nsetb;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' VARIABLE HAS BAD DIRECTION, NOT USED.')", &
c_n4, (ftnlen)42);
}
goto L210;
/* Solve the triangular system. */
L270:
dcopy_(&nsetb, &w[(*ncols + 1) * w_dim1 + 1], &c__1, &rw[1], &c__1);
for (j = nsetb; j >= 1; --j) {
rw[j] /= w[j + j * w_dim1];
jcol = (i__3 = ibasis[j], abs(i__3));
t = rw[j];
if (ibb[jcol] % 2 == 0) {
rw[j] = -rw[j];
}
i__3 = j - 1;
d__1 = -t;
daxpy_(&i__3, &d__1, &w[j * w_dim1 + 1], &c__1, &rw[1], &c__1);
rw[j] /= (d__1 = scl[jcol], abs(d__1));
/* L280: */
}
if (iprint > 0) {
dvout_(&nsetb, &rw[1], "(' SOLN. VALUES')", &c_n4, (ftnlen)17);
ivout_(&nsetb, &ibasis[1], "(' COLS. USED')", &c_n4, (ftnlen)15);
}
if (lgopr == 2) {
dcopy_(&nsetb, &rw[1], &c__1, &x[1], &c__1);
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
itemp = ibasis[j];
jcol = abs(itemp);
if (itemp < 0) {
bou = 0.;
} else {
bou = bl[jcol];
}
if (-bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (x[j] <= bou) {
jdrop1 = j;
goto L340;
}
bou = bu[jcol];
if (bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (x[j] >= bou) {
jdrop2 = j;
goto L340;
}
/* L450: */
}
goto L340;
}
/* See if the unconstrained solution (obtained by solving the */
/* triangular system) satisfies the problem bounds. */
alpha = 2.;
beta = 2.;
x[nsetb] = 0.;
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
itemp = ibasis[j];
jcol = abs(itemp);
t1 = 2.;
t2 = 2.;
if (itemp < 0) {
bou = 0.;
} else {
bou = bl[jcol];
}
if (-bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (rw[j] <= bou) {
t1 = (x[j] - bou) / (x[j] - rw[j]);
}
bou = bu[jcol];
if (bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (rw[j] >= bou) {
t2 = (bou - x[j]) / (rw[j] - x[j]);
}
/* If not, then compute a step length so that the variables remain */
/* feasible. */
if (t1 < alpha) {
alpha = t1;
jdrop1 = j;
}
if (t2 < beta) {
beta = t2;
jdrop2 = j;
}
/* L310: */
}
constr = alpha < 2. || beta < 2.;
if (! constr) {
/* Accept the candidate because it satisfies the stated bounds */
/* on the variables. */
dcopy_(&nsetb, &rw[1], &c__1, &x[1], &c__1);
goto L580;
}
/* Take a step that is as large as possible with all variables */
/* remaining feasible. */
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
x[j] += min(alpha,beta) * (rw[j] - x[j]);
/* L330: */
}
if (alpha <= beta) {
jdrop2 = 0;
} else {
jdrop1 = 0;
}
L340:
if (jdrop1 + jdrop2 <= 0 || nsetb <= 0) {
goto L580;
}
/* L350: */
jdrop = jdrop1 + jdrop2;
itemp = ibasis[jdrop];
jcol = abs(itemp);
if (jdrop2 > 0) {
/* Variable is at an upper bound. Subtract multiple of this */
/* column from right hand side. */
t = bu[jcol];
if (itemp > 0) {
bu[jcol] = t - bl[jcol];
bl[jcol] = -t;
itemp = -itemp;
scl[jcol] = -scl[jcol];
i__3 = jdrop;
for (i__ = 1; i__ <= i__3; ++i__) {
w[i__ + jdrop * w_dim1] = -w[i__ + jdrop * w_dim1];
/* L360: */
}
} else {
++ibb[jcol];
if (ibb[jcol] % 2 == 0) {
t = -t;
}
}
/* Variable is at a lower bound. */
} else {
if ((doublereal) itemp < 0.) {
t = 0.;
} else {
t = -bl[jcol];
bu[jcol] += t;
itemp = -itemp;
}
}
daxpy_(&jdrop, &t, &w[jdrop * w_dim1 + 1], &c__1, &w[(*ncols + 1) *
w_dim1 + 1], &c__1);
/* Move certain columns left to achieve upper Hessenberg form. */
dcopy_(&jdrop, &w[jdrop * w_dim1 + 1], &c__1, &rw[1], &c__1);
i__3 = nsetb;
for (j = jdrop + 1; j <= i__3; ++j) {
ibasis[j - 1] = ibasis[j];
x[j - 1] = x[j];
dcopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[(j - 1) * w_dim1 + 1], &c__1)
;
/* L370: */
}
ibasis[nsetb] = itemp;
w[nsetb * w_dim1 + 1] = 0.;
i__3 = mrows - jdrop;
dcopy_(&i__3, &w[nsetb * w_dim1 + 1], &c__0, &w[jdrop + 1 + nsetb *
w_dim1], &c__1);
dcopy_(&jdrop, &rw[1], &c__1, &w[nsetb * w_dim1 + 1], &c__1);
/* Transform the matrix from upper Hessenberg form to upper */
/* triangular form. */
--nsetb;
i__3 = nsetb;
for (i__ = jdrop; i__ <= i__3; ++i__) {
/* Look for small pivots and avoid mixing weighted and */
/* nonweighted rows. */
if (i__ == mval) {
t = 0.;
i__8 = nsetb;
for (j = i__; j <= i__8; ++j) {
jcol = (i__9 = ibasis[j], abs(i__9));
t1 = (d__1 = w[i__ + j * w_dim1] * scl[jcol], abs(d__1));
if (t1 > t) {
jbig = j;
t = t1;
}
/* L380: */
}
goto L400;
}
drotg_(&w[i__ + i__ * w_dim1], &w[i__ + 1 + i__ * w_dim1], &sc, &ss);
w[i__ + 1 + i__ * w_dim1] = 0.;
i__8 = *ncols - i__ + 1;
drot_(&i__8, &w[i__ + (i__ + 1) * w_dim1], mdw, &w[i__ + 1 + (i__ + 1)
* w_dim1], mdw, &sc, &ss);
/* L390: */
}
goto L430;
/* The triangularization is completed by giving up the Hessenberg */
/* form and triangularizing a rectangular matrix. */
L400:
dswap_(&mrows, &w[i__ * w_dim1 + 1], &c__1, &w[jbig * w_dim1 + 1], &c__1);
dswap_(&c__1, &ww[i__], &c__1, &ww[jbig], &c__1);
dswap_(&c__1, &x[i__], &c__1, &x[jbig], &c__1);
itemp = ibasis[i__];
ibasis[i__] = ibasis[jbig];
ibasis[jbig] = itemp;
jbig = i__;
i__3 = nsetb;
for (j = jbig; j <= i__3; ++j) {
i__8 = mrows;
for (i__ = j + 1; i__ <= i__8; ++i__) {
drotg_(&w[j + j * w_dim1], &w[i__ + j * w_dim1], &sc, &ss);
w[i__ + j * w_dim1] = 0.;
i__9 = *ncols - j + 1;
drot_(&i__9, &w[j + (j + 1) * w_dim1], mdw, &w[i__ + (j + 1) *
w_dim1], mdw, &sc, &ss);
/* L410: */
}
/* L420: */
}
/* See if the remaining coefficients are feasible. They should be */
/* because of the way MIN(ALPHA,BETA) was chosen. Any that are not */
/* feasible will be set to their bounds and appropriately translated. */
L430:
jdrop1 = 0;
jdrop2 = 0;
lgopr = 2;
goto L270;
/* Find a variable to become non-active. */
L120:
if (found) {
lgopr = 1;
goto L270;
}
/* Rescale and translate variables. */
igopr = 2;
L130:
dcopy_(&nsetb, &x[1], &c__1, &rw[1], &c__1);
dcopy_(ncols, &c_b185, &c__0, &x[1], &c__1);
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
jcol = (i__8 = ibasis[j], abs(i__8));
x[jcol] = rw[j] * (d__1 = scl[jcol], abs(d__1));
/* L140: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ibb[j] % 2 == 0) {
x[j] = bu[j] - x[j];
}
/* L150: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
jcol = ibasis[j];
if (jcol < 0) {
x[-jcol] = bl[-jcol] + x[-jcol];
}
/* L160: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (scl[j] < 0.) {
x[j] = -x[j];
}
/* L170: */
}
i__ = max(nsetb,mval);
i__3 = mrows - i__;
/* Computing MIN */
i__8 = i__ + 1;
*rnorm = dnrm2_(&i__3, &w[min(i__8,mrows) + (*ncols + 1) * w_dim1], &c__1)
;
if (igopr == 2) {
*mode = nsetb;
}
return 0;
} /* dbolsm_ */
/* DECK DEFCMN */
/* Subroutine */ int defcmn_(integer *ndata, doublereal *xdata, doublereal *
ydata, doublereal *sddata, integer *nord, integer *nbkpt, doublereal *
bkptin, integer *mdein, integer *mdeout, doublereal *coeff,
doublereal *bf, doublereal *xtemp, doublereal *ptemp, doublereal *
bkpt, doublereal *g, integer *mdg, doublereal *w, integer *mdw,
integer *lw)
{
/* System generated locals */
address a__1[4];
integer bf_dim1, bf_offset, g_dim1, g_offset, w_dim1, w_offset, i__1,
i__2[4], i__3;
doublereal d__1, d__2;
char ch__1[112];
/* Local variables */
static integer i__, l, n, nb, ip, ir, mt, np1;
static doublereal xval, xmin, xmax;
static integer irow;
static char xern1[8], xern2[8];
static integer idata;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static integer ileft;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dsort_(doublereal *, doublereal *,
integer *, integer *);
static doublereal dummy, rnorm;
static integer nordm1, nordp1;
extern /* Subroutine */ int dbndac_(doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *), dbndsl_(integer *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *), dfspvn_(doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *);
static integer intseq;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___7 = { 0, xern2, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE DEFCMN */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DEFC */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (EFCMN-S, DEFCMN-D) */
/* ***AUTHOR Hanson, R. J., (SNLA) */
/* ***DESCRIPTION */
/* This is a companion subprogram to DEFC( ). */
/* This subprogram does weighted least squares fitting of data by */
/* B-spline curves. */
/* The documentation for DEFC( ) has complete usage instructions. */
/* ***SEE ALSO DEFC */
/* ***ROUTINES CALLED DBNDAC, DBNDSL, DCOPY, DFSPVN, DSCAL, DSORT, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800801 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890618 Completely restructured and extensively revised (WRB & RWC) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 900604 DP version created from SP version. (RWC) */
/* ***END PROLOGUE DEFCMN */
/* ***FIRST EXECUTABLE STATEMENT DEFCMN */
/* Initialize variables and analyze input. */
/* Parameter adjustments */
--xdata;
--ydata;
--sddata;
bf_dim1 = *nord;
bf_offset = 1 + bf_dim1;
bf -= bf_offset;
--bkptin;
--coeff;
--xtemp;
--ptemp;
--bkpt;
g_dim1 = *mdg;
g_offset = 1 + g_dim1;
g -= g_offset;
w_dim1 = *mdw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
n = *nbkpt - *nord;
np1 = n + 1;
/* Initially set all output coefficients to zero. */
dcopy_(&n, &c_b2, &c__0, &coeff[1], &c__1);
*mdeout = -1;
if (*nord < 1 || *nord > 20) {
xermsg_("SLATEC", "DEFCMN", "IN DEFC, THE ORDER OF THE B-SPLINE MUST"
" BE 1 THRU 20.", &c__3, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)
53);
return 0;
}
if (*nbkpt < *nord << 1) {
xermsg_("SLATEC", "DEFCMN", "IN DEFC, THE NUMBER OF KNOTS MUST BE AT"
" LEAST TWICE THE B-SPLINE ORDER.", &c__4, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)71);
return 0;
}
if (*ndata < 0) {
xermsg_("SLATEC", "DEFCMN", "IN DEFC, THE NUMBER OF DATA POINTS MUST"
" BE NONNEGATIVE.", &c__5, &c__1, (ftnlen)6, (ftnlen)6, (
ftnlen)55);
return 0;
}
/* Computing 2nd power */
i__1 = *nord;
nb = (*nbkpt - *nord + 3) * (*nord + 1) + (*nbkpt + 1) * (*nord + 1) + (
max(*nbkpt,*ndata) << 1) + *nbkpt + i__1 * i__1;
if (*lw < nb) {
s_wsfi(&io___5);
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___7);
do_fio(&c__1, (char *)&(*lw), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 87, a__1[0] = "IN DEFC, INSUFFICIENT STORAGE FOR W(*). CH"
"ECK FORMULA THAT READS LW.GE. ... . NEED = ";
i__2[1] = 8, a__1[1] = xern1;
i__2[2] = 9, a__1[2] = " GIVEN = ";
i__2[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__2, &c__4, (ftnlen)112);
xermsg_("SLATEC", "DEFCMN", ch__1, &c__6, &c__1, (ftnlen)6, (ftnlen)6,
(ftnlen)112);
*mdeout = -1;
return 0;
}
if (*mdein != 1 && *mdein != 2) {
xermsg_("SLATEC", "DEFCMN", "IN DEFC, INPUT VALUE OF MDEIN MUST BE 1"
"-2.", &c__7, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)42);
return 0;
}
/* Sort the breakpoints. */
dcopy_(nbkpt, &bkptin[1], &c__1, &bkpt[1], &c__1);
dsort_(&bkpt[1], &dummy, nbkpt, &c__1);
/* Save interval containing knots. */
xmin = bkpt[*nord];
xmax = bkpt[np1];
nordm1 = *nord - 1;
nordp1 = *nord + 1;
/* Process least squares equations. */
/* Sort data and an array of pointers. */
dcopy_(ndata, &xdata[1], &c__1, &xtemp[1], &c__1);
i__1 = *ndata;
for (i__ = 1; i__ <= i__1; ++i__) {
ptemp[i__] = (doublereal) i__;
/* L100: */
}
if (*ndata > 0) {
dsort_(&xtemp[1], &ptemp[1], ndata, &c__2);
xmin = min(xmin,xtemp[1]);
/* Computing MAX */
d__1 = xmax, d__2 = xtemp[*ndata];
xmax = max(d__1,d__2);
}
/* Fix breakpoint array if needed. This should only involve very */
/* minor differences with the input array of breakpoints. */
i__1 = *nord;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MIN */
d__1 = bkpt[i__];
bkpt[i__] = min(d__1,xmin);
/* L110: */
}
i__1 = *nbkpt;
for (i__ = np1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = bkpt[i__];
bkpt[i__] = max(d__1,xmax);
/* L120: */
}
/* Initialize parameters of banded matrix processor, DBNDAC( ). */
mt = 0;
ip = 1;
ir = 1;
ileft = *nord;
intseq = 1;
i__1 = *ndata;
for (idata = 1; idata <= i__1; ++idata) {
/* Sorted indices are in PTEMP(*). */
l = (integer) ptemp[idata];
xval = xdata[l];
/* When interval changes, process equations in the last block. */
if (xval >= bkpt[ileft + 1]) {
i__3 = ileft - nordm1;
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &mt, &i__3);
mt = 0;
/* Move pointer up to have BKPT(ILEFT).LE.XVAL, ILEFT.LE.N. */
i__3 = n;
for (ileft = ileft; ileft <= i__3; ++ileft) {
if (xval < bkpt[ileft + 1]) {
goto L140;
}
if (*mdein == 2) {
/* Data is being sequentially accumulated. */
/* Transfer previously accumulated rows from W(*,*) to */
/* G(*,*) and process them. */
dcopy_(&nordp1, &w[intseq + w_dim1], mdw, &g[ir + g_dim1],
mdg);
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &c__1, &intseq)
;
++intseq;
}
/* L130: */
}
}
/* Obtain B-spline function value. */
L140:
dfspvn_(&bkpt[1], nord, &c__1, &xval, &ileft, &bf[bf_offset]);
/* Move row into place. */
irow = ir + mt;
++mt;
dcopy_(nord, &bf[bf_offset], &c__1, &g[irow + g_dim1], mdg);
g[irow + nordp1 * g_dim1] = ydata[l];
/* Scale data if uncertainty is nonzero. */
if (sddata[l] != 0.) {
d__1 = 1. / sddata[l];
dscal_(&nordp1, &d__1, &g[irow + g_dim1], mdg);
}
/* When staging work area is exhausted, process rows. */
if (irow == *mdg - 1) {
i__3 = ileft - nordm1;
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &mt, &i__3);
mt = 0;
}
/* L150: */
}
/* Process last block of equations. */
i__1 = ileft - nordm1;
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &mt, &i__1);
/* Finish processing any previously accumulated rows from W(*,*) */
/* to G(*,*). */
if (*mdein == 2) {
i__1 = np1;
for (i__ = intseq; i__ <= i__1; ++i__) {
dcopy_(&nordp1, &w[i__ + w_dim1], mdw, &g[ir + g_dim1], mdg);
i__3 = min(n,i__);
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &c__1, &i__3);
/* L160: */
}
}
/* Last call to adjust block positioning. */
dcopy_(&nordp1, &c_b2, &c__0, &g[ir + g_dim1], mdg);
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &c__1, &np1);
/* Transfer accumulated rows from G(*,*) to W(*,*) for */
/* possible later sequential accumulation. */
i__1 = np1;
for (i__ = 1; i__ <= i__1; ++i__) {
dcopy_(&nordp1, &g[i__ + g_dim1], mdg, &w[i__ + w_dim1], mdw);
/* L170: */
}
/* Solve for coefficients when possible. */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (g[i__ + g_dim1] == 0.) {
*mdeout = 2;
return 0;
}
/* L180: */
}
/* All the diagonal terms in the accumulated triangular */
/* matrix are nonzero. The solution can be computed but */
/* it may be unsuitable for further use due to poor */
/* conditioning or the lack of constraints. No checking */
/* for either of these is done here. */
dbndsl_(&c__1, &g[g_offset], mdg, nord, &ip, &ir, &coeff[1], &n, &rnorm);
*mdeout = 1;
return 0;
} /* defcmn_ */
/* DECK XSETF */
/* Subroutine */ int xsetf_(integer *kontrl)
{
/* System generated locals */
address a__1[2];
integer i__1[2];
char ch__1[27];
/* Builtin functions */
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer junk;
static char xern1[8];
extern integer j4save_(integer *, integer *, logical *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE XSETF */
/* ***PURPOSE Set the error control flag. */
/* ***LIBRARY SLATEC (XERROR) */
/* ***CATEGORY R3A */
/* ***TYPE ALL (XSETF-A) */
/* ***KEYWORDS ERROR, XERROR */
/* ***AUTHOR Jones, R. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* XSETF sets the error control flag value to KONTRL. */
/* (KONTRL is an input parameter only.) */
/* The following table shows how each message is treated, */
/* depending on the values of KONTRL and LEVEL. (See XERMSG */
/* for description of LEVEL.) */
/* If KONTRL is zero or negative, no information other than the */
/* message itself (including numeric values, if any) will be */
/* printed. If KONTRL is positive, introductory messages, */
/* trace-backs, etc., will be printed in addition to the message. */
/* ABS(KONTRL) */
/* LEVEL 0 1 2 */
/* value */
/* 2 fatal fatal fatal */
/* 1 not printed printed fatal */
/* 0 not printed printed printed */
/* -1 not printed printed printed */
/* only only */
/* once once */
/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */
/* Error-handling Package, SAND82-0800, Sandia */
/* Laboratories, 1982. */
/* ***ROUTINES CALLED J4SAVE, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 790801 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900510 Change call to XERRWV to XERMSG. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE XSETF */
/* ***FIRST EXECUTABLE STATEMENT XSETF */
if (abs(*kontrl) > 2) {
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*kontrl), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "INVALID ARGUMENT = ";
i__1[1] = 8, a__1[1] = xern1;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)27);
xermsg_("SLATEC", "XSETF", ch__1, &c__1, &c__2, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
junk = j4save_(&c__2, kontrl, &c_true);
return 0;
} /* xsetf_ */
/* DECK SGEIR */
/* Subroutine */ int sgeir_(real *a, integer *lda, integer *n, real *v,
integer *itask, integer *ind, real *work, integer *iwork)
{
/* System generated locals */
address a__1[4], a__2[3];
integer a_dim1, a_offset, work_dim1, work_offset, i__1[4], i__2[3], i__3;
real r__1, r__2, r__3;
char ch__1[40], ch__2[27], ch__3[31];
/* Local variables */
static integer j, info;
static char xern1[8], xern2[8];
extern /* Subroutine */ int sgefa_(real *, integer *, integer *, integer *
, integer *), sgesl_(real *, integer *, integer *, integer *,
real *, integer *);
static real dnorm;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real xnorm;
extern doublereal r1mach_(integer *), sdsdot_(integer *, real *, real *,
integer *, real *, integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE SGEIR */
/* ***PURPOSE Solve a general system of linear equations. Iterative */
/* refinement is used to obtain an error estimate. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY D2A1 */
/* ***TYPE SINGLE PRECISION (SGEIR-S, CGEIR-C) */
/* ***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, */
/* GENERAL SYSTEM OF LINEAR EQUATIONS */
/* ***AUTHOR Voorhees, E. A., (LANL) */
/* ***DESCRIPTION */
/* Subroutine SGEIR solves a general NxN system of single */
/* precision linear equations using LINPACK subroutines SGEFA and */
/* SGESL. One pass of iterative refinement is used only to obtain */
/* an estimate of the accuracy. That is, if A is an NxN real */
/* matrix and if X and B are real N-vectors, then SGEIR solves */
/* the equation */
/* A*X=B. */
/* The matrix A is first factored into upper and lower tri- */
/* angular matrices U and L using partial pivoting. These */
/* factors and the pivoting information are used to calculate */
/* the solution, X. Then the residual vector is found and */
/* used to calculate an estimate of the relative error, IND. */
/* IND estimates the accuracy of the solution only when the */
/* input matrix and the right hand side are represented */
/* exactly in the computer and does not take into account */
/* any errors in the input data. */
/* If the equation A*X=B is to be solved for more than one vector */
/* B, the factoring of A does not need to be performed again and */
/* the option to solve only (ITASK .GT. 1) will be faster for */
/* the succeeding solutions. In this case, the contents of A, */
/* LDA, N, WORK, and IWORK must not have been altered by the */
/* user following factorization (ITASK=1). IND will not be */
/* changed by SGEIR in this case. */
/* Argument Description *** */
/* A REAL(LDA,N) */
/* the doubly subscripted array with dimension (LDA,N) */
/* which contains the coefficient matrix. A is not */
/* altered by the routine. */
/* LDA INTEGER */
/* the leading dimension of the array A. LDA must be great- */
/* er than or equal to N. (terminal error message IND=-1) */
/* N INTEGER */
/* the order of the matrix A. The first N elements of */
/* the array A are the elements of the first column of */
/* matrix A. N must be greater than or equal to 1. */
/* (terminal error message IND=-2) */
/* V REAL(N) */
/* on entry, the singly subscripted array(vector) of di- */
/* mension N which contains the right hand side B of a */
/* system of simultaneous linear equations A*X=B. */
/* on return, V contains the solution vector, X . */
/* ITASK INTEGER */
/* If ITASK=1, the matrix A is factored and then the */
/* linear equation is solved. */
/* If ITASK .GT. 1, the equation is solved using the existing */
/* factored matrix A (stored in WORK). */
/* If ITASK .LT. 1, then terminal error message IND=-3 is */
/* printed. */
/* IND INTEGER */
/* GT. 0 IND is a rough estimate of the number of digits */
/* of accuracy in the solution, X. IND=75 means */
/* that the solution vector X is zero. */
/* LT. 0 see error message corresponding to IND below. */
/* WORK REAL(N*(N+1)) */
/* a singly subscripted array of dimension at least N*(N+1). */
/* IWORK INTEGER(N) */
/* a singly subscripted array of dimension at least N. */
/* Error Messages Printed *** */
/* IND=-1 terminal N is greater than LDA. */
/* IND=-2 terminal N is less than one. */
/* IND=-3 terminal ITASK is less than one. */
/* IND=-4 terminal The matrix A is computationally singular. */
/* A solution has not been computed. */
/* IND=-10 warning The solution has no apparent significance. */
/* The solution may be inaccurate or the matrix */
/* A may be poorly scaled. */
/* Note- The above terminal(*fatal*) error messages are */
/* designed to be handled by XERMSG in which */
/* LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 */
/* for warning error messages from XERMSG. Unless */
/* the user provides otherwise, an error message */
/* will be printed followed by an abort. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED R1MACH, SASUM, SCOPY, SDSDOT, SGEFA, SGESL, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800430 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE SGEIR */
/* ***FIRST EXECUTABLE STATEMENT SGEIR */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
--v;
--iwork;
/* Function Body */
if (*lda < *n) {
*ind = -1;
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 6, a__1[0] = "LDA = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " IS LESS THAN N = ";
i__1[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__1, &c__4, (ftnlen)40);
xermsg_("SLATEC", "SGEIR", ch__1, &c_n1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)40);
return 0;
}
if (*n <= 0) {
*ind = -2;
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__2[0] = "N = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)27);
xermsg_("SLATEC", "SGEIR", ch__2, &c_n2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
if (*itask < 1) {
*ind = -3;
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*itask), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 8, a__2[0] = "ITASK = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__3, a__2, i__2, &c__3, (ftnlen)31);
xermsg_("SLATEC", "SGEIR", ch__3, &c_n3, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)31);
return 0;
}
if (*itask == 1) {
/* MOVE MATRIX A TO WORK */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
scopy_(n, &a[j * a_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
c__1);
/* L10: */
}
/* FACTOR MATRIX A INTO LU */
sgefa_(&work[work_offset], n, n, &iwork[1], &info);
/* CHECK FOR COMPUTATIONALLY SINGULAR MATRIX */
if (info != 0) {
*ind = -4;
xermsg_("SLATEC", "SGEIR", "SINGULAR MATRIX A - NO SOLUTION", &
c_n4, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
}
}
/* SOLVE WHEN FACTORING COMPLETE */
/* MOVE VECTOR B TO WORK */
scopy_(n, &v[1], &c__1, &work[(*n + 1) * work_dim1 + 1], &c__1);
sgesl_(&work[work_offset], n, n, &iwork[1], &v[1], &c__0);
/* FORM NORM OF X0 */
xnorm = sasum_(n, &v[1], &c__1);
if (xnorm == 0.f) {
*ind = 75;
return 0;
}
/* COMPUTE RESIDUAL */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
r__1 = -work[j + (*n + 1) * work_dim1];
work[j + (*n + 1) * work_dim1] = sdsdot_(n, &r__1, &a[j + a_dim1],
lda, &v[1], &c__1);
/* L40: */
}
/* SOLVE A*DELTA=R */
sgesl_(&work[work_offset], n, n, &iwork[1], &work[(*n + 1) * work_dim1 +
1], &c__0);
/* FORM NORM OF DELTA */
dnorm = sasum_(n, &work[(*n + 1) * work_dim1 + 1], &c__1);
/* COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) */
/* AND CHECK FOR IND GREATER THAN ZERO */
/* Computing MAX */
r__2 = r1mach_(&c__4), r__3 = dnorm / xnorm;
r__1 = dmax(r__2,r__3);
*ind = -r_lg10(&r__1);
if (*ind <= 0) {
*ind = -10;
xermsg_("SLATEC", "SGEIR", "SOLUTION MAY HAVE NO SIGNIFICANCE", &
c_n10, &c__0, (ftnlen)6, (ftnlen)5, (ftnlen)33);
}
return 0;
} /* sgeir_ */
/* DECK DPLPDM */
/* Subroutine */ int dplpdm_(integer *mrelas, integer *nvars__, integer *lmx,
integer *lbm, integer *nredc, integer *info, integer *iopt, integer *
ibasis, integer *imat, integer *ibrc, integer *ipr, integer *iwr,
integer *ind, integer *ibb, doublereal *anorm, doublereal *eps,
doublereal *uu, doublereal *gg, doublereal *amat, doublereal *basmat,
doublereal *csc, doublereal *wr, logical *singlr, logical *redbas)
{
/* System generated locals */
address a__1[2];
integer ibrc_dim1, ibrc_offset, i__1, i__2[2];
char ch__1[55];
/* Local variables */
static integer i__, j, k;
static doublereal aij, one;
static integer nzbm;
static doublereal zero;
static char xern3[16];
extern /* Subroutine */ int la05ad_(doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer iplace;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen), dpnnzr_(integer *, doublereal
*, integer *, doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static icilist io___10 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
/* ***BEGIN PROLOGUE DPLPDM */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DSPLP */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SPLPDM-S, DPLPDM-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE. IT PERFORMS THE */
/* TASK OF DEFINING THE ENTRIES OF THE BASIS MATRIX AND */
/* DECOMPOSING IT USING THE LA05 PACKAGE. */
/* IT IS THE MAIN PART OF THE PROCEDURE (DECOMPOSE BASIS MATRIX). */
/* ***SEE ALSO DSPLP */
/* ***ROUTINES CALLED DASUM, DPNNZR, LA05AD, XERMSG */
/* ***COMMON BLOCKS LA05DD */
/* ***REVISION HISTORY (YYMMDD) */
/* 811215 DATE WRITTEN */
/* 890605 Added DASUM to list of DOUBLE PRECISION variables. */
/* 890605 Removed unreferenced labels. (WRB) */
/* 891009 Removed unreferenced variable. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls, convert do-it-yourself */
/* DO loops to DO loops. (RWC) */
/* ***END PROLOGUE DPLPDM */
/* COMMON BLOCK USED BY LA05 () PACKAGE.. */
/* ***FIRST EXECUTABLE STATEMENT DPLPDM */
/* Parameter adjustments */
ibrc_dim1 = *lbm;
ibrc_offset = 1 + ibrc_dim1;
ibrc -= ibrc_offset;
--ibasis;
--imat;
--ipr;
--iwr;
--ind;
--ibb;
--amat;
--basmat;
--csc;
--wr;
/* Function Body */
zero = 0.;
one = 1.;
/* DEFINE BASIS MATRIX BY COLUMNS FOR SPARSE MATRIX EQUATION SOLVER. */
/* THE LA05AD() SUBPROGRAM REQUIRES THE NONZERO ENTRIES OF THE MATRIX */
/* TOGETHER WITH THE ROW AND COLUMN INDICES. */
nzbm = 0;
/* DEFINE DEPENDENT VARIABLE COLUMNS. THESE ARE */
/* COLS. OF THE IDENTITY MATRIX AND IMPLICITLY GENERATED. */
i__1 = *mrelas;
for (k = 1; k <= i__1; ++k) {
j = ibasis[k];
if (j > *nvars__) {
++nzbm;
if (ind[j] == 2) {
basmat[nzbm] = one;
} else {
basmat[nzbm] = -one;
}
ibrc[nzbm + ibrc_dim1] = j - *nvars__;
ibrc[nzbm + (ibrc_dim1 << 1)] = k;
} else {
/* DEFINE THE INDEP. VARIABLE COLS. THIS REQUIRES RETRIEVING */
/* THE COLS. FROM THE SPARSE MATRIX DATA STRUCTURE. */
i__ = 0;
L10:
dpnnzr_(&i__, &aij, &iplace, &amat[1], &imat[1], &j);
if (i__ > 0) {
++nzbm;
basmat[nzbm] = aij * csc[j];
ibrc[nzbm + ibrc_dim1] = i__;
ibrc[nzbm + (ibrc_dim1 << 1)] = k;
goto L10;
}
}
/* L20: */
}
*singlr = FALSE_;
/* RECOMPUTE MATRIX NORM USING CRUDE NORM = SUM OF MAGNITUDES. */
*anorm = dasum_(&nzbm, &basmat[1], &c__1);
la05dd_1.small = *eps * *anorm;
/* GET AN L-U FACTORIZATION OF THE BASIS MATRIX. */
++(*nredc);
*redbas = TRUE_;
la05ad_(&basmat[1], &ibrc[ibrc_offset], &nzbm, lbm, mrelas, &ipr[1], &iwr[
1], &wr[1], gg, uu);
/* CHECK RETURN VALUE OF ERROR FLAG, GG. */
if (*gg >= zero) {
return 0;
}
if (*gg == -7.f) {
xermsg_("SLATEC", "DPLPDM", "IN DSPLP, SHORT ON STORAGE FOR LA05AD. "
" USE PRGOPT(*) TO GIVE MORE.", &c__28, iopt, (ftnlen)6, (
ftnlen)6, (ftnlen)67);
*info = -28;
} else if (*gg == -5.f) {
*singlr = TRUE_;
} else {
s_wsfi(&io___10);
do_fio(&c__1, (char *)&(*gg), (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__2[0] = 39, a__1[0] = "IN DSPLP, LA05AD RETURNED ERROR FLAG = ";
i__2[1] = 16, a__1[1] = xern3;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)55);
xermsg_("SLATEC", "DPLPDM", ch__1, &c__27, iopt, (ftnlen)6, (ftnlen)6,
(ftnlen)55);
*info = -27;
}
return 0;
} /* dplpdm_ */
/* Subroutine */ int sprtbg_(char *subnam, integer *ntypes, logical *dotype,
integer *nsizes, integer *nn, integer *inparm, char *pnames, integer *
nparms, integer *np1, integer *np2, integer *np3, integer *np4,
integer *np5, integer *np6, real *ops, integer *ldo1, integer *ldo2,
real *times, integer *ldt1, integer *ldt2, real *rwork, logical *
llwork, integer *nout, ftnlen subnam_len, ftnlen pnames_len)
{
/* Format strings */
static char fmt_9999[] = "(///\002 ****** Results for \002,a,\002 *****"
"*\002)";
static char fmt_9995[] = "(5x,:\002with \002,4(a,\002=\002,i5,:\002, "
"\002)/10x,2(a,\002=\002,i5,:\002, \002))";
static char fmt_9980[] = "(\002( 5X, : I5 , 6( \002,i2,\002X, I5, : ) "
")\002)";
static char fmt_9981[] = "(\002( 5X, : 'line ' , 6( \002,i2,\002X, A, : "
") )\002)";
static char fmt_9996[] = "(/\002 *** Time in seconds ***\002)";
static char fmt_9997[] = "(/\002 *** Number of floating-point operations"
" ***\002)";
static char fmt_9998[] = "(/\002 *** Speed in megaflops ***\002)";
/* System generated locals */
integer ops_dim1, ops_dim2, ops_offset, times_dim1, times_dim2,
times_offset, i__1, i__2, i__3;
/* Builtin functions */
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
i_len(char *, ftnlen), s_wsfi(icilist *), e_wsfi(void);
/* Local variables */
static integer ipar, i__, j, ipada, ipadi, iline, iinfo;
static logical ltemp;
static integer jp, js, jt;
static char frmata[40], frmati[40];
static integer ilines;
extern doublereal smflop_(real *, real *, integer *);
extern /* Subroutine */ int sprtbs_(char *, char *, integer *, logical *,
integer *, integer *, integer *, logical *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___6 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___7 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___8 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___10 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___11 = { 0, 0, 0, fmt_9995, 0 };
static icilist io___15 = { 0, frmati, 0, fmt_9980, 40, 1 };
static icilist io___18 = { 0, frmata, 0, fmt_9981, 40, 1 };
static cilist io___19 = { 0, 0, 0, frmata, 0 };
static cilist io___20 = { 0, 0, 0, frmati, 0 };
static cilist io___21 = { 0, 0, 0, frmati, 0 };
static cilist io___22 = { 0, 0, 0, frmati, 0 };
static cilist io___23 = { 0, 0, 0, frmati, 0 };
static cilist io___24 = { 0, 0, 0, frmati, 0 };
static cilist io___25 = { 0, 0, 0, frmati, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___33 = { 0, 0, 0, fmt_9998, 0 };
#define times_ref(a_1,a_2,a_3) times[((a_3)*times_dim2 + (a_2))*\
times_dim1 + a_1]
#define pnames_ref(a_0,a_1) &pnames[(a_1)*pnames_len + a_0]
#define ops_ref(a_1,a_2,a_3) ops[((a_3)*ops_dim2 + (a_2))*ops_dim1 + a_1]
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SPRTBG prints out timing information for the eigenvalue routines.
The table has NTYPES block rows and NSIZES columns, with NPARMS
individual rows in each block row. There are INPARM quantities
which depend on rows (currently, INPARM <= 4).
Arguments (none are modified)
=========
SUBNAM - CHARACTER*(*)
The label for the output.
NTYPES - INTEGER
The number of values of DOTYPE, and also the
number of sets of rows of the table.
DOTYPE - LOGICAL array of dimension( NTYPES )
If DOTYPE(j) is .TRUE., then block row j (which includes
data from RESLTS( i, j, k ), for all i and k) will be
printed. If DOTYPE(j) is .FALSE., then block row j will
not be printed.
NSIZES - INTEGER
The number of values of NN, and also the
number of columns of the table.
NN - INTEGER array of dimension( NSIZES )
The values of N used to label each column.
INPARM - INTEGER
The number of different parameters which are functions of
the row number. At the moment, INPARM <= 4.
PNAMES - CHARACTER*(*) array of dimension( INPARM )
The label for the columns.
NPARMS - INTEGER
The number of values for each "parameter", i.e., the
number of rows for each value of DOTYPE.
NP1 - INTEGER array of dimension( NPARMS )
The first quantity which depends on row number.
NP2 - INTEGER array of dimension( NPARMS )
The second quantity which depends on row number.
NP3 - INTEGER array of dimension( NPARMS )
The third quantity which depends on row number.
NP4 - INTEGER array of dimension( NPARMS )
The fourth quantity which depends on row number.
NP5 - INTEGER array of dimension( NPARMS )
The fifth quantity which depends on row number.
NP6 - INTEGER array of dimension( NPARMS )
The sixth quantity which depends on row number.
OPS - REAL array of dimension( LDT1, LDT2, NSIZES )
The operation counts. The first index indicates the row,
the second index indicates the block row, and the last
indicates the column.
LDO1 - INTEGER
The first dimension of OPS. It must be at least
min( 1, NPARMS ).
LDO2 - INTEGER
The second dimension of OPS. It must be at least
min( 1, NTYPES ).
TIMES - REAL array of dimension( LDT1, LDT2, NSIZES )
The times (in seconds). The first index indicates the row,
the second index indicates the block row, and the last
indicates the column.
LDT1 - INTEGER
The first dimension of RESLTS. It must be at least
min( 1, NPARMS ).
LDT2 - INTEGER
The second dimension of RESLTS. It must be at least
min( 1, NTYPES ).
RWORK - REAL array of dimension( NSIZES*NTYPES*NPARMS )
Real workspace.
Modified.
LLWORK - LOGICAL array of dimension( NPARMS )
Logical workspace. It is used to turn on or off specific
lines in the output. If LLWORK(i) is .TRUE., then row i
(which includes data from OPS(i,j,k) or TIMES(i,j,k) for
all j and k) will be printed. If LLWORK(i) is
.FALSE., then row i will not be printed.
Modified.
NOUT - INTEGER
The output unit number on which the table
is to be printed. If NOUT <= 0, no output is printed.
=====================================================================
First line
Parameter adjustments */
--dotype;
--nn;
pnames -= pnames_len;
--llwork;
--np1;
--np2;
--np3;
--np4;
--np5;
--np6;
ops_dim1 = *ldo1;
ops_dim2 = *ldo2;
ops_offset = 1 + ops_dim1 * (1 + ops_dim2 * 1);
ops -= ops_offset;
times_dim1 = *ldt1;
times_dim2 = *ldt2;
times_offset = 1 + times_dim1 * (1 + times_dim2 * 1);
times -= times_offset;
--rwork;
/* Function Body */
io___1.ciunit = *nout;
s_wsfe(&io___1);
do_fio(&c__1, subnam, subnam_len);
e_wsfe();
/* Set up which lines are to be printed. */
llwork[1] = TRUE_;
ilines = 1;
i__1 = *nparms;
for (ipar = 2; ipar <= i__1; ++ipar) {
llwork[ipar] = TRUE_;
i__2 = ipar - 1;
for (j = 1; j <= i__2; ++j) {
ltemp = FALSE_;
if (*inparm >= 1 && np1[j] != np1[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 2 && np2[j] != np2[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 3 && np3[j] != np3[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 4 && np4[j] != np4[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 5 && np5[j] != np5[ipar]) {
ltemp = TRUE_;
}
if (*inparm >= 6 && np6[j] != np6[ipar]) {
ltemp = TRUE_;
}
if (! ltemp) {
llwork[ipar] = FALSE_;
}
/* L10: */
}
if (llwork[ipar]) {
++ilines;
}
/* L20: */
}
if (ilines == 1) {
if (*inparm == 1) {
io___6.ciunit = *nout;
s_wsfe(&io___6);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 2) {
io___7.ciunit = *nout;
s_wsfe(&io___7);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 3) {
io___8.ciunit = *nout;
s_wsfe(&io___8);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 4) {
io___9.ciunit = *nout;
s_wsfe(&io___9);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 4), pnames_len);
do_fio(&c__1, (char *)&np4[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 5) {
io___10.ciunit = *nout;
s_wsfe(&io___10);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 4), pnames_len);
do_fio(&c__1, (char *)&np4[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 5), pnames_len);
do_fio(&c__1, (char *)&np5[1], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 6) {
io___11.ciunit = *nout;
s_wsfe(&io___11);
do_fio(&c__1, pnames_ref(0, 1), pnames_len);
do_fio(&c__1, (char *)&np1[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 2), pnames_len);
do_fio(&c__1, (char *)&np2[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 3), pnames_len);
do_fio(&c__1, (char *)&np3[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 4), pnames_len);
do_fio(&c__1, (char *)&np4[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 5), pnames_len);
do_fio(&c__1, (char *)&np5[1], (ftnlen)sizeof(integer));
do_fio(&c__1, pnames_ref(0, 6), pnames_len);
do_fio(&c__1, (char *)&np6[1], (ftnlen)sizeof(integer));
e_wsfe();
}
} else {
iline = 0;
/* Compute output format statement.
Computing MAX */
i__1 = i_len(pnames_ref(0, 1), pnames_len) - 3;
ipadi = max(i__1,1);
s_wsfi(&io___15);
do_fio(&c__1, (char *)&ipadi, (ftnlen)sizeof(integer));
e_wsfi();
ipada = ipadi + 5 - i_len(pnames_ref(0, 1), pnames_len);
s_wsfi(&io___18);
do_fio(&c__1, (char *)&ipada, (ftnlen)sizeof(integer));
e_wsfi();
io___19.ciunit = *nout;
s_wsfe(&io___19);
i__1 = min(6,*inparm);
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, pnames_ref(0, j), pnames_len);
}
e_wsfe();
i__1 = *nparms;
for (j = 1; j <= i__1; ++j) {
if (llwork[j]) {
++iline;
if (*inparm == 1) {
io___20.ciunit = *nout;
s_wsfe(&io___20);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 2) {
io___21.ciunit = *nout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 3) {
io___22.ciunit = *nout;
s_wsfe(&io___22);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 4) {
io___23.ciunit = *nout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np4[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 5) {
io___24.ciunit = *nout;
s_wsfe(&io___24);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np4[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np5[j], (ftnlen)sizeof(integer));
e_wsfe();
} else if (*inparm == 6) {
io___25.ciunit = *nout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&iline, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np1[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np2[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np3[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np4[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np5[j], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&np6[j], (ftnlen)sizeof(integer));
e_wsfe();
}
}
/* L30: */
}
}
/* Execution Times */
io___26.ciunit = *nout;
s_wsfe(&io___26);
e_wsfe();
sprtbs_("Type", "N ", ntypes, &dotype[1], nsizes, &nn[1], nparms, &llwork[
1], ×[times_offset], ldt1, ldt2, nout, (ftnlen)4, (ftnlen)2);
/* Operation Counts */
io___27.ciunit = *nout;
s_wsfe(&io___27);
e_wsfe();
sprtbs_("Type", "N ", ntypes, &dotype[1], nsizes, &nn[1], nparms, &llwork[
1], &ops[ops_offset], ldo1, ldo2, nout, (ftnlen)4, (ftnlen)2);
/* Megaflop Rates */
iinfo = 0;
i__1 = *nsizes;
for (js = 1; js <= i__1; ++js) {
i__2 = *ntypes;
for (jt = 1; jt <= i__2; ++jt) {
if (dotype[jt]) {
i__3 = *nparms;
for (jp = 1; jp <= i__3; ++jp) {
i__ = jp + *nparms * (jt - 1 + *ntypes * (js - 1));
rwork[i__] = smflop_(&ops_ref(jp, jt, js), ×_ref(jp,
jt, js), &iinfo);
/* L40: */
}
}
/* L50: */
}
/* L60: */
}
io___33.ciunit = *nout;
s_wsfe(&io___33);
e_wsfe();
sprtbs_("Type", "N ", ntypes, &dotype[1], nsizes, &nn[1], nparms, &llwork[
1], &rwork[1], nparms, ntypes, nout, (ftnlen)4, (ftnlen)2);
/* Format statements for generating format statements.
9981 generates a string 21+2+11=34 characters long.
9980 generates a string 16+2+12=30 characters long. */
return 0;
/* End of SPRTBG */
} /* sprtbg_ */
/* DECK CNBIR */
/* Subroutine */ int cnbir_(complex *abe, integer *lda, integer *n, integer *
ml, integer *mu, complex *v, integer *itask, integer *ind, complex *
work, integer *iwork)
{
/* System generated locals */
address a__1[4], a__2[3];
integer abe_dim1, abe_offset, work_dim1, work_offset, i__1[4], i__2[3],
i__3, i__4, i__5;
real r__1, r__2, r__3;
complex q__1, q__2;
char ch__1[40], ch__2[27], ch__3[31], ch__4[29];
/* Local variables */
static integer j, k, l, m, nc, kk, info;
static char xern1[8], xern2[8];
extern /* Subroutine */ int cnbfa_(complex *, integer *, integer *,
integer *, integer *, integer *, integer *), cnbsl_(complex *,
integer *, integer *, integer *, integer *, integer *, complex *,
integer *), ccopy_(integer *, complex *, integer *, complex *,
integer *);
static real dnorm, xnorm;
extern doublereal r1mach_(integer *);
extern /* Complex */ void cdcdot_(complex *, integer *, complex *,
complex *, integer *, complex *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___7 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE CNBIR */
/* ***PURPOSE Solve a general nonsymmetric banded system of linear */
/* equations. Iterative refinement is used to obtain an error */
/* estimate. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY D2C2 */
/* ***TYPE COMPLEX (SNBIR-S, CNBIR-C) */
/* ***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC */
/* ***AUTHOR Voorhees, E. A., (LANL) */
/* ***DESCRIPTION */
/* Subroutine CNBIR solves a general nonsymmetric banded NxN */
/* system of single precision complex linear equations using */
/* SLATEC subroutines CNBFA and CNBSL. These are adaptations */
/* of the LINPACK subroutines CGBFA and CGBSL which require */
/* a different format for storing the matrix elements. */
/* One pass of iterative refinement is used only to obtain an */
/* estimate of the accuracy. If A is an NxN complex banded */
/* matrix and if X and B are complex N-vectors, then CNBIR */
/* solves the equation */
/* A*X=B. */
/* A band matrix is a matrix whose nonzero elements are all */
/* fairly near the main diagonal, specifically A(I,J) = 0 */
/* if I-J is greater than ML or J-I is greater than */
/* MU . The integers ML and MU are called the lower and upper */
/* band widths and M = ML+MU+1 is the total band width. */
/* CNBIR uses less time and storage than the corresponding */
/* program for general matrices (CGEIR) if 2*ML+MU .LT. N . */
/* The matrix A is first factored into upper and lower tri- */
/* angular matrices U and L using partial pivoting. These */
/* factors and the pivoting information are used to find the */
/* solution vector X . Then the residual vector is found and used */
/* to calculate an estimate of the relative error, IND . IND esti- */
/* mates the accuracy of the solution only when the input matrix */
/* and the right hand side are represented exactly in the computer */
/* and does not take into account any errors in the input data. */
/* If the equation A*X=B is to be solved for more than one vector */
/* B, the factoring of A does not need to be performed again and */
/* the option to only solve (ITASK .GT. 1) will be faster for */
/* the succeeding solutions. In this case, the contents of A, LDA, */
/* N, WORK and IWORK must not have been altered by the user follow- */
/* ing factorization (ITASK=1). IND will not be changed by CNBIR */
/* in this case. */
/* Band Storage */
/* If A is a band matrix, the following program segment */
/* will set up the input. */
/* ML = (band width below the diagonal) */
/* MU = (band width above the diagonal) */
/* DO 20 I = 1, N */
/* J1 = MAX(1, I-ML) */
/* J2 = MIN(N, I+MU) */
/* DO 10 J = J1, J2 */
/* K = J - I + ML + 1 */
/* ABE(I,K) = A(I,J) */
/* 10 CONTINUE */
/* 20 CONTINUE */
/* This uses columns 1 through ML+MU+1 of ABE . */
/* Example: If the original matrix is */
/* 11 12 13 0 0 0 */
/* 21 22 23 24 0 0 */
/* 0 32 33 34 35 0 */
/* 0 0 43 44 45 46 */
/* 0 0 0 54 55 56 */
/* 0 0 0 0 65 66 */
/* then N = 6, ML = 1, MU = 2, LDA .GE. 5 and ABE should contain */
/* * 11 12 13 , * = not used */
/* 21 22 23 24 */
/* 32 33 34 35 */
/* 43 44 45 46 */
/* 54 55 56 * */
/* 65 66 * * */
/* Argument Description *** */
/* ABE COMPLEX(LDA,MM) */
/* on entry, contains the matrix in band storage as */
/* described above. MM must not be less than M = */
/* ML+MU+1 . The user is cautioned to dimension ABE */
/* with care since MM is not an argument and cannot */
/* be checked by CNBIR. The rows of the original */
/* matrix are stored in the rows of ABE and the */
/* diagonals of the original matrix are stored in */
/* columns 1 through ML+MU+1 of ABE . ABE is */
/* not altered by the program. */
/* LDA INTEGER */
/* the leading dimension of array ABE. LDA must be great- */
/* er than or equal to N. (terminal error message IND=-1) */
/* N INTEGER */
/* the order of the matrix A. N must be greater */
/* than or equal to 1 . (terminal error message IND=-2) */
/* ML INTEGER */
/* the number of diagonals below the main diagonal. */
/* ML must not be less than zero nor greater than or */
/* equal to N . (terminal error message IND=-5) */
/* MU INTEGER */
/* the number of diagonals above the main diagonal. */
/* MU must not be less than zero nor greater than or */
/* equal to N . (terminal error message IND=-6) */
/* V COMPLEX(N) */
/* on entry, the singly subscripted array(vector) of di- */
/* mension N which contains the right hand side B of a */
/* system of simultaneous linear equations A*X=B. */
/* on return, V contains the solution vector, X . */
/* ITASK INTEGER */
/* if ITASK=1, the matrix A is factored and then the */
/* linear equation is solved. */
/* if ITASK .GT. 1, the equation is solved using the existing */
/* factored matrix A and IWORK. */
/* if ITASK .LT. 1, then terminal error message IND=-3 is */
/* printed. */
/* IND INTEGER */
/* GT. 0 IND is a rough estimate of the number of digits */
/* of accuracy in the solution, X . IND=75 means */
/* that the solution vector X is zero. */
/* LT. 0 see error message corresponding to IND below. */
/* WORK COMPLEX(N*(NC+1)) */
/* a singly subscripted array of dimension at least */
/* N*(NC+1) where NC = 2*ML+MU+1 . */
/* IWORK INTEGER(N) */
/* a singly subscripted array of dimension at least N. */
/* Error Messages Printed *** */
/* IND=-1 terminal N is greater than LDA. */
/* IND=-2 terminal N is less than 1. */
/* IND=-3 terminal ITASK is less than 1. */
/* IND=-4 terminal The matrix A is computationally singular. */
/* A solution has not been computed. */
/* IND=-5 terminal ML is less than zero or is greater than */
/* or equal to N . */
/* IND=-6 terminal MU is less than zero or is greater than */
/* or equal to N . */
/* IND=-10 warning The solution has no apparent significance. */
/* The solution may be inaccurate or the matrix */
/* A may be poorly scaled. */
/* NOTE- The above terminal(*fatal*) error messages are */
/* designed to be handled by XERMSG in which */
/* LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 */
/* for warning error messages from XERMSG. Unless */
/* the user provides otherwise, an error message */
/* will be printed followed by an abort. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CCOPY, CDCDOT, CNBFA, CNBSL, R1MACH, SCASUM, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800819 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900510 Convert XERRWV calls to XERMSG calls, cvt GOTO's to */
/* IF-THEN-ELSE. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CNBIR */
/* ***FIRST EXECUTABLE STATEMENT CNBIR */
/* Parameter adjustments */
abe_dim1 = *lda;
abe_offset = 1 + abe_dim1;
abe -= abe_offset;
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
--v;
--iwork;
/* Function Body */
if (*lda < *n) {
*ind = -1;
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 6, a__1[0] = "LDA = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " IS LESS THAN N = ";
i__1[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__1, &c__4, (ftnlen)40);
xermsg_("SLATEC", "CNBIR", ch__1, &c_n1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)40);
return 0;
}
if (*n <= 0) {
*ind = -2;
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__2[0] = "N = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)27);
xermsg_("SLATEC", "CNBIR", ch__2, &c_n2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
if (*itask < 1) {
*ind = -3;
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*itask), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 8, a__2[0] = "ITASK = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__3, a__2, i__2, &c__3, (ftnlen)31);
xermsg_("SLATEC", "CNBIR", ch__3, &c_n3, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)31);
return 0;
}
if (*ml < 0 || *ml >= *n) {
*ind = -5;
s_wsfi(&io___7);
do_fio(&c__1, (char *)&(*ml), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 5, a__2[0] = "ML = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 16, a__2[2] = " IS OUT OF RANGE";
s_cat(ch__4, a__2, i__2, &c__3, (ftnlen)29);
xermsg_("SLATEC", "CNBIR", ch__4, &c_n5, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)29);
return 0;
}
if (*mu < 0 || *mu >= *n) {
*ind = -6;
s_wsfi(&io___8);
do_fio(&c__1, (char *)&(*mu), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 5, a__2[0] = "MU = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 16, a__2[2] = " IS OUT OF RANGE";
s_cat(ch__4, a__2, i__2, &c__3, (ftnlen)29);
xermsg_("SLATEC", "CNBIR", ch__4, &c_n6, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)29);
return 0;
}
nc = (*ml << 1) + *mu + 1;
if (*itask == 1) {
/* MOVE MATRIX ABE TO WORK */
m = *ml + *mu + 1;
i__3 = m;
for (j = 1; j <= i__3; ++j) {
ccopy_(n, &abe[j * abe_dim1 + 1], &c__1, &work[j * work_dim1 + 1],
&c__1);
/* L10: */
}
/* FACTOR MATRIX A INTO LU */
cnbfa_(&work[work_offset], n, n, ml, mu, &iwork[1], &info);
/* CHECK FOR COMPUTATIONALLY SINGULAR MATRIX */
if (info != 0) {
*ind = -4;
xermsg_("SLATEC", "CNBIR", "SINGULAR MATRIX A - NO SOLUTION", &
c_n4, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
}
}
/* SOLVE WHEN FACTORING COMPLETE */
/* MOVE VECTOR B TO WORK */
ccopy_(n, &v[1], &c__1, &work[(nc + 1) * work_dim1 + 1], &c__1);
cnbsl_(&work[work_offset], n, n, ml, mu, &iwork[1], &v[1], &c__0);
/* FORM NORM OF X0 */
xnorm = scasum_(n, &v[1], &c__1);
if (xnorm == 0.f) {
*ind = 75;
return 0;
}
/* COMPUTE RESIDUAL */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
i__4 = 1, i__5 = *ml + 2 - j;
k = max(i__4,i__5);
/* Computing MAX */
i__4 = 1, i__5 = j - *ml;
kk = max(i__4,i__5);
/* Computing MIN */
i__4 = j - 1;
/* Computing MIN */
i__5 = *n - j;
l = min(i__4,*ml) + min(i__5,*mu) + 1;
i__4 = j + (nc + 1) * work_dim1;
i__5 = j + (nc + 1) * work_dim1;
q__2.r = -work[i__5].r, q__2.i = -work[i__5].i;
cdcdot_(&q__1, &l, &q__2, &abe[j + k * abe_dim1], lda, &v[kk], &c__1);
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L40: */
}
/* SOLVE A*DELTA=R */
cnbsl_(&work[work_offset], n, n, ml, mu, &iwork[1], &work[(nc + 1) *
work_dim1 + 1], &c__0);
/* FORM NORM OF DELTA */
dnorm = scasum_(n, &work[(nc + 1) * work_dim1 + 1], &c__1);
/* COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) */
/* AND CHECK FOR IND GREATER THAN ZERO */
/* Computing MAX */
r__2 = r1mach_(&c__4), r__3 = dnorm / xnorm;
r__1 = dmax(r__2,r__3);
*ind = -r_lg10(&r__1);
if (*ind <= 0) {
*ind = -10;
xermsg_("SLATEC", "CNBIR", "SOLUTION MAY HAVE NO SIGNIFICANCE", &
c_n10, &c__0, (ftnlen)6, (ftnlen)5, (ftnlen)33);
}
return 0;
} /* cnbir_ */
/* Subroutine */ int bnpedt_(char *dirnam, integer *iout, integer *iprn, char
*memnam, integer *ngc, integer *nowstp, integer *ntnuc, integer *nzon,
char *case__, char *stdnuc, char *title, char *mtnm, integer *mtyp,
real *voldpz, real *days, real *expst, real *u235f, real *akeff, real
*akinf, real *crins, real *crint, real *powerl, real *flxnrm, real *
powrzn, real *expszn, real *hminv, real *rlht, real *ydxe, real *ydi0,
real *ydsm, real *ydpm, char *nuclid, real *densty, real *sigxe,
real *sigi0, real *sigsm, real *sigpm, ftnlen dirnam_len, ftnlen
memnam_len, ftnlen case_len, ftnlen stdnuc_len, ftnlen title_len,
ftnlen mtnm_len, ftnlen nuclid_len)
{
/* Format strings */
static char fmt_7000[] = "(\002 \002,\002BNPEDT\002,114(\002=\002))";
static char fmt_6000[] = "(/\002 BNUP-STEP \002,10(5x,i2,5x):/(12x,10(5"
"x,i2,5x)))";
static char fmt_6010[] = "(\002 DAYS \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6020[] = "(\002 MWD/TON \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6030[] = "(1x,a3,\002-%\002,6x,1p10e12.5:/(12x,1p10e12.5"
"))";
static char fmt_6040[] = "(\002 K-EFF \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6050[] = "(\002 K-INF \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6060[] = "(\002 INS.-CR \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6070[] = "(\002 INT.-CR \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6080[] = "(\002 POWER(MW) \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6090[] = "(\002 FLX-NORM. \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6200[] = "(\002 ABS./CC \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6210[] = "(\002 MWD/TON \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6220[] = "(\002 POW(MW/CC) \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6230[] = "(\002 HM-TON/CC \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6240[] = "(\002 J-ENG/FIS. \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6250[] = "(\002 XE-135 YD \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6260[] = "(\002 I -135 YD \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6270[] = "(\002 SM-149 YD \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6280[] = "(\002 PM-149 YD \002,1p10e12.5:/(12x,1p10e12."
"5))";
static char fmt_6300[] = "(/\002 BNUP-STEP \002,10(5x,i2,5x):/(12x,10(5"
"x,i2,5x)))";
static char fmt_6310[] = "(1x,3(\002-\002),2x,4(\002-\002),1x,11(1x,10"
"(\002-\002)))";
static char fmt_6320[] = "(1x,i3,2x,a4,1x,1p11e11.4:/(11x,1p11e11.4))";
static char fmt_6330[] = "(1x,\002STEP:\002,i3,2x,1p10e11.4:/(11x,1p10e1"
"1.4))";
static char fmt_7010[] = "(\002 \002,114(\002=\002),\002BNPEDT\002)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
icilist ici__1;
/* Builtin functions */
integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
, s_wsfe(cilist *), e_wsfe(void);
/* Local variables */
static integer i__, j, k, ig, ii, jj, irc, izn, leng, ipos, nzst;
extern /* Subroutine */ int pdsin_(char *, char *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
#define iwork ((integer *)&wkpds_1)
static char member[8];
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, 0, 0 };
static cilist io___3 = { 0, 6, 0, 0, 0 };
static cilist io___4 = { 0, 0, 0, 0, 0 };
static cilist io___5 = { 0, 6, 0, 0, 0 };
static cilist io___7 = { 0, 0, 0, 0, 0 };
static cilist io___8 = { 0, 6, 0, 0, 0 };
static cilist io___12 = { 0, 0, 0, 0, 0 };
static cilist io___13 = { 0, 6, 0, 0, 0 };
static cilist io___14 = { 0, 0, 0, 0, 0 };
static cilist io___15 = { 0, 6, 0, 0, 0 };
static cilist io___17 = { 0, 0, 0, 0, 0 };
static cilist io___18 = { 0, 6, 0, 0, 0 };
static cilist io___19 = { 0, 0, 0, 0, 0 };
static cilist io___20 = { 0, 6, 0, 0, 0 };
static cilist io___21 = { 0, 0, 0, 0, 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___28 = { 0, 0, 0, 0, 0 };
static cilist io___29 = { 0, 6, 0, 0, 0 };
static cilist io___30 = { 0, 0, 0, 0, 0 };
static cilist io___31 = { 0, 0, 0, fmt_7000, 0 };
static cilist io___32 = { 0, 0, 0, 0, 0 };
static cilist io___33 = { 0, 0, 0, 0, 0 };
static cilist io___34 = { 0, 0, 0, 0, 0 };
static cilist io___35 = { 0, 0, 0, "(1X,A,A)", 0 };
static cilist io___36 = { 0, 0, 0, "(1X,A,A)", 0 };
static cilist io___37 = { 0, 0, 0, "(1X,A,I3)", 0 };
static cilist io___38 = { 0, 0, 0, "(1X,A,I3)", 0 };
static cilist io___39 = { 0, 0, 0, "(1X,A,I3)", 0 };
static cilist io___40 = { 0, 0, 0, 0, 0 };
static cilist io___41 = { 0, 0, 0, fmt_6000, 0 };
static cilist io___42 = { 0, 0, 0, fmt_6010, 0 };
static cilist io___43 = { 0, 0, 0, fmt_6020, 0 };
static cilist io___44 = { 0, 0, 0, fmt_6030, 0 };
static cilist io___45 = { 0, 0, 0, fmt_6040, 0 };
static cilist io___46 = { 0, 0, 0, fmt_6050, 0 };
static cilist io___47 = { 0, 0, 0, fmt_6060, 0 };
static cilist io___48 = { 0, 0, 0, fmt_6070, 0 };
static cilist io___49 = { 0, 0, 0, fmt_6080, 0 };
static cilist io___50 = { 0, 0, 0, fmt_6090, 0 };
static cilist io___51 = { 0, 0, 0, 0, 0 };
static cilist io___53 = { 0, 0, 0, 0, 0 };
static cilist io___54 = { 0, 0, 0, 0, 0 };
static cilist io___55 = { 0, 0, 0, fmt_6000, 0 };
static cilist io___56 = { 0, 0, 0, fmt_6200, 0 };
static cilist io___57 = { 0, 0, 0, fmt_6210, 0 };
static cilist io___58 = { 0, 0, 0, fmt_6220, 0 };
static cilist io___59 = { 0, 0, 0, fmt_6230, 0 };
static cilist io___60 = { 0, 0, 0, fmt_6240, 0 };
static cilist io___61 = { 0, 0, 0, fmt_6250, 0 };
static cilist io___62 = { 0, 0, 0, fmt_6260, 0 };
static cilist io___63 = { 0, 0, 0, fmt_6270, 0 };
static cilist io___64 = { 0, 0, 0, fmt_6280, 0 };
static cilist io___65 = { 0, 0, 0, "(/A)", 0 };
static cilist io___66 = { 0, 0, 0, fmt_6300, 0 };
static cilist io___67 = { 0, 0, 0, fmt_6310, 0 };
static cilist io___68 = { 0, 0, 0, fmt_6320, 0 };
static cilist io___69 = { 0, 0, 0, "(/A)", 0 };
static cilist io___71 = { 0, 0, 0, fmt_6330, 0 };
static cilist io___72 = { 0, 0, 0, "(/A)", 0 };
static cilist io___73 = { 0, 0, 0, fmt_6330, 0 };
static cilist io___74 = { 0, 0, 0, "(/A)", 0 };
static cilist io___75 = { 0, 0, 0, fmt_6330, 0 };
static cilist io___76 = { 0, 0, 0, "(/A)", 0 };
static cilist io___77 = { 0, 0, 0, fmt_6330, 0 };
static cilist io___78 = { 0, 0, 0, 0, 0 };
static cilist io___79 = { 0, 0, 0, 0, 0 };
static cilist io___80 = { 0, 0, 0, fmt_7010, 0 };
static cilist io___81 = { 0, 0, 0, 0, 0 };
/* =========================== FOR MAIN ================================== */
/* DEL PARAMETER (MAXNGC=20, MAXSTP=35, MAXNUC=110) */
/* DEL PARAMETER (MAXZN=50) */
/* PARAMETER DEFINISION FOR PDSMDL */
/* ------------------------------------------------------------------ */
/* PARAMETER MEANING RECOMMENDED */
/* NAME MEANING DEFAULT VALUE */
/* ------------------------------------------------------------------ */
/* MAXNG MAXIMUM FINE ENERGY GROUPS 107 */
/* MAXNGC MAXIMUM CONDENSED ENERGY GROUPS 20 */
/* MAXSTP MAXIMUM BURNUP STEPS 35 */
/* MAXNUC MAXIMUM BURNABLE NUCLIDES IN CHAIN 110 */
/* MAXZN MAXIMUM BURNABLE ZONES 50 */
/* MAXNR MAXIMUM R-REGIONS 300 */
/* MAXXS MAXIMUM XS-TYPES 10 */
/* MAXUP MAXIMUM UP-SCATTERING GROUPS 48 */
/* MAXWRK MAXIMUM LENGTH OF A PDS MEMBER 200000 */
/* ------------------------------------------------------------------ */
/* ------------------------------------------------------------------ */
/* ======================================================================= */
/* DEL PARAMETER (MAXWRK=100000) */
/* -------------------------------INPUT----------------------------------- */
/* DIRNAM : DIRECTORY NAME (A72) OF PDS : /XXX/XXX/MACRO01 */
/* IOUT : LOGICAL DEVICE FOR OUTPUT */
/* IPRN : =0(NO PRINT), =1(PRINT OUT IN DEVICE IOUT) */
/* MEMNAM : PDS MEMBER NAME TO EDIT(A8): ____BNUP */
/* NGC : NUMBER OF CONDENSED ENERGY GROUPS */
/* -------------------------------OUTPUT---------------------------------- */
/* NOWSTP : NUMBER OF BURNUP STEPS INCLUDING THE INITIAL STEP */
/* NOWSTP = 1 + NEP(INPUT IN BURNUP) */
/* NTNUC : TOTAL NUMBER OF DEPLETING NUCLIDES */
/* NZON : TOTAL NUMBER OF DEPLETING ZONE(=MATERIAL REGION) */
/* CASE : CASE IDENTIFICATION (A4) */
/* STDNUC : STANDARD NUCLIDE NAME (A4) TO INDICATE FRACTIONAL */
/* BURNED DENSITY (%), DEFALT:XU05 */
/* TITLE : COMMENT (A72) */
/* MTNM(I) : MATERIAL NAME (A4) BY DEPLETING ZONE, I=1...NZON */
/* THE FIRST 4-CHARACTERS OF THE MATERIAL NAME IN INPUT */
/* MTYP(I) : MATERIAL TYPE BY DEPLETING ZONE, I=1...NZON */
/* (=1:FISSILE & BURNABLE, =2:NOT FISSILE BUT BURNABLE) */
/* VOLDPZ(I) : VOLUME OF DEPLETING ZONE(I) (CC) */
/* NUCLID(K) : K-TH DEPLETING NUCLIDE NAME (A4), K=1....NTNUC */
/* EX. XU05,XPU9 */
/* DAYS(J) : ACCUMULATED BURNUP PERIOD (DAYS) BY STEP(J) */
/* EXPST(J) : ACCUMULATED BURNUP (MWD/T) BY STEP(J) */
/* U235F(J) : FRACTIONAL BURNED DENSITY OF STDNUC (%) */
/* AKEFF(J) : K-EFF BY STEP(J) */
/* AKINF(J) : K-INF BY STEP(J) */
/* CRINS(J) : INSTANTANEOUS CONVERSION RATIO BY STEP(J) */
/* CRINT(J) : INTEGRATED CONVERSION RATIO BY STEP(J) */
/* POWERL(J) : TOTAL POWER IN A UNIT-LENGTH(CM) LATTICE (MWT) */
/* FLXNRM(J) : NORMALIZATION FACTOR OF FLUX LEVEL BY STEP(J) */
/* POWRZN(J,I) : POWER DENSITY (W/CM3) BY STEP(J), ZONE(I) */
/* EXPSZN(J,I) : ACCUMULATED BURNUP (MWD/T) BY STEP(J), ZONE(I) */
/* IF MTYP(I)=2 => ACCUMULATED ABSORPTION RATE(ABS/CM3) */
/* HMINV(J,I) : HEAVY METAL DENSITY (TON/CC) BY STEP(J), ZONE(I) */
/* RLHT(J,I) : RELEASED ENERGY/FISSION (J/FISS) BY STEP(J), ZONE(I) */
/* YDXE(J,I) : FISSION YIELD OF XE-135 BY STEP(J), ZONE(I) */
/* YDI0(J,I) : FISSION YIELD OF I-135 BY STEP(J), ZONE(I) */
/* YDSM(J,I) : FISSION YIELD OF SM-149 BY STEP(J), ZONE(I) */
/* YDPM(J,I) : FISSION YIELD OF PM-149 BY STEP(J), ZONE(I) */
/* DENSTY(J,K,I): DENSITY OF NUCLIDE(K) BY STEP(J), ZONE(I) */
/* SIGXE(G,J,I) : MICRO ABSORPTION XS OF XE-135 IN GROUP(G) BY STEP(J) */
/* BY ZONE(I) */
/* SIGI0(G,J,I) : MICRO ABSORPTION XS OF I-135 IN GROUP(G) BY STEP(J) */
/* BY ZONE(I) */
/* SIGSM(G,J,I) : MICRO ABSORPTION XS OF SM-149 IN GROUP(G) BY STEP(J) */
/* BY ZONE(I) */
/* SIGPM(G,J,I) : MICRO ABSORPTION XS OF PM-149 IN GROUP(G) BY STEP(J) */
/* BY ZONE(I) */
/* ----------------------------------------------------------------------- */
/* ************* */
/* ZERO SET *--------------------------------------------------------- */
/* ************* */
/* Parameter adjustments */
sigpm -= 721;
sigsm -= 721;
sigi0 -= 721;
sigxe -= 721;
densty -= 5286;
nuclid -= 4;
ydpm -= 36;
ydsm -= 36;
ydi0 -= 36;
ydxe -= 36;
rlht -= 36;
hminv -= 36;
expszn -= 36;
powrzn -= 36;
--flxnrm;
--powerl;
--crint;
--crins;
--akinf;
--akeff;
--u235f;
--expst;
--days;
--voldpz;
--mtyp;
mtnm -= 4;
/* Function Body */
if (*ngc > 20) {
io___2.ciunit = *iout;
s_wsle(&io___2);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): NUMBER OF ENERGY GROUPS(=", (
ftnlen)41);
do_lio(&c__3, &c__1, (char *)&(*ngc), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)33);
do_lio(&c__3, &c__1, (char *)&c__20, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
if (*iout != 6) {
s_wsle(&io___3);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): NUMBER OF ENERGY GROUPS(=",
(ftnlen)41);
do_lio(&c__3, &c__1, (char *)&(*ngc), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)
33);
do_lio(&c__3, &c__1, (char *)&c__20, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
}
s_stop("", (ftnlen)0);
}
if (*ngc <= 0) {
io___4.ciunit = *iout;
s_wsle(&io___4);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): NUMBER OF ENERGY GROUPS(=", (
ftnlen)41);
do_lio(&c__3, &c__1, (char *)&(*ngc), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS INVALID", (ftnlen)12);
e_wsle();
if (*iout != 6) {
s_wsle(&io___5);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): NUMBER OF ENERGY GROUPS(=",
(ftnlen)41);
do_lio(&c__3, &c__1, (char *)&(*ngc), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS INVALID", (ftnlen)12);
e_wsle();
}
s_stop("", (ftnlen)0);
}
for (i__ = 1; i__ <= 200000; ++i__) {
wkpds_1.work[i__ - 1] = 0.f;
/* L10: */
}
if (s_cmp(memnam + 4, "BNUP", (ftnlen)4, (ftnlen)4) != 0) {
io___7.ciunit = *iout;
s_wsle(&io___7);
do_lio(&c__9, &c__1, " CAUTION(BNPEDT): THE LAST 4 CHARACTER IS NOT",
(ftnlen)45);
do_lio(&c__9, &c__1, " BNUP , MEMBER NAME = ", (ftnlen)22);
do_lio(&c__9, &c__1, memnam, (ftnlen)8);
e_wsle();
if (*iout != 6) {
s_wsle(&io___8);
do_lio(&c__9, &c__1, " CAUTION(BNPEDT): THE LAST 4 CHARACTER IS "
"NOT", (ftnlen)45);
do_lio(&c__9, &c__1, " BNUP , MEMBER NAME = ", (ftnlen)22);
do_lio(&c__9, &c__1, memnam, (ftnlen)8);
e_wsle();
}
}
/* ************************** */
/* ----BNUP DATA EDIT *--------------------------------------------- */
/* ************************** */
s_copy(member, memnam, (ftnlen)8, (ftnlen)8);
pdsin_(dirnam, member, wkpds_1.work, &leng, &irc, iout, (ftnlen)72, (
ftnlen)8);
if (irc != 0) {
io___12.ciunit = *iout;
s_wsle(&io___12);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): PDSIN ERROR, CODE=", (ftnlen)34)
;
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
if (*iout != 6) {
s_wsle(&io___13);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): PDSIN ERROR, CODE=", (
ftnlen)34);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
}
s_stop("", (ftnlen)0);
}
if (leng > 200000) {
io___14.ciunit = *iout;
s_wsle(&io___14);
do_lio(&c__9, &c__1, " ERROR(BNPEDT):REQUIRED WORK SIZE(=", (ftnlen)
35);
do_lio(&c__3, &c__1, (char *)&leng, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)33);
do_lio(&c__3, &c__1, (char *)&c_b85, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
if (*iout != 6) {
s_wsle(&io___15);
do_lio(&c__9, &c__1, " ERROR(BNPEDT):REQUIRED WORK SIZE(=", (
ftnlen)35);
do_lio(&c__3, &c__1, (char *)&leng, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)
33);
do_lio(&c__3, &c__1, (char *)&c_b85, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
}
s_stop("", (ftnlen)0);
}
/* ------ 1:NOWSTP, 2:NTNUC, 3:NZON ----------------------------- */
*nowstp = iwork[0];
*ntnuc = iwork[1];
*nzon = iwork[2];
ipos = 10;
if (*nowstp > 35) {
io___17.ciunit = *iout;
s_wsle(&io___17);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): NUMBER OF BURNUP STEP(=", (
ftnlen)39);
do_lio(&c__3, &c__1, (char *)&(*nowstp), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)33);
do_lio(&c__3, &c__1, (char *)&c__35, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
if (*iout != 6) {
s_wsle(&io___18);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): NUMBER OF BURNUP STEP(=", (
ftnlen)39);
do_lio(&c__3, &c__1, (char *)&(*nowstp), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)
33);
do_lio(&c__3, &c__1, (char *)&c__35, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
}
s_stop("", (ftnlen)0);
}
if (*ntnuc > 150) {
io___19.ciunit = *iout;
s_wsle(&io___19);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): NUMBER OF DEP. NUCLIDES(=", (
ftnlen)41);
do_lio(&c__3, &c__1, (char *)&(*ntnuc), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)33);
do_lio(&c__3, &c__1, (char *)&c__150, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
if (*iout != 6) {
s_wsle(&io___20);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): NUMBER OF DEP. NUCLIDES(=",
(ftnlen)41);
do_lio(&c__3, &c__1, (char *)&(*ntnuc), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)
33);
do_lio(&c__3, &c__1, (char *)&c__150, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
}
s_stop("", (ftnlen)0);
}
if (*nzon > 50) {
io___21.ciunit = *iout;
s_wsle(&io___21);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): NUMBER OF DEP. ZONE(=", (ftnlen)
37);
do_lio(&c__3, &c__1, (char *)&(*nzon), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)33);
do_lio(&c__3, &c__1, (char *)&c__50, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
if (*iout != 6) {
s_wsle(&io___22);
do_lio(&c__9, &c__1, " ERROR(BNPEDT): NUMBER OF DEP. ZONE(=", (
ftnlen)37);
do_lio(&c__3, &c__1, (char *)&(*nzon), (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS GREATER THAN THE SET VALUE(=", (ftnlen)
33);
do_lio(&c__3, &c__1, (char *)&c__50, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
}
s_stop("", (ftnlen)0);
}
/* ------ 11:CASE, 12:STDNUC, 13:TITLE ---------------- */
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 4;
ici__1.iciunit = case__;
ici__1.icifmt = "(A4)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&iwork[ipos], (ftnlen)sizeof(integer));
e_wsfi();
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 4;
ici__1.iciunit = stdnuc;
ici__1.icifmt = "(A4)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&iwork[ipos + 1], (ftnlen)sizeof(integer));
e_wsfi();
ipos += 2;
for (i__ = 1; i__ <= 18; ++i__) {
ii = (i__ - 1 << 2) + 1;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 4;
ici__1.iciunit = title + (ii - 1);
ici__1.icifmt = "(A4)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&iwork[ipos + i__ - 1], (ftnlen)sizeof(integer))
;
e_wsfi();
/* L100: */
}
ipos += 18;
/* ------ 14:MTNM, 15:MTYP, 16:VOLDPZ -------------------------- */
i__1 = *nzon;
for (i__ = 1; i__ <= i__1; ++i__) {
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 4;
ici__1.iciunit = mtnm + (i__ << 2);
ici__1.icifmt = "(A4)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&iwork[ipos + i__ - 1], (ftnlen)sizeof(integer))
;
e_wsfi();
mtyp[i__] = iwork[ipos + *nzon + i__ - 1];
voldpz[i__] = wkpds_1.work[ipos + (*nzon << 1) + i__ - 1];
/* L110: */
}
ipos += *nzon * 3;
/* ------ 17:NUCLID ----------------------------------- */
i__1 = *ntnuc;
for (k = 1; k <= i__1; ++k) {
++ipos;
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 4;
ici__1.iciunit = nuclid + (k << 2);
ici__1.icifmt = "(A4)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&iwork[ipos - 1], (ftnlen)sizeof(integer));
e_wsfi();
/* L120: */
}
/* ------ 18:DAYS, 19:EXPST, 20:U235F, 21:AKEFF, 22:AKINF */
/* 23:CRINS, 24:CRINT, 25:POWERL, 26:FLXNRM ------------------ */
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
days[j] = wkpds_1.work[ipos + j - 1];
expst[j] = wkpds_1.work[ipos + *nowstp + j - 1];
u235f[j] = wkpds_1.work[ipos + (*nowstp << 1) + j - 1];
akeff[j] = wkpds_1.work[ipos + *nowstp * 3 + j - 1];
akinf[j] = wkpds_1.work[ipos + (*nowstp << 2) + j - 1];
crins[j] = wkpds_1.work[ipos + *nowstp * 5 + j - 1];
crint[j] = wkpds_1.work[ipos + *nowstp * 6 + j - 1];
powerl[j] = wkpds_1.work[ipos + *nowstp * 7 + j - 1];
flxnrm[j] = wkpds_1.work[ipos + (*nowstp << 3) + j - 1];
/* L130: */
}
ipos += *nowstp * 9;
/* ------ 27:POWRZN, 28:EXPSZN, 29:HMINV, 30:RLHT, 31:YDXE, */
/* 32:YDI0, 33:YDSM, 34:YDPM --------------------------------- */
nzst = *nzon * *nowstp;
i__1 = *nzon;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *nowstp;
for (j = 1; j <= i__2; ++j) {
powrzn[j + i__ * 35] = wkpds_1.work[ipos + *nowstp * (i__ - 1) +
j - 1];
expszn[j + i__ * 35] = wkpds_1.work[ipos + nzst + *nowstp * (i__
- 1) + j - 1];
hminv[j + i__ * 35] = wkpds_1.work[ipos + (nzst << 1) + *nowstp *
(i__ - 1) + j - 1];
rlht[j + i__ * 35] = wkpds_1.work[ipos + nzst * 3 + *nowstp * (
i__ - 1) + j - 1];
ydxe[j + i__ * 35] = wkpds_1.work[ipos + (nzst << 2) + *nowstp * (
i__ - 1) + j - 1];
ydi0[j + i__ * 35] = wkpds_1.work[ipos + nzst * 5 + *nowstp * (
i__ - 1) + j - 1];
ydsm[j + i__ * 35] = wkpds_1.work[ipos + nzst * 6 + *nowstp * (
i__ - 1) + j - 1];
ydpm[j + i__ * 35] = wkpds_1.work[ipos + nzst * 7 + *nowstp * (
i__ - 1) + j - 1];
/* L140: */
}
}
ipos += nzst << 3;
/* ------ 35:DENSTY ------------------------------------------------ */
i__2 = *nzon;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = *ntnuc;
for (k = 1; k <= i__1; ++k) {
i__3 = *nowstp;
for (j = 1; j <= i__3; ++j) {
++ipos;
densty[j + (k + i__ * 150) * 35] = wkpds_1.work[ipos - 1];
/* L150: */
}
}
}
/* ------ 36:SIGXE ------------------------------------------------- */
i__3 = *nzon;
for (i__ = 1; i__ <= i__3; ++i__) {
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
i__2 = *ngc;
for (ig = 1; ig <= i__2; ++ig) {
++ipos;
sigxe[ig + (j + i__ * 35) * 20] = wkpds_1.work[ipos - 1];
/* L160: */
}
}
}
/* ------ 37:SIGI0 ------------------------------------------------- */
i__2 = *nzon;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
i__3 = *ngc;
for (ig = 1; ig <= i__3; ++ig) {
++ipos;
sigi0[ig + (j + i__ * 35) * 20] = wkpds_1.work[ipos - 1];
/* L170: */
}
}
}
/* ------ 38:SIGSM ------------------------------------------------- */
i__3 = *nzon;
for (i__ = 1; i__ <= i__3; ++i__) {
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
i__2 = *ngc;
for (ig = 1; ig <= i__2; ++ig) {
++ipos;
sigsm[ig + (j + i__ * 35) * 20] = wkpds_1.work[ipos - 1];
/* L180: */
}
}
}
/* ------ 39:SIGPM ------------------------------------------------- */
i__2 = *nzon;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
i__3 = *ngc;
for (ig = 1; ig <= i__3; ++ig) {
++ipos;
sigpm[ig + (j + i__ * 35) * 20] = wkpds_1.work[ipos - 1];
/* L190: */
}
}
}
/* ------ DATA LENGTH CHECK ---------------------- */
if (ipos != leng) {
io___28.ciunit = *iout;
s_wsle(&io___28);
do_lio(&c__9, &c__1, " CAUTION(BNPEDT): DATA LENGTH IN PDS FILE(=", (
ftnlen)43);
do_lio(&c__3, &c__1, (char *)&leng, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS MISMATCHED WITH EDIT LENGTH(=", (ftnlen)34)
;
do_lio(&c__3, &c__1, (char *)&ipos, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
if (*iout != 6) {
s_wsle(&io___29);
do_lio(&c__9, &c__1, " CAUTION(BNPEDT): DATA LENGTH IN PDS FILE(="
, (ftnlen)43);
do_lio(&c__3, &c__1, (char *)&leng, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS MISMATCHED WITH EDIT LENGTH(=", (
ftnlen)34);
do_lio(&c__3, &c__1, (char *)&ipos, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ")", (ftnlen)1);
e_wsle();
}
}
/* ************************** */
/* PRINT OUT *-------------------------------------------- */
/* ************************** */
if (*iprn == 0) {
goto L9000;
}
io___30.ciunit = *iout;
s_wsle(&io___30);
e_wsle();
io___31.ciunit = *iout;
s_wsfe(&io___31);
e_wsfe();
io___32.ciunit = *iout;
s_wsle(&io___32);
e_wsle();
io___33.ciunit = *iout;
s_wsle(&io___33);
do_lio(&c__9, &c__1, " ***** HETEROGENEOUS BURNUP DATA :", (ftnlen)37);
do_lio(&c__9, &c__1, " MEMBER NAME = ", (ftnlen)15);
do_lio(&c__9, &c__1, memnam, (ftnlen)8);
do_lio(&c__9, &c__1, " *****", (ftnlen)6);
e_wsle();
io___34.ciunit = *iout;
s_wsle(&io___34);
e_wsle();
io___35.ciunit = *iout;
s_wsfe(&io___35);
do_fio(&c__1, "CASE = ", (ftnlen)10);
do_fio(&c__1, case__, (ftnlen)4);
e_wsfe();
io___36.ciunit = *iout;
s_wsfe(&io___36);
do_fio(&c__1, "TITLE = ", (ftnlen)10);
do_fio(&c__1, title, (ftnlen)72);
e_wsfe();
io___37.ciunit = *iout;
s_wsfe(&io___37);
do_fio(&c__1, "NOWSTP =", (ftnlen)9);
do_fio(&c__1, (char *)&(*nowstp), (ftnlen)sizeof(integer));
e_wsfe();
io___38.ciunit = *iout;
s_wsfe(&io___38);
do_fio(&c__1, "NTNUC =", (ftnlen)9);
do_fio(&c__1, (char *)&(*ntnuc), (ftnlen)sizeof(integer));
e_wsfe();
io___39.ciunit = *iout;
s_wsfe(&io___39);
do_fio(&c__1, "NZON =", (ftnlen)9);
do_fio(&c__1, (char *)&(*nzon), (ftnlen)sizeof(integer));
e_wsfe();
io___40.ciunit = *iout;
s_wsle(&io___40);
e_wsle();
io___41.ciunit = *iout;
s_wsfe(&io___41);
i__3 = *nowstp - 1;
for (j = 0; j <= i__3; ++j) {
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
}
e_wsfe();
io___42.ciunit = *iout;
s_wsfe(&io___42);
i__3 = *nowstp;
for (j = 1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&days[j], (ftnlen)sizeof(real));
}
e_wsfe();
io___43.ciunit = *iout;
s_wsfe(&io___43);
i__3 = *nowstp;
for (j = 1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&expst[j], (ftnlen)sizeof(real));
}
e_wsfe();
io___44.ciunit = *iout;
s_wsfe(&io___44);
do_fio(&c__1, stdnuc + 1, (ftnlen)3);
i__3 = *nowstp;
for (j = 1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&u235f[j], (ftnlen)sizeof(real));
}
e_wsfe();
io___45.ciunit = *iout;
s_wsfe(&io___45);
i__3 = *nowstp;
for (j = 1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&akeff[j], (ftnlen)sizeof(real));
}
e_wsfe();
io___46.ciunit = *iout;
s_wsfe(&io___46);
i__3 = *nowstp;
for (j = 1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&akinf[j], (ftnlen)sizeof(real));
}
e_wsfe();
io___47.ciunit = *iout;
s_wsfe(&io___47);
i__3 = *nowstp;
for (j = 1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&crins[j], (ftnlen)sizeof(real));
}
e_wsfe();
io___48.ciunit = *iout;
s_wsfe(&io___48);
i__3 = *nowstp;
for (j = 1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&crint[j], (ftnlen)sizeof(real));
}
e_wsfe();
io___49.ciunit = *iout;
s_wsfe(&io___49);
i__3 = *nowstp;
for (j = 1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&powerl[j], (ftnlen)sizeof(real));
}
e_wsfe();
io___50.ciunit = *iout;
s_wsfe(&io___50);
i__3 = *nowstp;
for (j = 1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&flxnrm[j], (ftnlen)sizeof(real));
}
e_wsfe();
io___51.ciunit = *iout;
s_wsle(&io___51);
e_wsle();
i__3 = *nzon;
for (izn = 1; izn <= i__3; ++izn) {
io___53.ciunit = *iout;
s_wsle(&io___53);
e_wsle();
io___54.ciunit = *iout;
s_wsle(&io___54);
do_lio(&c__9, &c__1, " ***** DEPLETING ZONE(", (ftnlen)22);
do_lio(&c__3, &c__1, (char *)&izn, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") : ", (ftnlen)4);
do_lio(&c__9, &c__1, "MATERIAL NAME=", (ftnlen)14);
do_lio(&c__9, &c__1, mtnm + (izn << 2), (ftnlen)4);
do_lio(&c__9, &c__1, " : MATERIAL TYPE=", (ftnlen)17);
do_lio(&c__3, &c__1, (char *)&mtyp[izn], (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " : VOLUME(CC)=", (ftnlen)14);
do_lio(&c__4, &c__1, (char *)&voldpz[izn], (ftnlen)sizeof(real));
e_wsle();
io___55.ciunit = *iout;
s_wsfe(&io___55);
i__1 = *nowstp - 1;
for (j = 0; j <= i__1; ++j) {
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
}
e_wsfe();
if (mtyp[izn] == 2) {
io___56.ciunit = *iout;
s_wsfe(&io___56);
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&expszn[j + izn * 35], (ftnlen)sizeof(
real));
}
e_wsfe();
} else {
io___57.ciunit = *iout;
s_wsfe(&io___57);
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&expszn[j + izn * 35], (ftnlen)sizeof(
real));
}
e_wsfe();
}
io___58.ciunit = *iout;
s_wsfe(&io___58);
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&powrzn[j + izn * 35], (ftnlen)sizeof(real))
;
}
e_wsfe();
io___59.ciunit = *iout;
s_wsfe(&io___59);
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&hminv[j + izn * 35], (ftnlen)sizeof(real));
}
e_wsfe();
io___60.ciunit = *iout;
s_wsfe(&io___60);
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&rlht[j + izn * 35], (ftnlen)sizeof(real));
}
e_wsfe();
io___61.ciunit = *iout;
s_wsfe(&io___61);
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&ydxe[j + izn * 35], (ftnlen)sizeof(real));
}
e_wsfe();
io___62.ciunit = *iout;
s_wsfe(&io___62);
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&ydi0[j + izn * 35], (ftnlen)sizeof(real));
}
e_wsfe();
io___63.ciunit = *iout;
s_wsfe(&io___63);
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&ydsm[j + izn * 35], (ftnlen)sizeof(real));
}
e_wsfe();
io___64.ciunit = *iout;
s_wsfe(&io___64);
i__1 = *nowstp;
for (j = 1; j <= i__1; ++j) {
do_fio(&c__1, (char *)&ydpm[j + izn * 35], (ftnlen)sizeof(real));
}
e_wsfe();
io___65.ciunit = *iout;
s_wsfe(&io___65);
do_fio(&c__1, " * NUMBER DENSITY (*E24 N/CC)", (ftnlen)29);
e_wsfe();
io___66.ciunit = *iout;
s_wsfe(&io___66);
i__1 = *nowstp - 1;
for (j = 0; j <= i__1; ++j) {
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
}
e_wsfe();
io___67.ciunit = *iout;
s_wsfe(&io___67);
e_wsfe();
i__1 = *ntnuc;
for (k = 1; k <= i__1; ++k) {
io___68.ciunit = *iout;
s_wsfe(&io___68);
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__1, nuclid + (k << 2), (ftnlen)4);
i__2 = *nowstp;
for (j = 1; j <= i__2; ++j) {
do_fio(&c__1, (char *)&densty[j + (k + izn * 150) * 35], (
ftnlen)sizeof(real));
}
e_wsfe();
/* L1000: */
}
/* L6330: */
io___69.ciunit = *iout;
s_wsfe(&io___69);
do_fio(&c__1, " * XE-135 MICRO ABSORPTION XS BY GROUP", (ftnlen)38);
e_wsfe();
i__1 = *nowstp;
for (jj = 1; jj <= i__1; ++jj) {
io___71.ciunit = *iout;
s_wsfe(&io___71);
i__2 = jj - 1;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
i__4 = *ngc;
for (ig = 1; ig <= i__4; ++ig) {
do_fio(&c__1, (char *)&sigxe[ig + (jj + izn * 35) * 20], (
ftnlen)sizeof(real));
}
e_wsfe();
/* L1010: */
}
io___72.ciunit = *iout;
s_wsfe(&io___72);
do_fio(&c__1, " * I -135 MICRO ABSORPTION XS BY GROUP", (ftnlen)38);
e_wsfe();
i__1 = *nowstp;
for (jj = 1; jj <= i__1; ++jj) {
io___73.ciunit = *iout;
s_wsfe(&io___73);
i__2 = jj - 1;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
i__4 = *ngc;
for (ig = 1; ig <= i__4; ++ig) {
do_fio(&c__1, (char *)&sigi0[ig + (jj + izn * 35) * 20], (
ftnlen)sizeof(real));
}
e_wsfe();
/* L1020: */
}
io___74.ciunit = *iout;
s_wsfe(&io___74);
do_fio(&c__1, " * SM-149 MICRO ABSORPTION XS BY GROUP", (ftnlen)38);
e_wsfe();
i__1 = *nowstp;
for (jj = 1; jj <= i__1; ++jj) {
io___75.ciunit = *iout;
s_wsfe(&io___75);
i__2 = jj - 1;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
i__4 = *ngc;
for (ig = 1; ig <= i__4; ++ig) {
do_fio(&c__1, (char *)&sigsm[ig + (jj + izn * 35) * 20], (
ftnlen)sizeof(real));
}
e_wsfe();
/* L1030: */
}
io___76.ciunit = *iout;
s_wsfe(&io___76);
do_fio(&c__1, " * PM-149 MICRO ABSORPTION XS BY GROUP", (ftnlen)38);
e_wsfe();
i__1 = *nowstp;
for (jj = 1; jj <= i__1; ++jj) {
io___77.ciunit = *iout;
s_wsfe(&io___77);
i__2 = jj - 1;
do_fio(&c__1, (char *)&i__2, (ftnlen)sizeof(integer));
i__4 = *ngc;
for (ig = 1; ig <= i__4; ++ig) {
do_fio(&c__1, (char *)&sigpm[ig + (jj + izn * 35) * 20], (
ftnlen)sizeof(real));
}
e_wsfe();
/* L1040: */
}
/* L2000: */
}
io___78.ciunit = *iout;
s_wsle(&io___78);
e_wsle();
io___79.ciunit = *iout;
s_wsle(&io___79);
e_wsle();
io___80.ciunit = *iout;
s_wsfe(&io___80);
e_wsfe();
io___81.ciunit = *iout;
s_wsle(&io___81);
e_wsle();
L9000:
return 0;
} /* bnpedt_ */
/* DECK SREADP */
/* Subroutine */ int sreadp_(integer *ipage, integer *list, real *rlist,
integer *lpage, integer *irec)
{
/* System generated locals */
address a__1[4];
integer i__1, i__2, i__3[4];
char ch__1[40];
/* Local variables */
static integer i__, lpg;
static char xern1[8], xern2[8];
static integer irecn, ipagef;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___4 = { 1, 0, 0, 0, 0 };
static cilist io___6 = { 1, 0, 0, 0, 0 };
static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___10 = { 0, xern2, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE SREADP */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to SPLP */
/* ***LIBRARY SLATEC */
/* ***TYPE SINGLE PRECISION (SREADP-S, DREADP-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* READ RECORD NUMBER IRECN, OF LENGTH LPG, FROM UNIT */
/* NUMBER IPAGEF INTO THE STORAGE ARRAY, LIST(*). */
/* READ RECORD IRECN+1, OF LENGTH LPG, FROM UNIT NUMBER */
/* IPAGEF INTO THE STORAGE ARRAY RLIST(*). */
/* TO CONVERT THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE */
/* /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/. */
/* ***SEE ALSO SPLP */
/* ***ROUTINES CALLED XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 811215 DATE WRITTEN */
/* 890605 Corrected references to XERRWV. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* ***END PROLOGUE SREADP */
/* ***FIRST EXECUTABLE STATEMENT SREADP */
/* Parameter adjustments */
--rlist;
--list;
/* Function Body */
ipagef = *ipage;
lpg = *lpage;
irecn = *irec;
io___4.ciunit = ipagef;
io___4.cirec = irecn;
i__1 = s_rdue(&io___4);
if (i__1 != 0) {
goto L100;
}
i__2 = lpg;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = do_uio(&c__1, (char *)&list[i__], (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L100;
}
}
i__1 = e_rdue();
if (i__1 != 0) {
goto L100;
}
io___6.ciunit = ipagef;
io___6.cirec = irecn + 1;
i__1 = s_rdue(&io___6);
if (i__1 != 0) {
goto L100;
}
i__2 = lpg;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = do_uio(&c__1, (char *)&rlist[i__], (ftnlen)sizeof(real));
if (i__1 != 0) {
goto L100;
}
}
i__1 = e_rdue();
if (i__1 != 0) {
goto L100;
}
return 0;
L100:
s_wsfi(&io___8);
do_fio(&c__1, (char *)&lpg, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___10);
do_fio(&c__1, (char *)&irecn, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 15, a__1[0] = "IN SPLP, LPG = ";
i__3[1] = 8, a__1[1] = xern1;
i__3[2] = 9, a__1[2] = " IRECN = ";
i__3[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__3, &c__4, (ftnlen)40);
xermsg_("SLATEC", "SREADP", ch__1, &c__100, &c__1, (ftnlen)6, (ftnlen)6, (
ftnlen)40);
return 0;
} /* sreadp_ */
/* DECK XERMSG */
/* Subroutine */ int xermsg_(char *librar, char *subrou, char *messg, integer
*nerr, integer *level, ftnlen librar_len, ftnlen subrou_len, ftnlen
messg_len)
{
/* System generated locals */
address a__1[2];
integer i__1, i__2, i__3[2];
char ch__1[87];
icilist ici__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer i_len(char *, ftnlen), s_wsfi(icilist *), do_fio(integer *, char *
, ftnlen), e_wsfi(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, lerr;
char temp[72];
extern /* Subroutine */ int fdump_(void);
char xlibr[8];
integer ltemp, kount;
char xsubr[8];
extern integer j4save_(integer *, integer *, logical *);
integer llevel, maxmes;
char lfirst[20];
extern /* Subroutine */ int xercnt_(char *, char *, char *, integer *,
integer *, integer *, ftnlen, ftnlen, ftnlen);
integer lkntrl, kdummy;
extern /* Subroutine */ int xerhlt_(char *, ftnlen);
integer mkntrl;
extern /* Subroutine */ int xersve_(char *, char *, char *, integer *,
integer *, integer *, integer *, ftnlen, ftnlen, ftnlen), xerprn_(
char *, integer *, char *, integer *, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE XERMSG */
/* ***PURPOSE Process error messages for SLATEC and other libraries. */
/* ***LIBRARY SLATEC (XERROR) */
/* ***CATEGORY R3C */
/* ***TYPE ALL (XERMSG-A) */
/* ***KEYWORDS ERROR MESSAGE, XERROR */
/* ***AUTHOR Fong, Kirby, (NMFECC at LLNL) */
/* ***DESCRIPTION */
/* XERMSG processes a diagnostic message in a manner determined by the */
/* value of LEVEL and the current value of the library error control */
/* flag, KONTRL. See subroutine XSETF for details. */
/* LIBRAR A character constant (or character variable) with the name */
/* of the library. This will be 'SLATEC' for the SLATEC */
/* Common Math Library. The error handling package is */
/* general enough to be used by many libraries */
/* simultaneously, so it is desirable for the routine that */
/* detects and reports an error to identify the library name */
/* as well as the routine name. */
/* SUBROU A character constant (or character variable) with the name */
/* of the routine that detected the error. Usually it is the */
/* name of the routine that is calling XERMSG. There are */
/* some instances where a user callable library routine calls */
/* lower level subsidiary routines where the error is */
/* detected. In such cases it may be more informative to */
/* supply the name of the routine the user called rather than */
/* the name of the subsidiary routine that detected the */
/* error. */
/* MESSG A character constant (or character variable) with the text */
/* of the error or warning message. In the example below, */
/* the message is a character constant that contains a */
/* generic message. */
/* CALL XERMSG ('SLATEC', 'MMPY', */
/* *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', */
/* *3, 1) */
/* It is possible (and is sometimes desirable) to generate a */
/* specific message--e.g., one that contains actual numeric */
/* values. Specific numeric values can be converted into */
/* character strings using formatted WRITE statements into */
/* character variables. This is called standard Fortran */
/* internal file I/O and is exemplified in the first three */
/* lines of the following example. You can also catenate */
/* substrings of characters to construct the error message. */
/* Here is an example showing the use of both writing to */
/* an internal file and catenating character strings. */
/* CHARACTER*5 CHARN, CHARL */
/* WRITE (CHARN,10) N */
/* WRITE (CHARL,10) LDA */
/* 10 FORMAT(I5) */
/* CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// */
/* * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// */
/* * CHARL, 3, 1) */
/* There are two subtleties worth mentioning. One is that */
/* the // for character catenation is used to construct the */
/* error message so that no single character constant is */
/* continued to the next line. This avoids confusion as to */
/* whether there are trailing blanks at the end of the line. */
/* The second is that by catenating the parts of the message */
/* as an actual argument rather than encoding the entire */
/* message into one large character variable, we avoid */
/* having to know how long the message will be in order to */
/* declare an adequate length for that large character */
/* variable. XERMSG calls XERPRN to print the message using */
/* multiple lines if necessary. If the message is very long, */
/* XERPRN will break it into pieces of 72 characters (as */
/* requested by XERMSG) for printing on multiple lines. */
/* Also, XERMSG asks XERPRN to prefix each line with ' * ' */
/* so that the total line length could be 76 characters. */
/* Note also that XERPRN scans the error message backwards */
/* to ignore trailing blanks. Another feature is that */
/* the substring '$$' is treated as a new line sentinel */
/* by XERPRN. If you want to construct a multiline */
/* message without having to count out multiples of 72 */
/* characters, just use '$$' as a separator. '$$' */
/* obviously must occur within 72 characters of the */
/* start of each line to have its intended effect since */
/* XERPRN is asked to wrap around at 72 characters in */
/* addition to looking for '$$'. */
/* NERR An integer value that is chosen by the library routine's */
/* author. It must be in the range -99 to 999 (three */
/* printable digits). Each distinct error should have its */
/* own error number. These error numbers should be described */
/* in the machine readable documentation for the routine. */
/* The error numbers need be unique only within each routine, */
/* so it is reasonable for each routine to start enumerating */
/* errors from 1 and proceeding to the next integer. */
/* LEVEL An integer value in the range 0 to 2 that indicates the */
/* level (severity) of the error. Their meanings are */
/* -1 A warning message. This is used if it is not clear */
/* that there really is an error, but the user's attention */
/* may be needed. An attempt is made to only print this */
/* message once. */
/* 0 A warning message. This is used if it is not clear */
/* that there really is an error, but the user's attention */
/* may be needed. */
/* 1 A recoverable error. This is used even if the error is */
/* so serious that the routine cannot return any useful */
/* answer. If the user has told the error package to */
/* return after recoverable errors, then XERMSG will */
/* return to the Library routine which can then return to */
/* the user's routine. The user may also permit the error */
/* package to terminate the program upon encountering a */
/* recoverable error. */
/* 2 A fatal error. XERMSG will not return to its caller */
/* after it receives a fatal error. This level should */
/* hardly ever be used; it is much better to allow the */
/* user a chance to recover. An example of one of the few */
/* cases in which it is permissible to declare a level 2 */
/* error is a reverse communication Library routine that */
/* is likely to be called repeatedly until it integrates */
/* across some interval. If there is a serious error in */
/* the input such that another step cannot be taken and */
/* the Library routine is called again without the input */
/* error having been corrected by the caller, the Library */
/* routine will probably be called forever with improper */
/* input. In this case, it is reasonable to declare the */
/* error to be fatal. */
/* Each of the arguments to XERMSG is input; none will be modified by */
/* XERMSG. A routine may make multiple calls to XERMSG with warning */
/* level messages; however, after a call to XERMSG with a recoverable */
/* error, the routine should return to the user. Do not try to call */
/* XERMSG with a second recoverable error after the first recoverable */
/* error because the error package saves the error number. The user */
/* can retrieve this error number by calling another entry point in */
/* the error handling package and then clear the error number when */
/* recovering from the error. Calling XERMSG in succession causes the */
/* old error number to be overwritten by the latest error number. */
/* This is considered harmless for error numbers associated with */
/* warning messages but must not be done for error numbers of serious */
/* errors. After a call to XERMSG with a recoverable error, the user */
/* must be given a chance to call NUMXER or XERCLR to retrieve or */
/* clear the error number. */
/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */
/* Error-handling Package, SAND82-0800, Sandia */
/* Laboratories, 1982. */
/* ***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE */
/* ***REVISION HISTORY (YYMMDD) */
/* 880101 DATE WRITTEN */
/* 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. */
/* THERE ARE TWO BASIC CHANGES. */
/* 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO */
/* PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES */
/* INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS */
/* ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE */
/* ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER */
/* ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY */
/* 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE */
/* LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. */
/* 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE */
/* FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE */
/* OF LOWER CASE. */
/* 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. */
/* THE PRINCIPAL CHANGES ARE */
/* 1. CLARIFY COMMENTS IN THE PROLOGUES */
/* 2. RENAME XRPRNT TO XERPRN */
/* 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES */
/* SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / */
/* CHARACTER FOR NEW RECORDS. */
/* 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO */
/* CLEAN UP THE CODING. */
/* 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN */
/* PREFIX. */
/* 891013 REVISED TO CORRECT COMMENTS. */
/* 891214 Prologue converted to Version 4.0 format. (WRB) */
/* 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but */
/* NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added */
/* LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and */
/* XERCTL to XERCNT. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE XERMSG */
/* ***FIRST EXECUTABLE STATEMENT XERMSG */
lkntrl = j4save_(&c__2, &c__0, &c_false);
maxmes = j4save_(&c__4, &c__0, &c_false);
/* LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. */
/* MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE */
/* SHOULD BE PRINTED. */
/* WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN */
/* CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, */
/* AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. */
if (*nerr < -9999999 || *nerr > 99999999 || *nerr == 0 || *level < -1 || *
level > 2) {
xerprn_(" ***", &c_n1, "FATAL ERROR IN...$$ XERMSG -- INVALID ERROR "
"NUMBER OR LEVEL$$ JOB ABORT DUE TO FATAL ERROR.", &c__72, (
ftnlen)4, (ftnlen)91);
xersve_(" ", " ", " ", &c__0, &c__0, &c__0, &kdummy, (ftnlen)1, (
ftnlen)1, (ftnlen)1);
xerhlt_(" ***XERMSG -- INVALID INPUT", (ftnlen)27);
return 0;
}
/* RECORD THE MESSAGE. */
i__ = j4save_(&c__1, nerr, &c_true);
xersve_(librar, subrou, messg, &c__1, nerr, level, &kount, librar_len,
subrou_len, messg_len);
/* HANDLE PRINT-ONCE WARNING MESSAGES. */
if (*level == -1 && kount > 1) {
return 0;
}
/* ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. */
s_copy(xlibr, librar, (ftnlen)8, librar_len);
s_copy(xsubr, subrou, (ftnlen)8, subrou_len);
s_copy(lfirst, messg, (ftnlen)20, messg_len);
lerr = *nerr;
llevel = *level;
xercnt_(xlibr, xsubr, lfirst, &lerr, &llevel, &lkntrl, (ftnlen)8, (ftnlen)
8, (ftnlen)20);
/* Computing MAX */
i__1 = -2, i__2 = min(2,lkntrl);
lkntrl = max(i__1,i__2);
mkntrl = abs(lkntrl);
/* SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS */
/* ZERO AND THE ERROR IS NOT FATAL. */
if (*level < 2 && lkntrl == 0) {
goto L30;
}
if (*level == 0 && kount > maxmes) {
goto L30;
}
if (*level == 1 && kount > maxmes && mkntrl == 1) {
goto L30;
}
if (*level == 2 && kount > max(1,maxmes)) {
goto L30;
}
/* ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A */
/* MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) */
/* AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG */
/* IS NOT ZERO. */
if (lkntrl != 0) {
s_copy(temp, "MESSAGE FROM ROUTINE ", (ftnlen)21, (ftnlen)21);
/* Computing MIN */
i__1 = i_len(subrou, subrou_len);
i__ = min(i__1,16);
s_copy(temp + 21, subrou, i__, i__);
i__1 = i__ + 21;
s_copy(temp + i__1, " IN LIBRARY ", i__ + 33 - i__1, (ftnlen)12);
ltemp = i__ + 33;
/* Computing MIN */
i__1 = i_len(librar, librar_len);
i__ = min(i__1,16);
i__1 = ltemp;
s_copy(temp + i__1, librar, ltemp + i__ - i__1, i__);
i__1 = ltemp + i__;
s_copy(temp + i__1, ".", ltemp + i__ + 1 - i__1, (ftnlen)1);
ltemp = ltemp + i__ + 1;
xerprn_(" ***", &c_n1, temp, &c__72, (ftnlen)4, ltemp);
}
/* IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE */
/* PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE */
/* FROM EACH OF THE FOLLOWING THREE OPTIONS. */
/* 1. LEVEL OF THE MESSAGE */
/* 'INFORMATIVE MESSAGE' */
/* 'POTENTIALLY RECOVERABLE ERROR' */
/* 'FATAL ERROR' */
/* 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE */
/* 'PROG CONTINUES' */
/* 'PROG ABORTED' */
/* 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK */
/* MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS */
/* WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) */
/* 'TRACEBACK REQUESTED' */
/* 'TRACEBACK NOT REQUESTED' */
/* NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT */
/* EXCEED 74 CHARACTERS. */
/* WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. */
if (lkntrl > 0) {
/* THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. */
if (*level <= 0) {
s_copy(temp, "INFORMATIVE MESSAGE,", (ftnlen)20, (ftnlen)20);
ltemp = 20;
} else if (*level == 1) {
s_copy(temp, "POTENTIALLY RECOVERABLE ERROR,", (ftnlen)30, (
ftnlen)30);
ltemp = 30;
} else {
s_copy(temp, "FATAL ERROR,", (ftnlen)12, (ftnlen)12);
ltemp = 12;
}
/* THEN WHETHER THE PROGRAM WILL CONTINUE. */
if ((mkntrl == 2 && *level >= 1) || (mkntrl == 1 && *level == 2)) {
i__1 = ltemp;
s_copy(temp + i__1, " PROG ABORTED,", ltemp + 14 - i__1, (ftnlen)
14);
ltemp += 14;
} else {
i__1 = ltemp;
s_copy(temp + i__1, " PROG CONTINUES,", ltemp + 16 - i__1, (
ftnlen)16);
ltemp += 16;
}
/* FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. */
if (lkntrl > 0) {
i__1 = ltemp;
s_copy(temp + i__1, " TRACEBACK REQUESTED", ltemp + 20 - i__1, (
ftnlen)20);
ltemp += 20;
} else {
i__1 = ltemp;
s_copy(temp + i__1, " TRACEBACK NOT REQUESTED", ltemp + 24 - i__1,
(ftnlen)24);
ltemp += 24;
}
xerprn_(" ***", &c_n1, temp, &c__72, (ftnlen)4, ltemp);
}
/* NOW SEND OUT THE MESSAGE. */
xerprn_(" * ", &c_n1, messg, &c__72, (ftnlen)4, messg_len);
/* IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A */
/* TRACEBACK. */
if (lkntrl > 0) {
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 72;
ici__1.iciunit = temp;
ici__1.icifmt = "('ERROR NUMBER = ', I8)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*nerr), (ftnlen)sizeof(integer));
e_wsfi();
for (i__ = 16; i__ <= 22; ++i__) {
if (*(unsigned char *)&temp[i__ - 1] != ' ') {
goto L20;
}
/* L10: */
}
L20:
/* Writing concatenation */
i__3[0] = 15, a__1[0] = temp;
i__3[1] = 23 - (i__ - 1), a__1[1] = temp + (i__ - 1);
s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)87);
xerprn_(" * ", &c_n1, ch__1, &c__72, (ftnlen)4, 23 - (i__ - 1) + 15);
fdump_();
}
/* IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. */
if (lkntrl != 0) {
xerprn_(" * ", &c_n1, " ", &c__72, (ftnlen)4, (ftnlen)1);
xerprn_(" ***", &c_n1, "END OF MESSAGE", &c__72, (ftnlen)4, (ftnlen)
14);
xerprn_(" ", &c__0, " ", &c__72, (ftnlen)4, (ftnlen)1);
}
/* IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE */
/* CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. */
L30:
if ((*level <= 0) || (*level == 1 && mkntrl <= 1)) {
return 0;
}
/* THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A */
/* FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR */
/* SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. */
if (lkntrl > 0 && kount < max(1,maxmes)) {
if (*level == 1) {
xerprn_(" ***", &c_n1, "JOB ABORT DUE TO UNRECOVERED ERROR.", &
c__72, (ftnlen)4, (ftnlen)35);
} else {
xerprn_(" ***", &c_n1, "JOB ABORT DUE TO FATAL ERROR.", &c__72, (
ftnlen)4, (ftnlen)29);
}
xersve_(" ", " ", " ", &c_n1, &c__0, &c__0, &kdummy, (ftnlen)1, (
ftnlen)1, (ftnlen)1);
xerhlt_(" ", (ftnlen)1);
} else {
xerhlt_(messg, messg_len);
}
return 0;
} /* xermsg_ */
/* DECK SDRIV1 */
/* Subroutine */ int sdriv1_(integer *n, real *t, real *y, U_fp f, real *tout,
integer *mstate, real *eps, real *work, integer *lenw, integer *
ierflg)
{
/* Initialized data */
static real ewtcom[1] = { 1.f };
/* System generated locals */
address a__1[3];
integer i__1[3], i__2;
real r__1;
char ch__1[79], ch__2[93], ch__3[95];
/* Local variables */
static integer i__, ml, mu, nde;
static real hmax;
static integer leniw, ntask, iwork[250];
static char intgr1[8];
extern /* Subroutine */ int sdriv3_(integer *, real *, real *, U_fp,
integer *, real *, integer *, integer *, real *, real *, integer *
, integer *, integer *, integer *, integer *, integer *, integer *
, real *, real *, integer *, integer *, integer *, U_fp, U_fp,
integer *, integer *, U_fp, U_fp, integer *);
static integer lenwcm, lnwchk, nstate;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___3 = { 0, intgr1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, intgr1, 0, "(I8)", 8, 1 };
static icilist io___11 = { 0, intgr1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE SDRIV1 */
/* ***PURPOSE The function of SDRIV1 is to solve N (200 or fewer) */
/* ordinary differential equations of the form */
/* dY(I)/dT = F(Y(I),T), given the initial conditions */
/* Y(I) = YI. SDRIV1 uses single precision arithmetic. */
/* ***LIBRARY SLATEC (SDRIVE) */
/* ***CATEGORY I1A2, I1A1B */
/* ***TYPE SINGLE PRECISION (SDRIV1-S, DDRIV1-D, CDRIV1-C) */
/* ***KEYWORDS GEAR'S METHOD, INITIAL VALUE PROBLEMS, ODE, */
/* ORDINARY DIFFERENTIAL EQUATIONS, SDRIVE, SINGLE PRECISION, */
/* STIFF */
/* ***AUTHOR Kahaner, D. K., (NIST) */
/* National Institute of Standards and Technology */
/* Gaithersburg, MD 20899 */
/* Sutherland, C. D., (LANL) */
/* Mail Stop D466 */
/* Los Alamos National Laboratory */
/* Los Alamos, NM 87545 */
/* ***DESCRIPTION */
/* Version 92.1 */
/* I. CHOOSING THE CORRECT ROUTINE ................................... */
/* SDRIV */
/* DDRIV */
/* CDRIV */
/* These are the generic names for three packages for solving */
/* initial value problems for ordinary differential equations. */
/* SDRIV uses single precision arithmetic. DDRIV uses double */
/* precision arithmetic. CDRIV allows complex-valued */
/* differential equations, integrated with respect to a single, */
/* real, independent variable. */
/* As an aid in selecting the proper program, the following is a */
/* discussion of the important options or restrictions associated with */
/* each program: */
/* A. SDRIV1 should be tried first for those routine problems with */
/* no more than 200 differential equations (SDRIV2 and SDRIV3 */
/* have no such restriction.) Internally this routine has two */
/* important technical defaults: */
/* 1. Numerical approximation of the Jacobian matrix of the */
/* right hand side is used. */
/* 2. The stiff solver option is used. */
/* Most users of SDRIV1 should not have to concern themselves */
/* with these details. */
/* B. SDRIV2 should be considered for those problems for which */
/* SDRIV1 is inadequate. For example, SDRIV1 may have difficulty */
/* with problems having zero initial conditions and zero */
/* derivatives. In this case SDRIV2, with an appropriate value */
/* of the parameter EWT, should perform more efficiently. SDRIV2 */
/* provides three important additional options: */
/* 1. The nonstiff equation solver (as well as the stiff */
/* solver) is available. */
/* 2. The root-finding option is available. */
/* 3. The program can dynamically select either the non-stiff */
/* or the stiff methods. */
/* Internally this routine also defaults to the numerical */
/* approximation of the Jacobian matrix of the right hand side. */
/* C. SDRIV3 is the most flexible, and hence the most complex, of */
/* the programs. Its important additional features include: */
/* 1. The ability to exploit band structure in the Jacobian */
/* matrix. */
/* 2. The ability to solve some implicit differential */
/* equations, i.e., those having the form: */
/* A(Y,T)*dY/dT = F(Y,T). */
/* 3. The option of integrating in the one step mode. */
/* 4. The option of allowing the user to provide a routine */
/* which computes the analytic Jacobian matrix of the right */
/* hand side. */
/* 5. The option of allowing the user to provide a routine */
/* which does all the matrix algebra associated with */
/* corrections to the solution components. */
/* II. PARAMETERS .................................................... */
/* The user should use parameter names in the call sequence of SDRIV1 */
/* for those quantities whose value may be altered by SDRIV1. The */
/* parameters in the call sequence are: */
/* N = (Input) The number of differential equations, N .LE. 200 */
/* T = The independent variable. On input for the first call, T */
/* is the initial point. On output, T is the point at which */
/* the solution is given. */
/* Y = The vector of dependent variables. Y is used as input on */
/* the first call, to set the initial values. On output, Y */
/* is the computed solution vector. This array Y is passed */
/* in the call sequence of the user-provided routine F. Thus */
/* parameters required by F can be stored in this array in */
/* components N+1 and above. (Note: Changes by the user to */
/* the first N components of this array will take effect only */
/* after a restart, i.e., after setting MSTATE to +1(-1).) */
/* F = A subroutine supplied by the user. The name must be */
/* declared EXTERNAL in the user's calling program. This */
/* subroutine is of the form: */
/* SUBROUTINE F (N, T, Y, YDOT) */
/* REAL Y(*), YDOT(*) */
/* . */
/* . */
/* YDOT(1) = ... */
/* . */
/* . */
/* YDOT(N) = ... */
/* END (Sample) */
/* This computes YDOT = F(Y,T), the right hand side of the */
/* differential equations. Here Y is a vector of length at */
/* least N. The actual length of Y is determined by the */
/* user's declaration in the program which calls SDRIV1. */
/* Thus the dimensioning of Y in F, while required by FORTRAN */
/* convention, does not actually allocate any storage. When */
/* this subroutine is called, the first N components of Y are */
/* intermediate approximations to the solution components. */
/* The user should not alter these values. Here YDOT is a */
/* vector of length N. The user should only compute YDOT(I) */
/* for I from 1 to N. Normally a return from F passes */
/* control back to SDRIV1. However, if the user would like */
/* to abort the calculation, i.e., return control to the */
/* program which calls SDRIV1, he should set N to zero. */
/* SDRIV1 will signal this by returning a value of MSTATE */
/* equal to +5(-5). Altering the value of N in F has no */
/* effect on the value of N in the call sequence of SDRIV1. */
/* TOUT = (Input) The point at which the solution is desired. */
/* MSTATE = An integer describing the status of integration. The user */
/* must initialize MSTATE to +1 or -1. If MSTATE is */
/* positive, the routine will integrate past TOUT and */
/* interpolate the solution. This is the most efficient */
/* mode. If MSTATE is negative, the routine will adjust its */
/* internal step to reach TOUT exactly (useful if a */
/* singularity exists beyond TOUT.) The meaning of the */
/* magnitude of MSTATE: */
/* 1 (Input) Means the first call to the routine. This */
/* value must be set by the user. On all subsequent */
/* calls the value of MSTATE should be tested by the */
/* user. Unless SDRIV1 is to be reinitialized, only the */
/* sign of MSTATE may be changed by the user. (As a */
/* convenience to the user who may wish to put out the */
/* initial conditions, SDRIV1 can be called with */
/* MSTATE=+1(-1), and TOUT=T. In this case the program */
/* will return with MSTATE unchanged, i.e., */
/* MSTATE=+1(-1).) */
/* 2 (Output) Means a successful integration. If a normal */
/* continuation is desired (i.e., a further integration */
/* in the same direction), simply advance TOUT and call */
/* again. All other parameters are automatically set. */
/* 3 (Output)(Unsuccessful) Means the integrator has taken */
/* 1000 steps without reaching TOUT. The user can */
/* continue the integration by simply calling SDRIV1 */
/* again. */
/* 4 (Output)(Unsuccessful) Means too much accuracy has */
/* been requested. EPS has been increased to a value */
/* the program estimates is appropriate. The user can */
/* continue the integration by simply calling SDRIV1 */
/* again. */
/* 5 (Output)(Unsuccessful) N has been set to zero in */
/* SUBROUTINE F. */
/* 6 (Output)(Successful) For MSTATE negative, T is beyond */
/* TOUT. The solution was obtained by interpolation. */
/* The user can continue the integration by simply */
/* advancing TOUT and calling SDRIV1 again. */
/* 7 (Output)(Unsuccessful) The solution could not be */
/* obtained. The value of IERFLG (see description */
/* below) for a "Recoverable" situation indicates the */
/* type of difficulty encountered: either an illegal */
/* value for a parameter or an inability to continue the */
/* solution. For this condition the user should take */
/* corrective action and reset MSTATE to +1(-1) before */
/* calling SDRIV1 again. Otherwise the program will */
/* terminate the run. */
/* EPS = On input, the requested relative accuracy in all solution */
/* components. On output, the adjusted relative accuracy if */
/* the input value was too small. The value of EPS should be */
/* set as large as is reasonable, because the amount of work */
/* done by SDRIV1 increases as EPS decreases. */
/* WORK */
/* LENW = (Input) */
/* WORK is an array of LENW real words used */
/* internally for temporary storage. The user must allocate */
/* space for this array in the calling program by a statement */
/* such as */
/* REAL WORK(...) */
/* The length of WORK should be at least N*N + 11*N + 300 */
/* and LENW should be set to the value used. The contents of */
/* WORK should not be disturbed between calls to SDRIV1. */
/* IERFLG = An error flag. The error number associated with a */
/* diagnostic message (see Section IV-A below) is the same as */
/* the corresponding value of IERFLG. The meaning of IERFLG: */
/* 0 The routine completed successfully. (No message is */
/* issued.) */
/* 3 (Warning) The number of steps required to reach TOUT */
/* exceeds 1000 . */
/* 4 (Warning) The value of EPS is too small. */
/* 11 (Warning) For MSTATE negative, T is beyond TOUT. */
/* The solution was obtained by interpolation. */
/* 15 (Warning) The integration step size is below the */
/* roundoff level of T. (The program issues this */
/* message as a warning but does not return control to */
/* the user.) */
/* 21 (Recoverable) N is greater than 200 . */
/* 22 (Recoverable) N is not positive. */
/* 26 (Recoverable) The magnitude of MSTATE is either 0 or */
/* greater than 7 . */
/* 27 (Recoverable) EPS is less than zero. */
/* 32 (Recoverable) Insufficient storage has been allocated */
/* for the WORK array. */
/* 41 (Recoverable) The integration step size has gone */
/* to zero. */
/* 42 (Recoverable) The integration step size has been */
/* reduced about 50 times without advancing the */
/* solution. The problem setup may not be correct. */
/* 999 (Fatal) The magnitude of MSTATE is 7 . */
/* III. USAGE ........................................................ */
/* PROGRAM SAMPLE */
/* EXTERNAL F */
/* REAL ALFA, EPS, T, TOUT */
/* C N is the number of equations */
/* PARAMETER(ALFA = 1.E0, N = 3, LENW = N*N + 11*N + 300) */
/* REAL WORK(LENW), Y(N+1) */
/* C Initial point */
/* T = 0.00001E0 */
/* C Set initial conditions */
/* Y(1) = 10.E0 */
/* Y(2) = 0.E0 */
/* Y(3) = 10.E0 */
/* C Pass parameter */
/* Y(4) = ALFA */
/* TOUT = T */
/* MSTATE = 1 */
/* EPS = .001E0 */
/* 10 CALL SDRIV1 (N, T, Y, F, TOUT, MSTATE, EPS, WORK, LENW, */
/* 8 IERFLG) */
/* IF (MSTATE .GT. 2) STOP */
/* WRITE(*, '(4E12.3)') TOUT, (Y(I), I=1,3) */
/* TOUT = 10.E0*TOUT */
/* IF (TOUT .LT. 50.E0) GO TO 10 */
/* END */
/* SUBROUTINE F (N, T, Y, YDOT) */
/* REAL ALFA, T, Y(*), YDOT(*) */
/* ALFA = Y(N+1) */
/* YDOT(1) = 1.E0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) */
/* YDOT(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) */
/* YDOT(3) = 1.E0 - Y(3)*(Y(1) + Y(2)) */
/* END */
/* IV. OTHER COMMUNICATION TO THE USER ............................... */
/* A. The solver communicates to the user through the parameters */
/* above. In addition it writes diagnostic messages through the */
/* standard error handling program XERMSG. A complete description */
/* of XERMSG is given in "Guide to the SLATEC Common Mathematical */
/* Library" by Kirby W. Fong et al.. At installations which do not */
/* have this error handling package the short but serviceable */
/* routine, XERMSG, available with this package, can be used. That */
/* program uses the file named OUTPUT to transmit messages. */
/* B. The number of evaluations of the right hand side can be found */
/* in the WORK array in the location determined by: */
/* LENW - (N + 50) + 4 */
/* V. REMARKS ........................................................ */
/* For other information, see Section IV of the writeup for SDRIV3. */
/* ***REFERENCES C. W. Gear, Numerical Initial Value Problems in */
/* Ordinary Differential Equations, Prentice-Hall, 1971. */
/* ***ROUTINES CALLED SDRIV3, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 790601 DATE WRITTEN */
/* 900329 Initial submission to SLATEC. */
/* ***END PROLOGUE SDRIV1 */
/* Parameter adjustments */
--work;
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT SDRIV1 */
if (abs(*mstate) == 0 || abs(*mstate) > 7) {
s_wsfi(&io___3);
do_fio(&c__1, (char *)&(*mstate), (ftnlen)sizeof(integer));
e_wsfi();
*ierflg = 26;
/* Writing concatenation */
i__1[0] = 41, a__1[0] = "Illegal input. The magnitude of MSTATE, ";
i__1[1] = 8, a__1[1] = intgr1;
i__1[2] = 30, a__1[2] = ", is not in the range 1 to 6 .";
s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)79);
xermsg_("SLATEC", "SDRIV1", ch__1, ierflg, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)79);
*mstate = i_sign(&c__7, mstate);
return 0;
} else if (abs(*mstate) == 7) {
*ierflg = 999;
xermsg_("SLATEC", "SDRIV1", "Illegal input. The magnitude of MSTATE"
" is 7 .", ierflg, &c__2, (ftnlen)6, (ftnlen)6, (ftnlen)46);
return 0;
}
if (*n > 200) {
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
*ierflg = 21;
/* Writing concatenation */
i__1[0] = 41, a__1[0] = "Illegal input. The number of equations, ";
i__1[1] = 8, a__1[1] = intgr1;
i__1[2] = 44, a__1[2] = ", is greater than the maximum allowed: 200 ."
;
s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)93);
xermsg_("SLATEC", "SDRIV1", ch__2, ierflg, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)93);
*mstate = i_sign(&c__7, mstate);
return 0;
}
if (*mstate > 0) {
nstate = *mstate;
ntask = 1;
} else {
nstate = -(*mstate);
ntask = 3;
}
hmax = (r__1 = *tout - *t, dabs(r__1)) * 2.f;
leniw = *n + 50;
lenwcm = *lenw - leniw;
if (lenwcm < *n * *n + *n * 10 + 250) {
lnwchk = *n * *n + *n * 10 + 250 + leniw;
s_wsfi(&io___11);
do_fio(&c__1, (char *)&lnwchk, (ftnlen)sizeof(integer));
e_wsfi();
*ierflg = 32;
/* Writing concatenation */
i__1[0] = 85, a__1[0] = "Insufficient storage allocated for the work"
" array. The required storage is at least ";
i__1[1] = 8, a__1[1] = intgr1;
i__1[2] = 2, a__1[2] = " .";
s_cat(ch__3, a__1, i__1, &c__3, (ftnlen)95);
xermsg_("SLATEC", "SDRIV1", ch__3, ierflg, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)95);
*mstate = i_sign(&c__7, mstate);
return 0;
}
if (nstate != 1) {
i__2 = leniw;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L20: */
iwork[i__ - 1] = work[i__ + lenwcm];
}
}
sdriv3_(n, t, &y[1], (U_fp)f, &nstate, tout, &ntask, &c__0, eps, ewtcom, &
c__2, &c__2, &c__2, &c__0, &ml, &mu, &c__5, &hmax, &work[1], &
lenwcm, iwork, &leniw, (U_fp)f, (U_fp)f, &nde, &c__1000, (U_fp)f,
(U_fp)f, ierflg);
i__2 = leniw;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L40: */
work[i__ + lenwcm] = (real) iwork[i__ - 1];
}
if (nstate <= 4) {
*mstate = i_sign(&nstate, mstate);
} else if (nstate == 6) {
*mstate = i_sign(&c__5, mstate);
} else if (*ierflg == 11) {
*mstate = i_sign(&c__6, mstate);
} else if (*ierflg > 11) {
*mstate = i_sign(&c__7, mstate);
}
return 0;
} /* sdriv1_ */
/* DECK DP1VLU */
/* Subroutine */ int dp1vlu_(integer *l, integer *nder, doublereal *x,
doublereal *yfit, doublereal *yp, doublereal *a)
{
/* System generated locals */
address a__1[5];
integer i__1, i__2, i__3[5];
char ch__1[150];
icilist ici__1;
/* Builtin functions */
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
;
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
integer i__, n, k1, k2, k3, k4;
doublereal cc;
integer ic, kc, in, k1i, lm1, lp1;
doublereal dif;
integer k3p1, k4p1, ndo;
doublereal val;
integer ilo, iup, ndp1, inp1, k3pn, k4pn, nord;
char xern1[8], xern2[8];
integer maxord;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DP1VLU */
/* ***PURPOSE Use the coefficients generated by DPOLFT to evaluate the */
/* polynomial fit of degree L, along with the first NDER of */
/* its derivatives, at a specified point. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY K6 */
/* ***TYPE DOUBLE PRECISION (PVALUE-S, DP1VLU-D) */
/* ***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION */
/* ***AUTHOR Shampine, L. F., (SNLA) */
/* Davenport, S. M., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* The subroutine DP1VLU uses the coefficients generated by DPOLFT */
/* to evaluate the polynomial fit of degree L , along with the first */
/* NDER of its derivatives, at a specified point. Computationally */
/* stable recurrence relations are used to perform this task. */
/* The parameters for DP1VLU are */
/* Input -- ALL TYPE REAL variables are DOUBLE PRECISION */
/* L - the degree of polynomial to be evaluated. L may be */
/* any non-negative integer which is less than or equal */
/* to NDEG , the highest degree polynomial provided */
/* by DPOLFT . */
/* NDER - the number of derivatives to be evaluated. NDER */
/* may be 0 or any positive value. If NDER is less */
/* than 0, it will be treated as 0. */
/* X - the argument at which the polynomial and its */
/* derivatives are to be evaluated. */
/* A - work and output array containing values from last */
/* call to DPOLFT . */
/* Output -- ALL TYPE REAL variables are DOUBLE PRECISION */
/* YFIT - value of the fitting polynomial of degree L at X */
/* YP - array containing the first through NDER derivatives */
/* of the polynomial of degree L . YP must be */
/* dimensioned at least NDER in the calling program. */
/* ***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, */
/* Curve fitting by polynomials in one variable, Report */
/* SLA-74-0270, Sandia Laboratories, June 1974. */
/* ***ROUTINES CALLED XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 740601 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (WRB) */
/* 891006 Cosmetic changes to prologue. (WRB) */
/* 891006 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE DP1VLU */
/* ***FIRST EXECUTABLE STATEMENT DP1VLU */
/* Parameter adjustments */
--a;
--yp;
/* Function Body */
if (*l < 0) {
goto L12;
}
ndo = max(*nder,0);
ndo = min(ndo,*l);
maxord = (integer) (a[1] + .5);
k1 = maxord + 1;
k2 = k1 + maxord;
k3 = k2 + maxord + 2;
nord = (integer) (a[k3] + .5);
if (*l > nord) {
goto L11;
}
k4 = k3 + *l + 1;
if (*nder < 1) {
goto L2;
}
i__1 = *nder;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L1: */
yp[i__] = 0.;
}
L2:
if (*l >= 2) {
goto L4;
}
if (*l == 1) {
goto L3;
}
/* L IS 0 */
val = a[k2 + 1];
goto L10;
/* L IS 1 */
L3:
cc = a[k2 + 2];
val = a[k2 + 1] + (*x - a[2]) * cc;
if (*nder >= 1) {
yp[1] = cc;
}
goto L10;
/* L IS GREATER THAN 1 */
L4:
ndp1 = ndo + 1;
k3p1 = k3 + 1;
k4p1 = k4 + 1;
lp1 = *l + 1;
lm1 = *l - 1;
ilo = k3 + 3;
iup = k4 + ndp1;
i__1 = iup;
for (i__ = ilo; i__ <= i__1; ++i__) {
/* L5: */
a[i__] = 0.;
}
dif = *x - a[lp1];
kc = k2 + lp1;
a[k4p1] = a[kc];
a[k3p1] = a[kc - 1] + dif * a[k4p1];
a[k3 + 2] = a[k4p1];
/* EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES */
i__1 = lm1;
for (i__ = 1; i__ <= i__1; ++i__) {
in = *l - i__;
inp1 = in + 1;
k1i = k1 + inp1;
ic = k2 + in;
dif = *x - a[inp1];
val = a[ic] + dif * a[k3p1] - a[k1i] * a[k4p1];
if (ndo <= 0) {
goto L8;
}
i__2 = ndo;
for (n = 1; n <= i__2; ++n) {
k3pn = k3p1 + n;
k4pn = k4p1 + n;
/* L6: */
yp[n] = dif * a[k3pn] + n * a[k3pn - 1] - a[k1i] * a[k4pn];
}
/* SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS */
i__2 = ndo;
for (n = 1; n <= i__2; ++n) {
k3pn = k3p1 + n;
k4pn = k4p1 + n;
a[k4pn] = a[k3pn];
/* L7: */
a[k3pn] = yp[n];
}
L8:
a[k4p1] = a[k3p1];
/* L9: */
a[k3p1] = val;
}
/* NORMAL RETURN OR ABORT DUE TO ERROR */
L10:
*yfit = val;
return 0;
L11:
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 8;
ici__1.iciunit = xern1;
ici__1.icifmt = "(I8)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&(*l), (ftnlen)sizeof(integer));
e_wsfi();
ici__1.icierr = 0;
ici__1.icirnum = 1;
ici__1.icirlen = 8;
ici__1.iciunit = xern2;
ici__1.icifmt = "(I8)";
s_wsfi(&ici__1);
do_fio(&c__1, (char *)&nord, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 40, a__1[0] = "THE ORDER OF POLYNOMIAL EVALUATION, L = ";
i__3[1] = 8, a__1[1] = xern1;
i__3[2] = 49, a__1[2] = " REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD "
"= ";
i__3[3] = 8, a__1[3] = xern2;
i__3[4] = 45, a__1[4] = ", COMPUTED BY DPOLFT -- EXECUTION TERMINATED.";
s_cat(ch__1, a__1, i__3, &c__5, (ftnlen)150);
xermsg_("SLATEC", "DP1VLU", ch__1, &c__8, &c__2, (ftnlen)6, (ftnlen)6, (
ftnlen)150);
return 0;
L12:
xermsg_("SLATEC", "DP1VLU", "INVALID INPUT PARAMETER. ORDER OF POLYNOMI"
"AL EVALUATION REQUESTED IS NEGATIVE.", &c__2, &c__2, (ftnlen)6, (
ftnlen)6, (ftnlen)79);
return 0;
} /* dp1vlu_ */
/* DECK LSOD */
/* Subroutine */ int lsod_(S_fp f, integer *neq, real *t, real *y, real *tout,
real *rtol, real *atol, integer *idid, real *ypout, real *yh, real *
yh1, real *ewt, real *savf, real *acor, real *wm, integer *iwm, U_fp
jac, logical *intout, real *tstop, real *tolfac, real *delsgn, real *
rpar, integer *ipar)
{
/* Initialized data */
static integer maxnum = 500;
/* System generated locals */
address a__1[2], a__2[7], a__3[6], a__4[8], a__5[3], a__6[5];
integer yh_dim1, yh_offset, i__1[2], i__2, i__3[7], i__4[6], i__5[8],
i__6[3], i__7[5];
real r__1, r__2, r__3, r__4;
char ch__1[107], ch__2[215], ch__3[207], ch__4[111], ch__5[127], ch__6[
158];
/* Local variables */
static integer k, l;
static real ha, dt, big, del, tol;
extern /* Subroutine */ int stod_(integer *, real *, real *, integer *,
real *, real *, real *, real *, real *, integer *, S_fp, U_fp,
real *, integer *);
static integer ltol;
static char xern1[8], xern3[16], xern4[16];
extern /* Subroutine */ int intyd_(real *, integer *, real *, integer *,
real *, integer *);
extern doublereal r1mach_(integer *);
static real absdel;
static integer intflg, natolp;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen), hstart_(S_fp, integer *, real
*, real *, real *, real *, real *, integer *, real *, real *,
real *, real *, real *, real *, real *, integer *, real *);
static integer nrtolp;
extern doublereal vnwrms_(integer *, real *, real *);
/* Fortran I/O blocks */
static icilist io___3 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___7 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___9 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
static icilist io___10 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___11 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
static icilist io___12 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
static icilist io___14 = { 0, xern4, 0, "(1PE15.6)", 16, 1 };
static icilist io___15 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
static icilist io___16 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
static icilist io___17 = { 0, xern4, 0, "(1PE15.6)", 16, 1 };
static icilist io___18 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
/* ***BEGIN PROLOGUE LSOD */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DEBDF */
/* ***LIBRARY SLATEC */
/* ***TYPE SINGLE PRECISION (LSOD-S, DLSOD-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* DEBDF merely allocates storage for LSOD to relieve the user of */
/* the inconvenience of a long call list. Consequently LSOD is used */
/* as described in the comments for DEBDF . */
/* ***SEE ALSO DEBDF */
/* ***ROUTINES CALLED HSTART, INTYD, R1MACH, STOD, VNWRMS, XERMSG */
/* ***COMMON BLOCKS DEBDF1 */
/* ***REVISION HISTORY (YYMMDD) */
/* 800901 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* ***END PROLOGUE LSOD */
/* ....................................................................... */
/* THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE */
/* NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER */
/* IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE */
/* WORK. */
/* Parameter adjustments */
yh_dim1 = *neq;
yh_offset = 1 + yh_dim1;
yh -= yh_offset;
--y;
--rtol;
--atol;
--ypout;
--yh1;
--ewt;
--savf;
--acor;
--wm;
--iwm;
--rpar;
--ipar;
/* Function Body */
/* ....................................................................... */
/* ***FIRST EXECUTABLE STATEMENT LSOD */
if (debdf1_1.ibegin == 0) {
/* ON THE FIRST CALL , PERFORM INITIALIZATION -- */
/* DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE */
/* FUNCTION ROUTINE R1MACH. THE USER MUST MAKE SURE THAT THE */
/* VALUES SET IN R1MACH ARE RELEVANT TO THE COMPUTER BEING USED. */
debdf1_1.u = r1mach_(&c__4);
/* -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER */
wm[1] = sqrt(debdf1_1.u);
/* -- SET TERMINATION FLAG */
debdf1_1.iquit = 0;
/* -- SET INITIALIZATION INDICATOR */
debdf1_1.init = 0;
/* -- SET COUNTER FOR ATTEMPTED STEPS */
debdf1_1.ksteps = 0;
/* -- SET INDICATOR FOR INTERMEDIATE-OUTPUT */
*intout = FALSE_;
/* -- SET START INDICATOR FOR STOD CODE */
debdf1_1.jstart = 0;
/* -- SET BDF METHOD INDICATOR */
debdf1_1.meth = 2;
/* -- SET MAXIMUM ORDER FOR BDF METHOD */
debdf1_1.maxord = 5;
/* -- SET ITERATION MATRIX INDICATOR */
if (debdf1_1.ijac == 0 && debdf1_1.iband == 0) {
debdf1_1.miter = 2;
}
if (debdf1_1.ijac == 1 && debdf1_1.iband == 0) {
debdf1_1.miter = 1;
}
if (debdf1_1.ijac == 0 && debdf1_1.iband == 1) {
debdf1_1.miter = 5;
}
if (debdf1_1.ijac == 1 && debdf1_1.iband == 1) {
debdf1_1.miter = 4;
}
/* -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK */
debdf1_1.n = *neq;
debdf1_1.nst = 0;
debdf1_1.nje = 0;
debdf1_1.hmxi = 0.f;
debdf1_1.nq = 1;
debdf1_1.h__ = 1.f;
/* -- RESET IBEGIN FOR SUBSEQUENT CALLS */
debdf1_1.ibegin = 1;
}
/* ....................................................................... */
/* CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY */
if (*neq < 1) {
s_wsfi(&io___3);
do_fio(&c__1, (char *)&(*neq), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 99, a__1[0] = "IN DEBDF, THE NUMBER OF EQUATIONS MUST BE A"
" POSITIVE INTEGER.$$YOU HAVE CALLED THE CODE WITH NEQ = ";
i__1[1] = 8, a__1[1] = xern1;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)107);
xermsg_("SLATEC", "LSOD", ch__1, &c__6, &c__1, (ftnlen)6, (ftnlen)4, (
ftnlen)107);
*idid = -33;
}
nrtolp = 0;
natolp = 0;
i__2 = *neq;
for (k = 1; k <= i__2; ++k) {
if (nrtolp <= 0) {
if (rtol[k] < 0.f) {
s_wsfi(&io___7);
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___9);
do_fio(&c__1, (char *)&rtol[k], (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__3[0] = 98, a__2[0] = "IN DEBDF, THE RELATIVE ERROR TOLERA"
"NCES MUST BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE"
" WITH RTOL(";
i__3[1] = 8, a__2[1] = xern1;
i__3[2] = 4, a__2[2] = ") = ";
i__3[3] = 16, a__2[3] = xern3;
i__3[4] = 9, a__2[4] = "$$IN THE ";
i__3[5] = 44, a__2[5] = "CASE OF VECTOR ERROR TOLERANCES, NO"
" FURTHER ";
i__3[6] = 36, a__2[6] = "CHECKING OF RTOL COMPONENTS IS DONE."
;
s_cat(ch__2, a__2, i__3, &c__7, (ftnlen)215);
xermsg_("SLATEC", "LSOD", ch__2, &c__7, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)215);
*idid = -33;
if (natolp > 0) {
goto L70;
}
nrtolp = 1;
} else if (natolp > 0) {
goto L50;
}
}
if (atol[k] < 0.f) {
s_wsfi(&io___10);
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___11);
do_fio(&c__1, (char *)&atol[k], (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__4[0] = 98, a__3[0] = "IN DEBDF, THE ABSOLUTE ERROR TOLERANCES"
" MUST BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE WITH AT"
"OL(";
i__4[1] = 8, a__3[1] = xern1;
i__4[2] = 4, a__3[2] = ") = ";
i__4[3] = 16, a__3[3] = xern3;
i__4[4] = 53, a__3[4] = "$$IN THE CASE OF VECTOR ERROR TOLERANCE"
"S, NO FURTHER ";
i__4[5] = 36, a__3[5] = "CHECKING OF ATOL COMPONENTS IS DONE.";
s_cat(ch__2, a__3, i__4, &c__6, (ftnlen)215);
xermsg_("SLATEC", "LSOD", ch__2, &c__8, &c__1, (ftnlen)6, (ftnlen)
4, (ftnlen)215);
*idid = -33;
if (nrtolp > 0) {
goto L70;
}
natolp = 1;
}
L50:
if (debdf1_1.itol == 0) {
goto L70;
}
/* L60: */
}
L70:
if (debdf1_1.itstop == 1) {
r__3 = *tout - *t;
r__4 = *tstop - *t;
if (r_sign(&c_b41, &r__3) != r_sign(&c_b41, &r__4) || (r__1 = *tout -
*t, dabs(r__1)) > (r__2 = *tstop - *t, dabs(r__2))) {
s_wsfi(&io___12);
do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(real));
e_wsfi();
s_wsfi(&io___14);
do_fio(&c__1, (char *)&(*tstop), (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__5[0] = 47, a__4[0] = "IN DEBDF, YOU HAVE CALLED THE CODE WITH"
" TOUT = ";
i__5[1] = 16, a__4[1] = xern3;
i__5[2] = 15, a__4[2] = "$$BUT YOU HAVE ";
i__5[3] = 51, a__4[3] = "ALSO TOLD THE CODE NOT TO INTEGRATE PAS"
"T THE POINT ";
i__5[4] = 8, a__4[4] = "TSTOP = ";
i__5[5] = 16, a__4[5] = xern4;
i__5[6] = 26, a__4[6] = " BY SETTING INFO(4) = 1. ";
i__5[7] = 28, a__4[7] = "THESE INSTRUCTIONS CONFLICT.";
s_cat(ch__3, a__4, i__5, &c__8, (ftnlen)207);
xermsg_("SLATEC", "LSOD", ch__3, &c__14, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)207);
*idid = -33;
}
}
/* CHECK SOME CONTINUATION POSSIBILITIES */
if (debdf1_1.init != 0) {
if (*t == *tout) {
s_wsfi(&io___15);
do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__6[0] = 51, a__5[0] = "IN DEBDF, YOU HAVE CALLED THE CODE WITH"
" T = TOUT = ";
i__6[1] = 16, a__5[1] = xern3;
i__6[2] = 44, a__5[2] = " THIS IS NOT ALLOWED ON CONTINUATION C"
"ALLS.";
s_cat(ch__4, a__5, i__6, &c__3, (ftnlen)111);
xermsg_("SLATEC", "LSOD", ch__4, &c__9, &c__1, (ftnlen)6, (ftnlen)
4, (ftnlen)111);
*idid = -33;
}
if (*t != debdf1_1.told) {
s_wsfi(&io___16);
do_fio(&c__1, (char *)&debdf1_1.told, (ftnlen)sizeof(real));
e_wsfi();
s_wsfi(&io___17);
do_fio(&c__1, (char *)&(*t), (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__7[0] = 47, a__6[0] = "IN DEBDF, YOU HAVE CHANGED THE VALUE OF"
" T FROM ";
i__7[1] = 16, a__6[1] = xern3;
i__7[2] = 4, a__6[2] = " TO ";
i__7[3] = 16, a__6[3] = xern4;
i__7[4] = 44, a__6[4] = " THIS IS NOT ALLOWED ON CONTINUATION C"
"ALLS.";
s_cat(ch__5, a__6, i__7, &c__5, (ftnlen)127);
xermsg_("SLATEC", "LSOD", ch__5, &c__10, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)127);
*idid = -33;
}
if (debdf1_1.init != 1) {
if (*delsgn * (*tout - *t) < 0.f) {
s_wsfi(&io___18);
do_fio(&c__1, (char *)&(*tout), (ftnlen)sizeof(real));
e_wsfi();
/* Writing concatenation */
i__7[0] = 42, a__6[0] = "IN DEBDF, BY CALLING THE CODE WITH "
"TOUT = ";
i__7[1] = 16, a__6[1] = xern3;
i__7[2] = 34, a__6[2] = " YOU ARE ATTEMPTING TO CHANGE THE ";
i__7[3] = 27, a__6[3] = "DIRECTION OF INTEGRATION.$$";
i__7[4] = 39, a__6[4] = "THIS IS NOT ALLOWED WITHOUT RESTART"
"ING.";
s_cat(ch__6, a__6, i__7, &c__5, (ftnlen)158);
xermsg_("SLATEC", "LSOD", ch__6, &c__11, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)158);
*idid = -33;
}
}
}
if (*idid == -33) {
if (debdf1_1.iquit != -33) {
/* INVALID INPUT DETECTED */
debdf1_1.iquit = -33;
debdf1_1.ibegin = -1;
} else {
xermsg_("SLATEC", "LSOD", "IN DEBDF, INVALID INPUT WAS DETECTED "
"ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE TO PROCEED BECA"
"USE YOU HAVE NOT CORRECTED THE PROBLEM, SO EXECUTION IS "
"BEING TERMINATED.", &c__12, &c__2, (ftnlen)6, (ftnlen)4, (
ftnlen)166);
}
return 0;
}
/* ....................................................................... */
/* RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS */
/* ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, */
/* THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE */
/* 100*U WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE */
i__2 = *neq;
for (k = 1; k <= i__2; ++k) {
if (rtol[k] + atol[k] > 0.f) {
goto L160;
}
rtol[k] = debdf1_1.u * 100.f;
*idid = -2;
L160:
if (debdf1_1.itol == 0) {
goto L180;
}
/* L170: */
}
L180:
if (*idid != -2) {
goto L190;
}
/* RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A */
/* SMALL POSITIVE VALUE */
debdf1_1.ibegin = -1;
return 0;
/* BRANCH ON STATUS OF INITIALIZATION INDICATOR */
/* INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE */
/* AND DIRECTION NOT YET SET */
/* INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET */
/* INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED */
L190:
if (debdf1_1.init == 0) {
goto L200;
}
if (debdf1_1.init == 1) {
goto L220;
}
goto L240;
/* ....................................................................... */
/* MORE INITIALIZATION -- */
/* -- EVALUATE INITIAL DERIVATIVES */
L200:
debdf1_1.init = 1;
(*f)(t, &y[1], &yh[(yh_dim1 << 1) + 1], &rpar[1], &ipar[1]);
debdf1_1.nfe = 1;
if (*t != *tout) {
goto L220;
}
*idid = 2;
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
/* L210: */
ypout[l] = yh[l + (yh_dim1 << 1)];
}
debdf1_1.told = *t;
return 0;
/* -- COMPUTE INITIAL STEP SIZE */
/* -- SAVE SIGN OF INTEGRATION DIRECTION */
/* -- SET INDEPENDENT AND DEPENDENT VARIABLES */
/* X AND YH(*) FOR STOD */
L220:
ltol = 1;
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
if (debdf1_1.itol == 1) {
ltol = l;
}
tol = rtol[ltol] * (r__1 = y[l], dabs(r__1)) + atol[ltol];
if (tol == 0.f) {
goto L380;
}
/* L225: */
ewt[l] = tol;
}
big = sqrt(r1mach_(&c__2));
hstart_((S_fp)f, neq, t, tout, &y[1], &yh[(yh_dim1 << 1) + 1], &ewt[1], &
c__1, &debdf1_1.u, &big, &yh[yh_dim1 * 3 + 1], &yh[(yh_dim1 << 2)
+ 1], &yh[yh_dim1 * 5 + 1], &yh[yh_dim1 * 6 + 1], &rpar[1], &ipar[
1], &debdf1_1.h__);
r__1 = *tout - *t;
*delsgn = r_sign(&c_b41, &r__1);
debdf1_1.x = *t;
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
yh[l + yh_dim1] = y[l];
/* L230: */
yh[l + (yh_dim1 << 1)] = debdf1_1.h__ * yh[l + (yh_dim1 << 1)];
}
debdf1_1.init = 2;
/* ....................................................................... */
/* ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL */
/* OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT */
L240:
del = *tout - *t;
absdel = dabs(del);
/* ....................................................................... */
/* IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN */
L250:
if ((r__1 = debdf1_1.x - *t, dabs(r__1)) < absdel) {
goto L270;
}
intyd_(tout, &c__0, &yh[yh_offset], neq, &y[1], &intflg);
intyd_(tout, &c__1, &yh[yh_offset], neq, &ypout[1], &intflg);
*idid = 3;
if (debdf1_1.x != *tout) {
goto L260;
}
*idid = 2;
*intout = FALSE_;
L260:
*t = *tout;
debdf1_1.told = *t;
return 0;
/* IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, */
/* EXTRAPOLATE AND RETURN */
L270:
if (debdf1_1.itstop != 1) {
goto L290;
}
if ((r__1 = *tstop - debdf1_1.x, dabs(r__1)) >= debdf1_1.u * 100.f * dabs(
debdf1_1.x)) {
goto L290;
}
dt = *tout - debdf1_1.x;
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
/* L280: */
y[l] = yh[l + yh_dim1] + dt / debdf1_1.h__ * yh[l + (yh_dim1 << 1)];
}
(*f)(tout, &y[1], &ypout[1], &rpar[1], &ipar[1]);
++debdf1_1.nfe;
*idid = 3;
*t = *tout;
debdf1_1.told = *t;
return 0;
L290:
if (debdf1_1.iinteg == 0 || ! (*intout)) {
goto L300;
}
/* INTERMEDIATE-OUTPUT MODE */
*idid = 1;
goto L500;
/* ....................................................................... */
/* MONITOR NUMBER OF STEPS ATTEMPTED */
L300:
if (debdf1_1.ksteps <= maxnum) {
goto L330;
}
/* A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED */
*idid = -1;
debdf1_1.ksteps = 0;
debdf1_1.ibegin = -1;
goto L500;
/* ....................................................................... */
/* LIMIT STEP SIZE AND SET WEIGHT VECTOR */
L330:
debdf1_1.hmin = debdf1_1.u * 100.f * dabs(debdf1_1.x);
/* Computing MAX */
r__1 = dabs(debdf1_1.h__);
ha = dmax(r__1,debdf1_1.hmin);
if (debdf1_1.itstop != 1) {
goto L340;
}
/* Computing MIN */
r__2 = ha, r__3 = (r__1 = *tstop - debdf1_1.x, dabs(r__1));
ha = dmin(r__2,r__3);
L340:
debdf1_1.h__ = r_sign(&ha, &debdf1_1.h__);
ltol = 1;
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
if (debdf1_1.itol == 1) {
ltol = l;
}
ewt[l] = rtol[ltol] * (r__1 = yh[l + yh_dim1], dabs(r__1)) + atol[
ltol];
if (ewt[l] <= 0.f) {
goto L380;
}
/* L350: */
}
*tolfac = debdf1_1.u * vnwrms_(neq, &yh[yh_offset], &ewt[1]);
if (*tolfac <= 1.f) {
goto L400;
}
/* TOLERANCES TOO SMALL */
*idid = -2;
*tolfac *= 2.f;
rtol[1] = *tolfac * rtol[1];
atol[1] = *tolfac * atol[1];
if (debdf1_1.itol == 0) {
goto L370;
}
i__2 = *neq;
for (l = 2; l <= i__2; ++l) {
rtol[l] = *tolfac * rtol[l];
/* L360: */
atol[l] = *tolfac * atol[l];
}
L370:
debdf1_1.ibegin = -1;
goto L500;
/* RELATIVE ERROR CRITERION INAPPROPRIATE */
L380:
*idid = -3;
debdf1_1.ibegin = -1;
goto L500;
/* ....................................................................... */
/* TAKE A STEP */
L400:
stod_(neq, &y[1], &yh[yh_offset], neq, &yh1[1], &ewt[1], &savf[1], &acor[
1], &wm[1], &iwm[1], (S_fp)f, (U_fp)jac, &rpar[1], &ipar[1]);
debdf1_1.jstart = -2;
*intout = TRUE_;
if (debdf1_1.kflag == 0) {
goto L250;
}
/* ....................................................................... */
if (debdf1_1.kflag == -1) {
goto L450;
}
/* REPEATED CORRECTOR CONVERGENCE FAILURES */
*idid = -6;
debdf1_1.ibegin = -1;
goto L500;
/* REPEATED ERROR TEST FAILURES */
L450:
*idid = -7;
debdf1_1.ibegin = -1;
/* ....................................................................... */
/* STORE VALUES BEFORE RETURNING TO DEBDF */
L500:
i__2 = *neq;
for (l = 1; l <= i__2; ++l) {
y[l] = yh[l + yh_dim1];
/* L555: */
ypout[l] = yh[l + (yh_dim1 << 1)] / debdf1_1.h__;
}
*t = debdf1_1.x;
debdf1_1.told = *t;
*intout = FALSE_;
return 0;
} /* lsod_ */
/* DECK DFCMN */
/* Subroutine */ int dfcmn_(integer *ndata, doublereal *xdata, doublereal *
ydata, doublereal *sddata, integer *nord, integer *nbkpt, doublereal *
bkptin, integer *nconst, doublereal *xconst, doublereal *yconst,
integer *nderiv, integer *mode, doublereal *coeff, doublereal *bf,
doublereal *xtemp, doublereal *ptemp, doublereal *bkpt, doublereal *g,
integer *mdg, doublereal *w, integer *mdw, doublereal *work, integer
*iwork)
{
/* System generated locals */
address a__1[2];
integer bf_dim1, bf_offset, g_dim1, g_offset, w_dim1, w_offset, i__1,
i__2[2], i__3, i__4;
doublereal d__1, d__2;
char ch__1[59], ch__2[61];
/* Local variables */
static integer i__, l, n, nb, ip, ir, mt, lw, np1, iw1, iw2;
static logical var, new__, band;
static doublereal xval, xmin, yval, xmax;
static integer irow;
static char xern1[8];
static integer intw1, idata;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dlsei_(doublereal *, integer *, integer *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer ileft;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer itype;
extern /* Subroutine */ int dsort_(doublereal *, doublereal *, integer *,
integer *);
static doublereal dummy, rnorm;
static integer nordm1, nordp1;
extern /* Subroutine */ int dbndac_(doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *), dbndsl_(integer *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *);
static integer ideriv, neqcon, nincon;
extern /* Subroutine */ int dfspvd_(doublereal *, integer *, doublereal *,
integer *, doublereal *, integer *), dfspvn_(doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *);
static doublereal rnorme;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static doublereal rnorml, prgopt[10];
static integer intrvl;
/* Fortran I/O blocks */
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___32 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___33 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE DFCMN */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to FC */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (FCMN-S, DFCMN-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* This is a companion subprogram to DFC( ). */
/* The documentation for DFC( ) has complete usage instructions. */
/* ***SEE ALSO DFC */
/* ***ROUTINES CALLED DAXPY, DBNDAC, DBNDSL, DCOPY, DFSPVD, DFSPVN, */
/* DLSEI, DSCAL, DSORT, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 780801 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890618 Completely restructured and extensively revised (WRB & RWC) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 900604 DP version created from SP version. (RWC) */
/* ***END PROLOGUE DFCMN */
/* ***FIRST EXECUTABLE STATEMENT DFCMN */
/* Analyze input. */
/* Parameter adjustments */
--xdata;
--ydata;
--sddata;
bf_dim1 = *nord;
bf_offset = 1 + bf_dim1;
bf -= bf_offset;
--bkptin;
--xconst;
--yconst;
--nderiv;
--coeff;
--xtemp;
--ptemp;
--bkpt;
g_dim1 = *mdg;
g_offset = 1 + g_dim1;
g -= g_offset;
w_dim1 = *mdw;
w_offset = 1 + w_dim1;
w -= w_offset;
--work;
--iwork;
/* Function Body */
if (*nord < 1 || *nord > 20) {
xermsg_("SLATEC", "DFCMN", "IN DFC, THE ORDER OF THE B-SPLINE MUST B"
"E 1 THRU 20.", &c__2, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)52)
;
*mode = -1;
return 0;
} else if (*nbkpt < *nord << 1) {
xermsg_("SLATEC", "DFCMN", "IN DFC, THE NUMBER OF KNOTS MUST BE AT L"
"EAST TWICE THE B-SPLINE ORDER.", &c__2, &c__1, (ftnlen)6, (
ftnlen)5, (ftnlen)70);
*mode = -1;
return 0;
}
if (*ndata < 0) {
xermsg_("SLATEC", "DFCMN", "IN DFC, THE NUMBER OF DATA POINTS MUST B"
"E NONNEGATIVE.", &c__2, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)
54);
*mode = -1;
return 0;
}
/* Amount of storage allocated for W(*), IW(*). */
iw1 = iwork[1];
iw2 = iwork[2];
/* Computing 2nd power */
i__1 = *nord;
nb = (*nbkpt - *nord + 3) * (*nord + 1) + (max(*ndata,*nbkpt) << 1) + *
nbkpt + i__1 * i__1;
/* See if sufficient storage has been allocated. */
if (iw1 < nb) {
s_wsfi(&io___5);
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 51, a__1[0] = "IN DFC, INSUFFICIENT STORAGE FOR W(*). CHE"
"CK NB = ";
i__2[1] = 8, a__1[1] = xern1;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)59);
xermsg_("SLATEC", "DFCMN", ch__1, &c__2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)59);
*mode = -1;
return 0;
}
if (*mode == 1) {
band = TRUE_;
var = FALSE_;
new__ = TRUE_;
} else if (*mode == 2) {
band = FALSE_;
var = TRUE_;
new__ = TRUE_;
} else if (*mode == 3) {
band = TRUE_;
var = FALSE_;
new__ = FALSE_;
} else if (*mode == 4) {
band = FALSE_;
var = TRUE_;
new__ = FALSE_;
} else {
xermsg_("SLATEC", "DFCMN", "IN DFC, INPUT VALUE OF MODE MUST BE 1-4.",
&c__2, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)40);
*mode = -1;
return 0;
}
*mode = 0;
/* Sort the breakpoints. */
dcopy_(nbkpt, &bkptin[1], &c__1, &bkpt[1], &c__1);
dsort_(&bkpt[1], &dummy, nbkpt, &c__1);
/* Initialize variables. */
neqcon = 0;
nincon = 0;
i__1 = *nconst;
for (i__ = 1; i__ <= i__1; ++i__) {
l = nderiv[i__];
itype = l % 4;
if (itype < 2) {
++nincon;
} else {
++neqcon;
}
/* L100: */
}
/* Compute the number of variables. */
n = *nbkpt - *nord;
np1 = n + 1;
lw = nb + (np1 + *nconst) * np1 + (neqcon + np1 << 1) + (nincon + np1) + (
nincon + 2) * (np1 + 6);
intw1 = nincon + (np1 << 1);
/* Save interval containing knots. */
xmin = bkpt[*nord];
xmax = bkpt[np1];
/* Find the smallest referenced independent variable value in any */
/* constraint. */
i__1 = *nconst;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MIN */
d__1 = xmin, d__2 = xconst[i__];
xmin = min(d__1,d__2);
/* Computing MAX */
d__1 = xmax, d__2 = xconst[i__];
xmax = max(d__1,d__2);
/* L110: */
}
nordm1 = *nord - 1;
nordp1 = *nord + 1;
/* Define the option vector PRGOPT(1-10) for use in DLSEI( ). */
prgopt[0] = 4.;
/* Set the covariance matrix computation flag. */
prgopt[1] = 1.;
if (var) {
prgopt[2] = 1.;
} else {
prgopt[2] = 0.;
}
/* Increase the rank determination tolerances for both equality */
/* constraint equations and least squares equations. */
prgopt[3] = 7.;
prgopt[4] = 4.;
prgopt[5] = 1e-4;
prgopt[6] = 10.;
prgopt[7] = 5.;
prgopt[8] = 1e-4;
prgopt[9] = 1.;
/* Turn off work array length checking in DLSEI( ). */
iwork[1] = 0;
iwork[2] = 0;
/* Initialize variables and analyze input. */
if (new__) {
/* To process least squares equations sort data and an array of */
/* pointers. */
dcopy_(ndata, &xdata[1], &c__1, &xtemp[1], &c__1);
i__1 = *ndata;
for (i__ = 1; i__ <= i__1; ++i__) {
ptemp[i__] = (doublereal) i__;
/* L120: */
}
if (*ndata > 0) {
dsort_(&xtemp[1], &ptemp[1], ndata, &c__2);
xmin = min(xmin,xtemp[1]);
/* Computing MAX */
d__1 = xmax, d__2 = xtemp[*ndata];
xmax = max(d__1,d__2);
}
/* Fix breakpoint array if needed. */
i__1 = *nord;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MIN */
d__1 = bkpt[i__];
bkpt[i__] = min(d__1,xmin);
/* L130: */
}
i__1 = *nbkpt;
for (i__ = np1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = bkpt[i__];
bkpt[i__] = max(d__1,xmax);
/* L140: */
}
/* Initialize parameters of banded matrix processor, DBNDAC( ). */
mt = 0;
ip = 1;
ir = 1;
ileft = *nord;
i__1 = *ndata;
for (idata = 1; idata <= i__1; ++idata) {
/* Sorted indices are in PTEMP(*). */
l = (integer) ptemp[idata];
xval = xdata[l];
/* When interval changes, process equations in the last block. */
if (xval >= bkpt[ileft + 1]) {
i__3 = ileft - nordm1;
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &mt, &i__3);
mt = 0;
/* Move pointer up to have BKPT(ILEFT).LE.XVAL, */
/* ILEFT.LT.NP1. */
L150:
if (xval >= bkpt[ileft + 1] && ileft < n) {
++ileft;
goto L150;
}
}
/* Obtain B-spline function value. */
dfspvn_(&bkpt[1], nord, &c__1, &xval, &ileft, &bf[bf_offset]);
/* Move row into place. */
irow = ir + mt;
++mt;
dcopy_(nord, &bf[bf_offset], &c__1, &g[irow + g_dim1], mdg);
g[irow + nordp1 * g_dim1] = ydata[l];
/* Scale data if uncertainty is nonzero. */
if (sddata[l] != 0.) {
d__1 = 1. / sddata[l];
dscal_(&nordp1, &d__1, &g[irow + g_dim1], mdg);
}
/* When staging work area is exhausted, process rows. */
if (irow == *mdg - 1) {
i__3 = ileft - nordm1;
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &mt, &i__3);
mt = 0;
}
/* L160: */
}
/* Process last block of equations. */
i__1 = ileft - nordm1;
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &mt, &i__1);
/* Last call to adjust block positioning. */
dcopy_(&nordp1, &c_b45, &c__0, &g[ir + g_dim1], mdg);
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &c__1, &np1);
}
band = band && *nconst == 0;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
band = band && g[i__ + g_dim1] != 0.;
/* L170: */
}
/* Process banded least squares equations. */
if (band) {
dbndsl_(&c__1, &g[g_offset], mdg, nord, &ip, &ir, &coeff[1], &n, &
rnorm);
return 0;
}
/* Check further for sufficient storage in working arrays. */
if (iw1 < lw) {
s_wsfi(&io___32);
do_fio(&c__1, (char *)&lw, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 51, a__1[0] = "IN DFC, INSUFFICIENT STORAGE FOR W(*). CHE"
"CK LW = ";
i__2[1] = 8, a__1[1] = xern1;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)59);
xermsg_("SLATEC", "DFCMN", ch__1, &c__2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)59);
*mode = -1;
return 0;
}
if (iw2 < intw1) {
s_wsfi(&io___33);
do_fio(&c__1, (char *)&intw1, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 53, a__1[0] = "IN DFC, INSUFFICIENT STORAGE FOR IW(*). CH"
"ECK IW1 = ";
i__2[1] = 8, a__1[1] = xern1;
s_cat(ch__2, a__1, i__2, &c__2, (ftnlen)61);
xermsg_("SLATEC", "DFCMN", ch__2, &c__2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)61);
*mode = -1;
return 0;
}
/* Write equality constraints. */
/* Analyze constraint indicators for an equality constraint. */
neqcon = 0;
i__1 = *nconst;
for (idata = 1; idata <= i__1; ++idata) {
l = nderiv[idata];
itype = l % 4;
if (itype > 1) {
ideriv = l / 4;
++neqcon;
ileft = *nord;
xval = xconst[idata];
L180:
if (xval < bkpt[ileft + 1] || ileft >= n) {
goto L190;
}
++ileft;
goto L180;
L190:
i__3 = ideriv + 1;
dfspvd_(&bkpt[1], nord, &xval, &ileft, &bf[bf_offset], &i__3);
dcopy_(&np1, &c_b45, &c__0, &w[neqcon + w_dim1], mdw);
dcopy_(nord, &bf[(ideriv + 1) * bf_dim1 + 1], &c__1, &w[neqcon + (
ileft - nordm1) * w_dim1], mdw);
if (itype == 2) {
w[neqcon + np1 * w_dim1] = yconst[idata];
} else {
ileft = *nord;
yval = yconst[idata];
L200:
if (yval < bkpt[ileft + 1] || ileft >= n) {
goto L210;
}
++ileft;
goto L200;
L210:
i__3 = ideriv + 1;
dfspvd_(&bkpt[1], nord, &yval, &ileft, &bf[bf_offset], &i__3);
daxpy_(nord, &c_b74, &bf[(ideriv + 1) * bf_dim1 + 1], &c__1, &
w[neqcon + (ileft - nordm1) * w_dim1], mdw);
}
}
/* L220: */
}
/* Transfer least squares data. */
i__1 = np1;
for (i__ = 1; i__ <= i__1; ++i__) {
irow = i__ + neqcon;
dcopy_(&n, &c_b45, &c__0, &w[irow + w_dim1], mdw);
/* Computing MIN */
i__4 = np1 - i__;
i__3 = min(i__4,*nord);
dcopy_(&i__3, &g[i__ + g_dim1], mdg, &w[irow + i__ * w_dim1], mdw);
w[irow + np1 * w_dim1] = g[i__ + nordp1 * g_dim1];
/* L230: */
}
/* Write inequality constraints. */
/* Analyze constraint indicators for inequality constraints. */
nincon = 0;
i__1 = *nconst;
for (idata = 1; idata <= i__1; ++idata) {
l = nderiv[idata];
itype = l % 4;
if (itype < 2) {
ideriv = l / 4;
++nincon;
ileft = *nord;
xval = xconst[idata];
L240:
if (xval < bkpt[ileft + 1] || ileft >= n) {
goto L250;
}
++ileft;
goto L240;
L250:
i__3 = ideriv + 1;
dfspvd_(&bkpt[1], nord, &xval, &ileft, &bf[bf_offset], &i__3);
irow = neqcon + np1 + nincon;
dcopy_(&n, &c_b45, &c__0, &w[irow + w_dim1], mdw);
intrvl = ileft - nordm1;
dcopy_(nord, &bf[(ideriv + 1) * bf_dim1 + 1], &c__1, &w[irow +
intrvl * w_dim1], mdw);
if (itype == 1) {
w[irow + np1 * w_dim1] = yconst[idata];
} else {
w[irow + np1 * w_dim1] = -yconst[idata];
dscal_(nord, &c_b74, &w[irow + intrvl * w_dim1], mdw);
}
}
/* L260: */
}
/* Solve constrained least squares equations. */
dlsei_(&w[w_offset], mdw, &neqcon, &np1, &nincon, &n, prgopt, &coeff[1], &
rnorme, &rnorml, mode, &work[1], &iwork[1]);
return 0;
} /* dfcmn_ */
/* ----------------------------------------------------------------------- */
/* Main program */ int MAIN__(void)
{
/* System generated locals */
address a__1[7];
integer i__1, i__2[7], i__3, i__4;
alist al__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_rsfe(cilist *), do_fio(integer *, char *, ftnlen), e_rsfe(void),
s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char *, ftnlen);
integer f_rew(alist *), s_wsfe(cilist *), e_wsfe(void), s_wsfi(icilist *),
e_wsfi(void);
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
static integer i__, l, m, ld;
static char cmd[4];
static integer irc;
static real data[6];
static integer leng;
static char line[72];
static integer nred, nmem, ipos, kpos, iout;
static char type__[1];
static real work[300000];
static integer ldata;
static char aleng[6];
extern /* Subroutine */ int pdsin_(char *, char *, real *, integer *,
integer *, integer *, ftnlen, ftnlen);
static integer iomls, iotxt;
extern /* Subroutine */ int setli1_(char *, integer *, real *, integer *,
ftnlen), setli2_(char *, integer *, real *, integer *, ftnlen),
setli3_(char *, integer *, real *, integer *, ftnlen);
static char member[8], dirnam[72], memnam[8*4000];
extern /* Subroutine */ int setlin_(char *, integer *, real *, ftnlen),
memlst_(integer *, integer *, char *, ftnlen), uioset_(void),
txtlin_(integer *, integer *);
/* Fortran I/O blocks */
static cilist io___7 = { 0, 5, 0, "(A72)", 0 };
static cilist io___9 = { 0, 6, 0, 0, 0 };
static cilist io___10 = { 0, 6, 0, 0, 0 };
static cilist io___11 = { 0, 6, 0, 0, 0 };
static cilist io___13 = { 0, 0, 0, "(A72)", 0 };
static cilist io___16 = { 0, 6, 0, 0, 0 };
static cilist io___22 = { 0, 6, 0, 0, 0 };
static cilist io___23 = { 0, 6, 0, 0, 0 };
static cilist io___24 = { 0, 6, 0, 0, 0 };
static icilist io___26 = { 0, aleng, 0, "(I6)", 6, 1 };
static cilist io___27 = { 0, 0, 0, "(A72)", 0 };
static cilist io___35 = { 0, 0, 0, "(A72)", 0 };
static cilist io___36 = { 0, 0, 0, "(A72)", 0 };
static cilist io___37 = { 0, 0, 0, 0, 0 };
static cilist io___38 = { 0, 0, 0, 0, 0 };
static cilist io___39 = { 0, 0, 0, 0, 0 };
/* ----- IO DEVICE */
/* IOTXT : TEXT PDS (WRITE) */
/* IOMLS : MEMBER LIST (READ) */
/* IOUT : STANDARD OUTPUT (WRITE) */
/* 49 : DEVICE FOR PDS MEMBER, INTERNALLY OPENED AND CLOSED (READ) */
/* 5 : STANDARD INPUT FOR DIRECTORY NAME OF PDS FILE */
uioset_();
iotxt = 10;
iomls = 11;
iout = 6;
nred = 0;
s_copy(cmd, "*PUT", (ftnlen)4, (ftnlen)4);
*(unsigned char *)type__ = 'N';
/* ******************** */
/* READ INPUT DATA * */
/* ******************** */
/* DIRNAM : FULL NAME OF DIRECTORY FOR PDS */
/* EX:/DG05/UFS02/J9347/SRAC95/LIB/PDS/PFAST/PFASTJ2 */
s_rsfe(&io___7);
do_fio(&c__1, dirnam, (ftnlen)72);
e_rsfe();
if (*(unsigned char *)dirnam == ' ') {
s_wsle(&io___9);
do_lio(&c__9, &c__1, " ERROR(MAIN) : DIRECTORY NAME IS INVALID", (
ftnlen)40);
e_wsle();
s_wsle(&io___10);
do_lio(&c__9, &c__1, " THE FIRST COLUMN SHOULD BE NON-BLANK", (ftnlen)
37);
e_wsle();
s_wsle(&io___11);
do_lio(&c__9, &c__1, " DIRNAM = ", (ftnlen)10);
do_lio(&c__9, &c__1, dirnam, (ftnlen)72);
e_wsle();
s_stop("", (ftnlen)0);
}
/* ************************ */
/* WRITE HEADER IN TEXT * */
/* ************************ */
al__1.aerr = 0;
al__1.aunit = iotxt;
f_rew(&al__1);
s_copy(line, " 3 PDSEDT INPUT R/W MODE ", (ftnlen)72, (ftnlen)34)
;
io___13.ciunit = iotxt;
s_wsfe(&io___13);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
/* ******************** */
/* READ MEMBER LIST * */
/* ******************** */
memlst_(&iomls, &nmem, memnam, (ftnlen)8);
if (nmem > 4000) {
s_wsle(&io___16);
do_lio(&c__9, &c__1, " ERROR (MAIN) : MAX OF MEMBER(MAXME=", (ftnlen)
36);
do_lio(&c__3, &c__1, (char *)&c__4000, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS LESS THAN REQUIRED SIZE(=", (ftnlen)30);
do_lio(&c__3, &c__1, (char *)&nmem, (ftnlen)sizeof(integer));
e_wsle();
s_stop("", (ftnlen)0);
}
/* ******************** */
/* LOOP ON MEMBER * */
/* ******************** */
i__1 = nmem;
for (m = 1; m <= i__1; ++m) {
s_copy(member, memnam + (m - 1 << 3), (ftnlen)8, (ftnlen)8);
setdt_1.ntnuc1 = 0;
setdt_1.ntnuc2 = 0;
setdt_1.nzon2 = 0;
setdt_1.nzon3 = 0;
/* *************************** */
/* READ CONTENTS OF MEMBER * */
/* *************************** */
pdsin_(dirnam, member, work, &leng, &irc, &iout, (ftnlen)72, (ftnlen)
8);
if (irc != 0) {
s_wsle(&io___22);
do_lio(&c__9, &c__1, " PDS ERROR : ERROR CODE = ", (ftnlen)26);
do_lio(&c__3, &c__1, (char *)&irc, (ftnlen)sizeof(integer));
e_wsle();
s_wsle(&io___23);
do_lio(&c__9, &c__1, " MEMBER = ", (ftnlen)10);
do_lio(&c__9, &c__1, member, (ftnlen)8);
e_wsle();
s_stop("", (ftnlen)0);
} else {
++nred;
}
if (leng > 300000) {
s_wsle(&io___24);
do_lio(&c__9, &c__1, " ERROR (MAIN) : WORK AREA(MAXWK=", (ftnlen)
32);
do_lio(&c__3, &c__1, (char *)&c_b48, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, ") IS LESS THAN REQUIRED SIZE(=", (ftnlen)30)
;
do_lio(&c__3, &c__1, (char *)&leng, (ftnlen)sizeof(integer));
do_lio(&c__9, &c__1, " IN MEMBER:", (ftnlen)11);
do_lio(&c__9, &c__1, member, (ftnlen)8);
e_wsle();
s_stop("", (ftnlen)0);
}
/* ***************** */
/* WRITE IN TEXT * */
/* ***************** */
/* ----- WRITE MEMBER NAME AND LENGTH */
s_wsfi(&io___26);
do_fio(&c__1, (char *)&leng, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__1[0] = cmd;
i__2[1] = 1, a__1[1] = " ";
i__2[2] = 8, a__1[2] = member;
i__2[3] = 1, a__1[3] = " ";
i__2[4] = 1, a__1[4] = type__;
i__2[5] = 1, a__1[5] = " ";
i__2[6] = 6, a__1[6] = aleng;
s_cat(line, a__1, i__2, &c__7, (ftnlen)72);
io___27.ciunit = iotxt;
s_wsfe(&io___27);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
/* ----- SET NUMBER OF LINES TO WRITE IN TEXT FOR DATA OF A MEMBER */
txtlin_(&leng, &ldata);
/* ----- SET LINE DATA AND WRITE IN TEXT */
i__3 = ldata;
for (l = 1; l <= i__3; ++l) {
kpos = (l - 1) * 6 + 1;
if (l != ldata) {
ld = 6;
} else {
ld = leng - (ldata - 1) * 6;
}
i__4 = ld;
for (i__ = 1; i__ <= i__4; ++i__) {
ipos = (l - 1) * 6 + i__;
data[i__ - 1] = work[ipos - 1];
/* L110: */
}
if (s_cmp(member + 4, "DN", (ftnlen)2, (ftnlen)2) == 0 && *(
unsigned char *)&member[7] == 'T') {
setli1_(line, &ld, data, &kpos, (ftnlen)72);
} else if (s_cmp(member + 4, "BNUP", (ftnlen)4, (ftnlen)4) == 0) {
setli2_(line, &ld, data, &kpos, (ftnlen)72);
} else if (s_cmp(member + 4, "REST", (ftnlen)4, (ftnlen)4) == 0) {
setli3_(line, &ld, data, &kpos, (ftnlen)72);
} else {
setlin_(line, &ld, data, (ftnlen)72);
}
io___35.ciunit = iotxt;
s_wsfe(&io___35);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
/* L100: */
}
/* L1000: */
}
/* *********** */
/* FINISH * */
/* *********** */
s_copy(line, "*FIN", (ftnlen)72, (ftnlen)4);
io___36.ciunit = iotxt;
s_wsfe(&io___36);
do_fio(&c__1, line, (ftnlen)72);
e_wsfe();
io___37.ciunit = iout;
s_wsle(&io___37);
e_wsle();
io___38.ciunit = iout;
s_wsle(&io___38);
do_lio(&c__9, &c__1, " NUMBER OF MEMBERS READ FROM PDS=", (ftnlen)33);
do_lio(&c__3, &c__1, (char *)&nred, (ftnlen)sizeof(integer));
e_wsle();
io___39.ciunit = iout;
s_wsle(&io___39);
do_lio(&c__9, &c__1, " ********** JOB END **********", (ftnlen)30);
e_wsle();
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* DECK SCHKW */
/* Subroutine */ int schkw_(char *name__, integer *lociw, integer *leniw,
integer *locw, integer *lenw, integer *ierr, integer *iter, real *err,
ftnlen name_len)
{
/* System generated locals */
address a__1[7];
integer i__1[7];
char ch__1[89], ch__2[86];
/* Local variables */
static char xern1[8], xern2[8];
extern doublereal r1mach_(integer *);
static char xernam[8];
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___3 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___7 = { 0, xern2, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE SCHKW */
/* ***SUBSIDIARY */
/* ***PURPOSE SLAP WORK/IWORK Array Bounds Checker. */
/* This routine checks the work array lengths and interfaces */
/* to the SLATEC error handler if a problem is found. */
/* ***LIBRARY SLATEC (SLAP) */
/* ***CATEGORY R2 */
/* ***TYPE SINGLE PRECISION (SCHKW-S, DCHKW-D) */
/* ***KEYWORDS ERROR CHECKING, SLAP, WORKSPACE CHECKING */
/* ***AUTHOR Seager, Mark K., (LLNL) */
/* Lawrence Livermore National Laboratory */
/* PO BOX 808, L-60 */
/* Livermore, CA 94550 (510) 423-3141 */
/* [email protected] */
/* ***DESCRIPTION */
/* *Usage: */
/* CHARACTER*(*) NAME */
/* INTEGER LOCIW, LENIW, LOCW, LENW, IERR, ITER */
/* REAL ERR */
/* CALL SCHKW( NAME, LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR ) */
/* *Arguments: */
/* NAME :IN Character*(*). */
/* Name of the calling routine. This is used in the output */
/* message, if an error is detected. */
/* LOCIW :IN Integer. */
/* Location of the first free element in the integer workspace */
/* array. */
/* LENIW :IN Integer. */
/* Length of the integer workspace array. */
/* LOCW :IN Integer. */
/* Location of the first free element in the real workspace */
/* array. */
/* LENRW :IN Integer. */
/* Length of the real workspace array. */
/* IERR :OUT Integer. */
/* Return error flag. */
/* IERR = 0 => All went well. */
/* IERR = 1 => Insufficient storage allocated for */
/* WORK or IWORK. */
/* ITER :OUT Integer. */
/* Set to zero on return. */
/* ERR :OUT Real. */
/* Set to the smallest positive magnitude if all went well. */
/* Set to a very large number if an error is detected. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 880225 DATE WRITTEN */
/* 881213 Previous REVISION DATE */
/* 890915 Made changes requested at July 1989 CML Meeting. (MKS) */
/* 890922 Numerous changes to prologue to make closer to SLATEC */
/* standard. (FNF) */
/* 890929 Numerous changes to reduce SP/DP differences. (FNF) */
/* 900805 Changed XERRWV calls to calls to XERMSG. (RWC) */
/* 910411 Prologue converted to Version 4.0 format. (BAB) */
/* 910502 Corrected XERMSG calls to satisfy Section 6.2.2 of ANSI */
/* X3.9-1978. (FNF) */
/* 910506 Made subsidiary. (FNF) */
/* 920511 Added complete declaration section. (WRB) */
/* 921015 Added code to initialize ITER and ERR when IERR=0. (FNF) */
/* ***END PROLOGUE SCHKW */
/* .. Scalar Arguments .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* ***FIRST EXECUTABLE STATEMENT SCHKW */
/* Check the Integer workspace situation. */
*ierr = 0;
*iter = 0;
*err = r1mach_(&c__1);
if (*lociw > *leniw) {
*ierr = 1;
*err = r1mach_(&c__2);
s_copy(xernam, name__, (ftnlen)8, name_len);
s_wsfi(&io___3);
do_fio(&c__1, (char *)&(*lociw), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*leniw), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 3, a__1[0] = "In ";
i__1[1] = 8, a__1[1] = xernam;
i__1[2] = 33, a__1[2] = ", INTEGER work array too short. ";
i__1[3] = 12, a__1[3] = "IWORK needs ";
i__1[4] = 8, a__1[4] = xern1;
i__1[5] = 17, a__1[5] = "; have allocated ";
i__1[6] = 8, a__1[6] = xern2;
s_cat(ch__1, a__1, i__1, &c__7, (ftnlen)89);
xermsg_("SLATEC", "SCHKW", ch__1, &c__1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)89);
}
/* Check the Real workspace situation. */
if (*locw > *lenw) {
*ierr = 1;
*err = r1mach_(&c__2);
s_copy(xernam, name__, (ftnlen)8, name_len);
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*locw), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___7);
do_fio(&c__1, (char *)&(*lenw), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 3, a__1[0] = "In ";
i__1[1] = 8, a__1[1] = xernam;
i__1[2] = 30, a__1[2] = ", REAL work array too short. ";
i__1[3] = 12, a__1[3] = "RWORK needs ";
i__1[4] = 8, a__1[4] = xern1;
i__1[5] = 17, a__1[5] = "; have allocated ";
i__1[6] = 8, a__1[6] = xern2;
s_cat(ch__2, a__1, i__1, &c__7, (ftnlen)86);
xermsg_("SLATEC", "SCHKW", ch__2, &c__1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)86);
}
return 0;
/* ------------- LAST LINE OF SCHKW FOLLOWS ---------------------------- */
} /* schkw_ */