From 6f4a6f687994e7e79f46e17e0237489cad148d5a Mon Sep 17 00:00:00 2001 From: Harry Moffat Date: Thu, 5 Aug 2004 19:15:05 +0000 Subject: [PATCH] First commit of this directory --- ext/f2c_math/.cvsignore | 1 + ext/f2c_math/Makefile.in | 96 + ext/f2c_math/cblas.h | 646 +++ ext/f2c_math/daux.c | 355 ++ ext/f2c_math/ddaspk.c | 8783 ++++++++++++++++++++++++++++++++++++++ ext/f2c_math/dgbefa.c | 253 ++ ext/f2c_math/dgbsl.c | 206 + ext/f2c_math/dgefa.c | 164 + ext/f2c_math/dgesl.c | 183 + ext/f2c_math/dp1vlu.c | 255 ++ ext/f2c_math/dpcoef.c | 127 + ext/f2c_math/dpolft.c | 539 +++ ext/f2c_math/fdump.c | 120 + ext/f2c_math/gmres.h | 144 + ext/f2c_math/idamax.c | 87 + ext/f2c_math/j4save.c | 90 + ext/f2c_math/mach.cpp | 60 + ext/f2c_math/mkl_cblas.h | 644 +++ ext/f2c_math/pcoef.c | 1006 +++++ ext/f2c_math/polfit.c | 533 +++ ext/f2c_math/pvalue.c | 255 ++ ext/f2c_math/xercnt.c | 83 + ext/f2c_math/xerhlt.c | 78 + ext/f2c_math/xermsg.c | 475 +++ ext/f2c_math/xerprn.c | 316 ++ ext/f2c_math/xersve.c | 239 ++ ext/f2c_math/xgetua.c | 93 + 27 files changed, 15831 insertions(+) create mode 100644 ext/f2c_math/.cvsignore create mode 100644 ext/f2c_math/Makefile.in create mode 100644 ext/f2c_math/cblas.h create mode 100644 ext/f2c_math/daux.c create mode 100644 ext/f2c_math/ddaspk.c create mode 100644 ext/f2c_math/dgbefa.c create mode 100644 ext/f2c_math/dgbsl.c create mode 100644 ext/f2c_math/dgefa.c create mode 100644 ext/f2c_math/dgesl.c create mode 100644 ext/f2c_math/dp1vlu.c create mode 100644 ext/f2c_math/dpcoef.c create mode 100644 ext/f2c_math/dpolft.c create mode 100644 ext/f2c_math/fdump.c create mode 100644 ext/f2c_math/gmres.h create mode 100644 ext/f2c_math/idamax.c create mode 100644 ext/f2c_math/j4save.c create mode 100644 ext/f2c_math/mach.cpp create mode 100644 ext/f2c_math/mkl_cblas.h create mode 100644 ext/f2c_math/pcoef.c create mode 100644 ext/f2c_math/polfit.c create mode 100644 ext/f2c_math/pvalue.c create mode 100644 ext/f2c_math/xercnt.c create mode 100644 ext/f2c_math/xerhlt.c create mode 100644 ext/f2c_math/xermsg.c create mode 100644 ext/f2c_math/xerprn.c create mode 100644 ext/f2c_math/xersve.c create mode 100644 ext/f2c_math/xgetua.c diff --git a/ext/f2c_math/.cvsignore b/ext/f2c_math/.cvsignore new file mode 100644 index 000000000..f3c7a7c5d --- /dev/null +++ b/ext/f2c_math/.cvsignore @@ -0,0 +1 @@ +Makefile diff --git a/ext/f2c_math/Makefile.in b/ext/f2c_math/Makefile.in new file mode 100644 index 000000000..d84db0fdd --- /dev/null +++ b/ext/f2c_math/Makefile.in @@ -0,0 +1,96 @@ +#/bin/sh +# +# $Source$ +# $Author$ +# $Revision$ +# $Date$ +# + +.SUFFIXES : +.SUFFIXES : .c .cpp .d .o + +# the directory where the Cantera libraries are located +CANTERA_LIBDIR=@buildlib@ + +# the directory where Cantera include files may be found. +CANTERA_INCDIR=@ctroot@/build/include/cantera + +# the C++ compiler +CXX = @CXX@ + +# the C compiler +CC = @CC@ + +# C++ compile flags +CXX_FLAGS = @CXXFLAGS@ $(CXX_OPT) + +# Local include files +CXX_INCLUDES=-I../f2c_libs + +# How to compile the dependency file +.c.d: + g++ -MM $(CXX_FLAGS) $(CXX_INCLUDES) $*.c > $*.d + +.cpp.d: + g++ -MM $(CXX_FLAGS) $(CXX_INCLUDES) $*.cpp > $*.d + +# How to compile a C file +.c.o: + @CC@ -c $< @DEFS@ $(CXX_FLAGS) $(CXX_INCLUDES) + +# How to compile a Cpp file +.cpp.o: + @CXX@ -c $< @DEFS@ $(CXX_FLAGS) $(CXX_INCLUDES) + + +# ----------------------------------------------- + +LIB = @buildlib@/libctmath.a + +all: $(LIB) + +OBJS = \ +mach.o \ +ddaspk.o \ +dgbefa.o \ +dgbsl.o \ +dgefa.o \ +dgesl.o \ +dp1vlu.o \ +dpcoef.o \ +dpolft.o \ +fdump.o \ +j4save.o \ +pcoef.o \ +polfit.o \ +pvalue.o \ +xercnt.o \ +xerhlt.o \ +xermsg.o \ +xerprn.o \ +xersve.o \ +xgetua.o + +SRCS = $(OBJS:.o=.cpp) + +# List of dependency files to be created +DEPENDS=$(OBJS:.o=.d) + +# How to make the static library +$(LIB): $(OBJS) + @ARCHIVE@ $(LIB) $(OBJS) + +# ------------------------------------------------ +# Utility Targets + +clean: + $(RM) $(OBJS) $(LIB) *.d .depends + +# depends target +depends: + $(RM) *.d .depends + @MAKE@ .depends + +.depends: $(DEPENDS) + cat *.d > .depends + diff --git a/ext/f2c_math/cblas.h b/ext/f2c_math/cblas.h new file mode 100644 index 000000000..8ca35aa1a --- /dev/null +++ b/ext/f2c_math/cblas.h @@ -0,0 +1,646 @@ +// -*- C++ -*- + +// ============================================= // +// die double-Versionen der BLAS Level 1 und 2 // +// ============================================= // + +#ifndef CBLAS1_H +// ============================================================================ + +// generate a plane rotation +void drotg( double *a, double *b, double *c, double *s ); + + +#if 0 +// generate a modified plane rotation +void drotmg( double *d1, double *d2, double *a, double b, double *param ); +#endif + +// apply a plane rotation +void drot( int n, double *x, int incx, double *y, int incy, double c, + double s ); + + +#if 0 +// apply a modified plane rotation +void drotm( int n, double *x, int incx, double *y, int incy, double *param ); +#endif + + +// x <=> y +void dswap( int n, double *x, int incx, double *y, int incy ); + + +// x <= a*x +void dscal( int n, double alpha, double *x, int incx ); + + +// y <= x +void dcopy( int n, const double *x, int incx, double *y, int incy ); + + +// y <= a*x+y +void daxpy( int n, double alpha, const double *x, int incx, double *y, + int incy ); + + +// dot <= x^T*y +double ddot( int n, const double *x, int incx, const double *y, int incy ); + + +// dnrm2 <= |x|_2 +double dnrm2( int n, const double *x, int incx ); + + +// asum <= |x|_1 +double dasum( int n, const double *x, int incx ); + + +// idamax <= first k such that |x_k| = max|x_i| +int idamax( int n, const double *x, int incx ); + +// ============================================================================ +#endif // CBLAS1_H + + +#ifndef CBLAS2_H +// ============================================================================ + + +enum MatrixTranspose { NoTranspose=0, Transpose=1, ConjugateTranspose=2 }; +enum MatrixTriangle { UpperTriangle=0, LowerTriangle=1 }; +enum MatrixUnitTriangular { UnitTriangular=0, NotUnitTriangular=1 }; + + +// ============================================================================ + + +// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) +void dgemv( MatrixTranspose trans, int m, int n, double alpha, + const double *A, int ldA, const double *x, int incx, + double beta, double *y, int incy ); + + +// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) +void dgbmv( MatrixTranspose trans, int m, int n, int kl, int ku, double alpha, + const double *A, int ldA, const double *x, int incx, double *beta, + double *y, int incy ); + + +// y <= alpha*A*x + beta*y +void dsymv( MatrixTriangle uplo, int n, double alpha, const double *A, int ldA, + const double *x, int incx, double beta, double *y, int incy ); + + +// y <= alpha*A*x + beta*y +void dsbmv( MatrixTriangle uplo, int n, int k, double alpha, double *A, + int ldA, const double *x, int incx, double beta, double *y, + int *incy ); + + +// y <= alpha*A*x + beta*y +void dspmv( MatrixTriangle uplo, int n, double alpha, const double *AP, + const double *x, int incx, double beta, double *y, int incy ); + + +// x <= A*x, x <= A^T*x +void dtrmv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, const double *A, int ldA, + double *x, int incx ); + + +// x <= A*x, x <= A^T*x +void dtbmv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, int k, const double *A, int ldA, + double *x, int incx ); + + +// x <= A*x, x <= A^T*x +void dtpmv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, int k, const double *AP, + double *x, int incx ); + + +// x <= A^{-1}*x, x <= A^{-T}*x +void dtrsv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, const double *A, int ldA, + double *x, int incx ); + + +// x <= A^{-1}*x, x <= A^{-T}*x +void dtbsv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, int k, const double *A, int ldA, + double *x, int incx ); + + +// x <= A^{-1}*x, x <= A^{-T}*x +void dtpsv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, int k, const double *AP, + double *x, int incx ); + + +// A <= alpha*x*y^T + A, A-(m,n) +void dger( int m, int n, double alpha, const double *x, int incx, + const double *y, int incy, double *A, int ldA ); + + +// A <= alpha*x*x^T + A +void dsyr( MatrixTriangle uplo, int n, double alpha, const double *x, + int incx, double *A, int ldA ); + + +// A <= alpha*x*x^T + A +void dspr( MatrixTriangle uplo, int n, double alpha, const double *x, + int incx, double *AP ); + + +// A <= alpha*x*y^T + alpha*y*x^T + A +void dsyr2( MatrixTriangle uplo, int n, double alpha, const double *x, + int incx, const double *y, int incy, double *A, int ldA ); + + +// A <= alpha*x*y^T + alpha*y*x^T + A +void dspr2( MatrixTriangle uplo, int n, double alpha, const double *x, + int incx, const double *y, int incy, double *AP ); + +// ============================================================================ +#endif // CBLAS2_H + + +#ifndef BLAS1_H +#define BLAS1_H +// ============================================================================ + +// generate a plane rotation +extern "C" +void drotg_( double *a, double *b, double *c, double *s ); + + +#if 0 +// generate a modified plane rotation +extern "C" +void drotmg_( double *d1, double *d2, double *a, double *b, double *param ); +#endif + + +// apply a plane rotation +extern "C" +void drot_( int *n, double *x, int *incx, double *y, int *incy, + double *c, double *s ); + + +#if 0 +// apply a modified plane rotation +extern "C" +void drotm_( int *n, double *x, int *incx, double *y, int *incy, + double *param ); +#endif + + +// x <=> y +extern "C" +void dswap_( const int *n, double *x, const int *incx, double *y, + const int *incy ); + +// x <= a*x +extern "C" +void dscal_( const int *n, const double *alpha, double *x, const int *incx ); + + +// y <= x +extern "C" +void dcopy_( const int *n, const double *x, const int *incx, double *y, + const int *incy ); + + +// y <= a*x+y +extern "C" +void daxpy_( const int *n, const double *alpha, const double *x, + const int *incx, double *y, const int *incy ); + + +// dot <= x^T*y +extern "C" +double ddot_( const int *n, const double *x, const int *incx, const double *y, + const int *incy ); + + +// dnrm2 <= |x|_2 +extern "C" +double dnrm2_( const int *n, const double *x, const int *incx ); + + +// asum <= |x|_1 +extern "C" +double dasum_( const int *n, const double *x, const int *incx ); + + +// idamax <= first k such that |x_k| = max|x_i| +extern "C" +int idamax_( const int *n, const double *x, const int *incx ); + + +// ============================================================================ +#endif // BLAS1_H + + + +#ifndef CBLAS1_H +#define CBLAS1_H +// ============================================================================ + + +#ifdef __linux__ // muss dnorm2 f"ur linux neu implementieren +# include +#endif + +inline +void drotg( double *a, double *b, double *c, double *s ) { + drotg_(a,b,c,s); +} + +#if 0 +inline +void drotmg( double *d1, double *d2, double *a, double b, double *param ) { + drotmg_(d1,d2,a,&b,param); +} +#endif + +inline +void drot( int n, double *x, int incx, double *y, int incy, double c, + double s ) { + drot_(&n,x,&incx,y,&incy,&c,&s); +} + +#if 0 +inline +void drotm( int n, double *x, int incx, double *y, int incy, double *param ) { + drotm_(&n,x,&incx,y,&incy,param); +} +#endif + +inline +void dswap( int n, double *x, int incx, double *y, int incy ) { + dswap_(&n,x,&incx,y,&incy); +} + +inline +void dscal( int n, double alpha, double *x, int incx ) { + int nn = n; + int incxx = incx; + double aa = alpha; + dscal_(&nn,&aa,x,&incxx); +} + +inline +void dcopy( int n, const double *x, int incx, double *y, int incy ) { + int nn = n; + int incxx = incx; + int incyy = incy; + dcopy_(&nn,x,&incxx,y,&incyy); +} + +inline +void daxpy( int n, double alpha, const double *x, int incx, double *y, + int incy ) { + double aa = alpha; + int incxx = incx; + int incyy = incy; + daxpy_(&n,&aa,x,&incxx,y,&incyy); +} + +inline +double ddot( int n, const double *x, int incx, const double *y, int incy ) { + int nn = n; + int incxx = incx; + int incyy = incy; + return ddot_(&nn,x,&incxx,y,&incyy); +} + +inline +double dnrm2( int n, const double *x, int incx ) { + int nn = n; + int incxx = incx; +#ifdef __linux__ // fehlerhafte Berechnung + double d=0.; + while ( nn-- ) + d+=(*x)*(*x), x+=incxx; + return sqrt(d); +#else // unter nicht-Linux korrekt + return dnrm2_(&nn,x,&incxx); +#endif +} + +inline +double dasum( int n, const double *x, int incx ) { + return dasum_(&n,x,&incx); +} + +inline +int idamax( int n, const double *x, int incx ) { + return idamax_(&n,x,&incx); +} + + +// ============================================================================ +#endif // CBLAS1_H + + +#ifndef BLAS2_H +#define BLAS2_H +// ============================================================================ + +// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) +//extern "C" +//void dgemv_( const char *trans, const int *m, const int *n, +// const double *alpha, const double *A, const int *ldA, +// const double *x, const int *incx, +// const double *beta, double *y, const int *incy ); + + +// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) +extern "C" +void dgbmv_( const char *trans, const int *m, const int *n, const int *kl, + const int *ku, const double *alpha, const double *A, + const int *ldA, const double *x, const int *incx, + const double *beta, double *y, const int *incy ); + + +// y <= alpha*A*x + beta*y +extern "C" +void dsymv_( const char *uplo, const int *n, const double *alpha, + const double *A, const int *ldA, const double *x, const int *incx, + const double *beta, double *y, const int *incy ); + + +// y <= alpha*A*x + beta*y +extern "C" +void dsbmv_( const char *uplo, const int *n, const int *k, const double *alpha, + const double *A, const int *ldA, const double *x, const int *incx, + const double *beta, double *y, const int *incy ); + + +// y <= alpha*A*x + beta*y +extern "C" +void dspmv_( const char *uplo, const int *n, const double *alpha, + const double *AP, const double *x, const int *incx, + const double *beta, double *y, const int *incy ); + + +// x <= A*x, x <= A^T*x +extern "C" +void dtrmv_( const char *uplo, const char *trans, const char *diag, + const int *n, const double *A, const int *ldA, + double *x, const int *incx ); + + +// x <= A*x, x <= A^T*x +extern "C" +void dtbmv_( const char *uplo, const char *trans, const char *diag, + const int *n, const int *k, const double *A, const int *ldA, + double *x, const int *incx ); + + +// x <= A*x, x <= A^T*x +extern "C" +void dtpmv_( const char *uplo, const char *trans, const char *diag, + const int *n, const double *AP, double *x, const int *incx ); + + +// x <= A^{-1}*x, x <= A^{-T}*x +extern "C" +void dtrsv_( const char *uplo, const char *trans, const char *diag, + const int *n, const double *A, const int *ldA, + double *x, const int *incx ); + + +// x <= A^{-1}*x, x <= A^{-T}*x +extern "C" +void dtbsv_( const char *uplo, const char *trans, const char *diag, + const int *n, const int *k, const double *A, const int *ldA, + double *x, const int *incx ); + + +// x <= A^{-1}*x, x <= A^{-T}*x +extern "C" +void dtpsv_( const char *uplo, const char *trans, const char *diag, + const int *n, const double *AP, double *x, const int *incx ); + + +// A <= alpha*x*y^T + A, A-(m,n) +extern "C" +void dger_( const int *m, const int *n, const double *alpha, const double *x, + const int *incx, const double *y, const int *incy, double *A, + const int *ldA ); + + +// A <= alpha*x*x^T + A +extern "C" +void dsyr_( const char *uplo, const int *n, const double *alpha, + const double *x, const int *incx, double *A, const int *ldA ); + + +// A <= alpha*x*x^T + A +extern "C" +void dspr_( const char *uplo, const int *n, const double *alpha, + const double *x, const int *incx, double *AP ); + + +// A <= alpha*x*y^T + alpha*y*x^T + A +extern "C" +void dsyr2_( const char *uplo, const int *n, const double *alpha, + const double *x, const int *incx, const double *y, + const int *incy, double *A, const int *ldA ); + + +// A <= alpha*x*y^T + alpha*y*x^T + A +extern "C" +void dspr2_( const char *uplo, const int *n, const double *alpha, + const double *x, const int *incx, const double *y, + const int *incy, double *AP ); + +// ============================================================================ +#endif // BLAS2_H + + +#ifndef CBLAS2_H +#define CBLAS2_H +// ============================================================================ + + +// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) +inline +void dgemv( MatrixTranspose trans, int m, int n, double alpha, + const double *A, int ldA, const double *x, int incx, + double beta, double *y, int incy ) { + const char *T[3] = { "N", "T", 0 }; + int mm = m; + int nn = n; + double aa = alpha; + double bb = beta; + int ldaa = ldA; + int incxx = incx; + int incyy = incy; + dgemv_(T[(int)trans],&mm,&nn,&aa,A,&ldaa,x,&incxx,&bb,y,&incyy,1); +} + + +// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) +inline +void dgbmv( MatrixTranspose trans, int m, int n, int kl, int ku, double alpha, + const double *A, int ldA, const double *x, int incx, double beta, + double *y, int incy ) { + const char *T[3] = { "N", "T" }; + dgbmv_(T[(int)trans],&m,&n,&kl,&ku,&alpha,A,&ldA,x,&incx,&beta,y,&incy); +} + +// y <= alpha*A*x + beta*y +inline +void dsymv( MatrixTriangle uplo, int n, double alpha, const double *A, int ldA, + const double *x, int incx, double beta, double *y, int incy ) { + const char *UL[2] = { "U", "L" }; + dsymv_(UL[(int)uplo],&n,&alpha,A,&ldA,x,&incx,&beta,y,&incy); +} + + +// y <= alpha*A*x + beta*y +inline +void dsbmv( MatrixTriangle uplo, int n, int k, double alpha, double *A, + int ldA, const double *x, int incx, double beta, double *y, + int incy ) { + const char *UL[2] = { "U", "L" }; + dsbmv_(UL[(int)uplo],&n,&k,&alpha,A,&ldA,x,&incx,&beta,y,&incy); +} + + +// y <= alpha*A*x + beta*y +inline +void dspmv( MatrixTriangle uplo, int n, double alpha, const double *AP, + const double *x, int incx, double beta, double *y, int incy ) { + const char *UL[2] = { "U", "L" }; + dspmv_(UL[(int)uplo],&n,&alpha,AP,x,&incx,&beta,y,&incy); +} + + +// x <= A*x, x <= A^T*x +inline +void dtrmv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, const double *A, int ldA, + double *x, int incx ) { + const char *UL[2] = { "U", "L" }; + const char *T[3] = { "N", "T", 0 }; + const char *D[2] = { "U", "N" }; + dtrmv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&n,A,&ldA,x,&incx); +} + + +// x <= A*x, x <= A^T*x +inline +void dtbmv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, int k, const double *A, int ldA, + double *x, int incx ) { + const char *UL[2] = { "U", "L" }; + const char *T[3] = { "N", "T", 0 }; + const char *D[2] = { "U", "N" }; + dtbmv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&n,&k,A,&ldA,x,&incx); +} + + +// x <= A*x, x <= A^T*x +inline +void dtpmv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, const double *AP, + double *x, int incx ) { + const char *UL[2] = { "U", "L" }; + const char *T[3] = { "N", "T", 0 }; + const char *D[2] = { "U", "N" }; + dtpmv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&n,AP,x,&incx); +} + + +// x <= A^{-1}*x, x <= A^{-T}*x +inline +void dtrsv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, const double *A, int ldA, + double *x, int incx ) { + const char *UL[2] = { "U", "L" }; + const char *T[3] = { "N", "T", 0 }; + const char *D[2] = { "U", "N" }; + dtrsv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&n,A,&ldA,x,&incx); +} + + +// x <= A^{-1}*x, x <= A^{-T}*x +inline +void dtbsv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, int k, const double *A, int ldA, + double *x, int incx ) { + const char *UL[2] = { "U", "L" }; + const char *T[3] = { "N", "T", 0 }; + const char *D[2] = { "U", "N" }; + dtbsv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&n,&k,A,&ldA,x,&incx); +} + + +// x <= A^{-1}*x, x <= A^{-T}*x +inline +void dtpsv( MatrixTriangle uplo, MatrixTranspose trans, + MatrixUnitTriangular diag, int n, const double *AP, + double *x, int incx ) { + const char *UL[2] = { "U", "L" }; + const char *T[3] = { "N", "T", 0 }; + const char *D[2] = { "U", "N" }; + int nn = n; + int incxx = incx; + dtpsv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&nn,AP,x,&incxx); +} + + +// A <= alpha*x*y^T + A, A-(m,n) +inline +void dger( int m, int n, double alpha, const double *x, int incx, + const double *y, int incy, double *A, int ldA ) { + dger_(&m,&n,&alpha,x,&incx,y,&incy,A,&ldA); +} + + +// A <= alpha*x*x^T + A +inline +void dsyr( MatrixTriangle uplo, int n, double alpha, const double *x, + int incx, double *A, int ldA ) { + const char *UL[2] = { "U", "L" }; + dsyr_(UL[(int)uplo],&n,&alpha,x,&incx,A,&ldA); +} + + +// A <= alpha*x*x^T + A +inline +void dspr( MatrixTriangle uplo, int n, double alpha, const double *x, + int incx, double *AP ) { + const char *UL[2] = { "U", "L" }; + dspr_(UL[(int)uplo],&n,&alpha,x,&incx,AP); +} + + +// A <= alpha*x*y^T + alpha*y*x^T + A +inline +void dsyr2( MatrixTriangle uplo, int n, double alpha, const double *x, + int incx, const double *y, int incy, double *A, int ldA ) { + const char *UL[2] = { "U", "L" }; + dsyr2_(UL[(int)uplo],&n,&alpha,x,&incx,y,&incy,A,&ldA); +} + + +// A <= alpha*x*y^T + alpha*y*x^T + A +inline +void dspr2( MatrixTriangle uplo, int n, double alpha, const double *x, + int incx, const double *y, int incy, double *AP ) { + const char *UL[2] = { "U", "L" }; + dspr2_(UL[(int)uplo],&n,&alpha,x,&incx,y,&incy,AP); +} + + +// ============================================================================ + + +#endif // CBLAS2_H diff --git a/ext/f2c_math/daux.c b/ext/f2c_math/daux.c new file mode 100644 index 000000000..251c3748d --- /dev/null +++ b/ext/f2c_math/daux.c @@ -0,0 +1,355 @@ +/* daux.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__1 = 1; +static integer c__0 = 0; +static logical c_false = FALSE_; +static integer c__2 = 2; +static logical c_true = TRUE_; + +/* DOUBLE PRECISION FUNCTION D1MACH (IDUM) */ +/* INTEGER IDUM */ +/* C----------------------------------------------------------------------- */ +/* C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE */ +/* C PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER */ +/* C U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). */ +/* C----------------------------------------------------------------------- */ +/* DOUBLE PRECISION U, COMP */ +/* U = 1.0D0 */ +/* 10 U = U*0.5D0 */ +/* COMP = 1.0D0 + U */ +/* IF (COMP .NE. 1.0D0) GO TO 10 */ +/* D1MACH = U*2.0D0 */ +/* RETURN */ +/* C----------------------- END OF FUNCTION D1MACH ------------------------ */ +/* END */ +/* DECK XERRWD */ +/* Subroutine */ int xerrwd_(char *msg, integer *nmes, integer *nerr, integer + *level, integer *ni, integer *i1, integer *i2, integer *nr, + doublereal *r1, doublereal *r2, ftnlen msg_len) +{ + /* Format strings */ + static char fmt_10[] = "(1x,a)"; + static char fmt_20[] = "(6x,\002In above message, I1 =\002,i10)"; + static char fmt_30[] = "(6x,\002In above message, I1 =\002,i10,3x,\002I" + "2 =\002,i10)"; + static char fmt_40[] = "(6x,\002In above message, R1 =\002,d21.13)"; + static char fmt_50[] = "(6x,\002In above, R1 =\002,d21.13,3x,\002R2 " + "=\002,d21.13)"; + + /* Builtin functions */ + integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); + /* Subroutine */ int s_stop(char *, ftnlen); + + /* Local variables */ + extern integer ixsav_(integer *, integer *, logical *); + static integer lunit, mesflg; + + /* Fortran I/O blocks */ + static cilist io___3 = { 0, 0, 0, fmt_10, 0 }; + static cilist io___4 = { 0, 0, 0, fmt_20, 0 }; + static cilist io___5 = { 0, 0, 0, fmt_30, 0 }; + static cilist io___6 = { 0, 0, 0, fmt_40, 0 }; + static cilist io___7 = { 0, 0, 0, fmt_50, 0 }; + + +/* ***BEGIN PROLOGUE XERRWD */ +/* ***SUBSIDIARY */ +/* ***PURPOSE Write error message with values. */ +/* ***LIBRARY MATHLIB */ +/* ***CATEGORY R3C */ +/* ***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D) */ +/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */ +/* ***DESCRIPTION */ + +/* Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, */ +/* as given here, constitute a simplified version of the SLATEC error */ +/* handling package. */ + +/* All arguments are input arguments. */ + +/* MSG = The message (character array). */ +/* NMES = The length of MSG (number of characters). */ +/* NERR = The error number (not used). */ +/* LEVEL = The error level.. */ +/* 0 or 1 means recoverable (control returns to caller). */ +/* 2 means fatal (run is aborted--see note below). */ +/* NI = Number of integers (0, 1, or 2) to be printed with message. */ +/* I1,I2 = Integers to be printed, depending on NI. */ +/* NR = Number of reals (0, 1, or 2) to be printed with message. */ +/* R1,R2 = Reals to be printed, depending on NR. */ + +/* Note.. this routine is machine-dependent and specialized for use */ +/* in limited context, in the following ways.. */ +/* 1. The argument MSG is assumed to be of type CHARACTER, and */ +/* the message is printed with a format of (1X,A). */ +/* 2. The message is assumed to take only one line. */ +/* Multi-line messages are generated by repeated calls. */ +/* 3. If LEVEL = 2, control passes to the statement STOP */ +/* to abort the run. This statement may be machine-dependent. */ +/* 4. R1 and R2 are assumed to be in double precision and are printed */ +/* in D21.13 format. */ + +/* ***ROUTINES CALLED IXSAV */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 920831 DATE WRITTEN */ +/* 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) */ +/* 930329 Modified prologue to SLATEC format. (FNF) */ +/* 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) */ +/* 930922 Minor cosmetic change. (FNF) */ +/* ***END PROLOGUE XERRWD */ + +/* *Internal Notes: */ + +/* For a different default logical unit number, IXSAV (or a subsidiary */ +/* routine that it calls) will need to be modified. */ +/* For a different run-abort command, change the statement following */ +/* statement 100 at the end. */ +/* ----------------------------------------------------------------------- */ +/* Subroutines called by XERRWD.. None */ +/* Function routine called by XERRWD.. IXSAV */ +/* ----------------------------------------------------------------------- */ +/* **End */ + +/* Declare arguments. */ + + +/* Declare local variables. */ + + +/* Get logical unit number and message print flag. */ + +/* ***FIRST EXECUTABLE STATEMENT XERRWD */ + lunit = ixsav_(&c__1, &c__0, &c_false); + mesflg = ixsav_(&c__2, &c__0, &c_false); + if (mesflg == 0) { + goto L100; + } + +/* Write the message. */ + + io___3.ciunit = lunit; + s_wsfe(&io___3); + do_fio(&c__1, msg, msg_len); + e_wsfe(); + if (*ni == 1) { + io___4.ciunit = lunit; + s_wsfe(&io___4); + do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer)); + e_wsfe(); + } + if (*ni == 2) { + io___5.ciunit = lunit; + s_wsfe(&io___5); + do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer)); + do_fio(&c__1, (char *)&(*i2), (ftnlen)sizeof(integer)); + e_wsfe(); + } + if (*nr == 1) { + io___6.ciunit = lunit; + s_wsfe(&io___6); + do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal)); + e_wsfe(); + } + if (*nr == 2) { + io___7.ciunit = lunit; + s_wsfe(&io___7); + do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal)); + do_fio(&c__1, (char *)&(*r2), (ftnlen)sizeof(doublereal)); + e_wsfe(); + } + +/* Abort the run if LEVEL = 2. */ + +L100: + if (*level != 2) { + return 0; + } + s_stop("", (ftnlen)0); +/* ----------------------- End of Subroutine XERRWD ---------------------- */ + return 0; +} /* xerrwd_ */ + +/* DECK XSETF */ +/* Subroutine */ int xsetf_(integer *mflag) +{ + static integer junk; + extern integer ixsav_(integer *, integer *, logical *); + +/* ***BEGIN PROLOGUE XSETF */ +/* ***PURPOSE Reset the error print control flag. */ +/* ***LIBRARY MATHLIB */ +/* ***CATEGORY R3A */ +/* ***TYPE ALL (XSETF-A) */ +/* ***KEYWORDS ERROR CONTROL */ +/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */ +/* ***DESCRIPTION */ + +/* XSETF sets the error print control flag to MFLAG: */ +/* MFLAG=1 means print all messages (the default). */ +/* MFLAG=0 means no printing. */ + +/* ***SEE ALSO XERMSG, XERRWD, XERRWV */ +/* ***REFERENCES (NONE) */ +/* ***ROUTINES CALLED IXSAV */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 921118 DATE WRITTEN */ +/* 930329 Added SLATEC format prologue. (FNF) */ +/* 930407 Corrected SEE ALSO section. (FNF) */ +/* 930922 Made user-callable, and other cosmetic changes. (FNF) */ +/* ***END PROLOGUE XSETF */ + +/* Subroutines called by XSETF.. None */ +/* Function routine called by XSETF.. IXSAV */ +/* ----------------------------------------------------------------------- */ +/* **End */ + +/* ***FIRST EXECUTABLE STATEMENT XSETF */ + if (*mflag == 0 || *mflag == 1) { + junk = ixsav_(&c__2, mflag, &c_true); + } + return 0; +/* ----------------------- End of Subroutine XSETF ----------------------- */ +} /* xsetf_ */ + +/* DECK XSETUN */ +/* Subroutine */ int xsetun_(integer *lun) +{ + static integer junk; + extern integer ixsav_(integer *, integer *, logical *); + +/* ***BEGIN PROLOGUE XSETUN */ +/* ***PURPOSE Reset the logical unit number for error messages. */ +/* ***LIBRARY MATHLIB */ +/* ***CATEGORY R3B */ +/* ***TYPE ALL (XSETUN-A) */ +/* ***KEYWORDS ERROR CONTROL */ +/* ***DESCRIPTION */ + +/* XSETUN sets the logical unit number for error messages to LUN. */ + +/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */ +/* ***SEE ALSO XERMSG, XERRWD, XERRWV */ +/* ***REFERENCES (NONE) */ +/* ***ROUTINES CALLED IXSAV */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 921118 DATE WRITTEN */ +/* 930329 Added SLATEC format prologue. (FNF) */ +/* 930407 Corrected SEE ALSO section. (FNF) */ +/* 930922 Made user-callable, and other cosmetic changes. (FNF) */ +/* ***END PROLOGUE XSETUN */ + +/* Subroutines called by XSETUN.. None */ +/* Function routine called by XSETUN.. IXSAV */ +/* ----------------------------------------------------------------------- */ +/* **End */ + +/* ***FIRST EXECUTABLE STATEMENT XSETUN */ + if (*lun > 0) { + junk = ixsav_(&c__1, lun, &c_true); + } + return 0; +/* ----------------------- End of Subroutine XSETUN ---------------------- */ +} /* xsetun_ */ + +/* DECK IXSAV */ +integer ixsav_(integer *ipar, integer *ivalue, logical *iset) +{ + /* Initialized data */ + + static integer lunit = -1; + static integer lundef = 6; + static integer mesflg = 1; + + /* System generated locals */ + integer ret_val; + +/* ***BEGIN PROLOGUE IXSAV */ +/* ***SUBSIDIARY */ +/* ***PURPOSE Save and recall error message control parameters. */ +/* ***LIBRARY MATHLIB */ +/* ***CATEGORY R3C */ +/* ***TYPE ALL (IXSAV-A) */ +/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */ +/* ***DESCRIPTION */ + +/* IXSAV saves and recalls one of two error message parameters: */ +/* LUNIT, the logical unit number to which messages are printed, and */ +/* MESFLG, the message print flag. */ +/* This is a modification of the SLATEC library routine J4SAVE. */ + +/* Saved local variables.. */ +/* LUNIT = Logical unit number for messages. */ +/* LUNDEF = Default logical unit number, data-loaded to 6 below */ +/* (may be machine-dependent). */ +/* MESFLG = Print control flag.. */ +/* 1 means print all messages (the default). */ +/* 0 means no printing. */ + +/* On input.. */ +/* IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). */ +/* IVALUE = The value to be set for the parameter, if ISET = .TRUE. */ +/* ISET = Logical flag to indicate whether to read or write. */ +/* If ISET = .TRUE., the parameter will be given */ +/* the value IVALUE. If ISET = .FALSE., the parameter */ +/* will be unchanged, and IVALUE is a dummy argument. */ + +/* On return.. */ +/* IXSAV = The (old) value of the parameter. */ + +/* ***SEE ALSO XERMSG, XERRWD, XERRWV */ +/* ***ROUTINES CALLED NONE */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 921118 DATE WRITTEN */ +/* 930329 Modified prologue to SLATEC format. (FNF) */ +/* 941025 Minor modification re default unit number. (ACH) */ +/* ***END PROLOGUE IXSAV */ + +/* **End */ +/* ----------------------------------------------------------------------- */ +/* ----------------------------------------------------------------------- */ +/* The following Fortran-77 declaration is to cause the values of the */ +/* listed (local) variables to be saved between calls to this routine. */ +/* ----------------------------------------------------------------------- */ + +/* ***FIRST EXECUTABLE STATEMENT IXSAV */ + if (*ipar == 1) { + if (lunit == -1) { + lunit = lundef; + } + ret_val = lunit; + if (*iset) { + lunit = *ivalue; + } + } + + if (*ipar == 2) { + ret_val = mesflg; + if (*iset) { + mesflg = *ivalue; + } + } + + return ret_val; +/* ----------------------- End of Function IXSAV ------------------------- */ +} /* ixsav_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/ddaspk.c b/ext/f2c_math/ddaspk.c new file mode 100644 index 000000000..adf7ee8e4 --- /dev/null +++ b/ext/f2c_math/ddaspk.c @@ -0,0 +1,8783 @@ +/* ddaspk.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__49 = 49; +static integer c__201 = 201; +static integer c__0 = 0; +static doublereal c_b37 = 0.; +static integer c__47 = 47; +static integer c__202 = 202; +static integer c__1 = 1; +static integer c__41 = 41; +static integer c__203 = 203; +static integer c__4 = 4; +static doublereal c_b67 = .6667; +static integer c__9 = 9; +static integer c__5 = 5; +static integer c__56 = 56; +static integer c__501 = 501; +static integer c__2 = 2; +static integer c__502 = 502; +static integer c__503 = 503; +static integer c__38 = 38; +static integer c__610 = 610; +static integer c__48 = 48; +static integer c__611 = 611; +static integer c__620 = 620; +static integer c__621 = 621; +static integer c__45 = 45; +static integer c__622 = 622; +static integer c__630 = 630; +static integer c__28 = 28; +static integer c__631 = 631; +static integer c__44 = 44; +static integer c__640 = 640; +static integer c__57 = 57; +static integer c__641 = 641; +static integer c__650 = 650; +static integer c__651 = 651; +static integer c__40 = 40; +static integer c__652 = 652; +static integer c__655 = 655; +static integer c__46 = 46; +static integer c__656 = 656; +static integer c__660 = 660; +static integer c__661 = 661; +static integer c__670 = 670; +static integer c__671 = 671; +static integer c__672 = 672; +static integer c__675 = 675; +static integer c__51 = 51; +static integer c__676 = 676; +static integer c__677 = 677; +static integer c__680 = 680; +static integer c__36 = 36; +static integer c__681 = 681; +static integer c__685 = 685; +static integer c__686 = 686; +static integer c__690 = 690; +static integer c__35 = 35; +static integer c__691 = 691; +static integer c__695 = 695; +static integer c__50 = 50; +static integer c__696 = 696; +static integer c__25 = 25; +static integer c__34 = 34; +static integer c__3 = 3; +static integer c__60 = 60; +static integer c__39 = 39; +static integer c__6 = 6; +static integer c__7 = 7; +static integer c__8 = 8; +static integer c__54 = 54; +static integer c__10 = 10; +static integer c__11 = 11; +static integer c__29 = 29; +static integer c__12 = 12; +static integer c__13 = 13; +static integer c__14 = 14; +static integer c__15 = 15; +static integer c__52 = 52; +static integer c__17 = 17; +static integer c__18 = 18; +static integer c__19 = 19; +static integer c__20 = 20; +static integer c__21 = 21; +static integer c__22 = 22; +static integer c__58 = 58; +static integer c__23 = 23; +static integer c__24 = 24; +static integer c__26 = 26; +static integer c__27 = 27; +static integer c__701 = 701; +static integer c__702 = 702; +static integer c__901 = 901; +static integer c__902 = 902; +static integer c__903 = 903; +static integer c__904 = 904; +static integer c__43 = 43; +static integer c__905 = 905; +static integer c__42 = 42; +static integer c__906 = 906; +static integer c__921 = 921; +static integer c__922 = 922; +static integer c__923 = 923; +static integer c__924 = 924; +static integer c__925 = 925; +static integer c__926 = 926; + +/* Subroutine */ int ddaspk_(U_fp res, integer *neq, doublereal *t, + doublereal *y, doublereal *yprime, doublereal *tout, integer *info, + doublereal *rtol, doublereal *atol, integer *idid, doublereal *rwork, + integer *lrw, integer *iwork, integer *liw, doublereal *rpar, integer + *ipar, U_fp jac, U_fp psol) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1, d__2; + + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign( + doublereal *, doublereal *); + integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void); + + /* Local variables */ + static doublereal h__; + static integer i__; + static doublereal r__, h0; + static integer le; + static doublereal rh, tn; + static integer ici, idi, lid, ier; + static char msg[80]; + static integer lwm, lvt, lwt, nwt, nli0, nni0; + static logical lcfl, lcfn, done; + static doublereal rcfl; + static integer nnid; + static logical lavl; + static integer maxl, iret; + static doublereal hmax; + static integer lphi; + static doublereal hmin; + static integer lyic, lpwk, nstd; + static doublereal rcfn; + static integer ncfl0, ncfn0; + extern /* Subroutine */ int dnedd_(); + static integer mband; + extern /* Subroutine */ int dnedk_(); + static integer lenic, lenid, ncphi, lenpd, lsoff, msave, index, itemp, + leniw, nzflg; + static doublereal atoli; + static integer lypic; + static logical lwarn; + static doublereal avlin; + static integer lenwp, lenrw, mxord, nwarn; + static doublereal rtoli; + static integer lsavr; + extern doublereal d1mach_(integer *); + static doublereal tdist, tnext, fmaxl; + extern /* Subroutine */ int ddstp_(doublereal *, doublereal *, doublereal + *, integer *, U_fp, U_fp, U_fp, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, U_fp); + static doublereal tstop; + extern /* Subroutine */ int dcnst0_(integer *, doublereal *, integer *, + integer *), ddasic_(doublereal *, doublereal *, doublereal *, + integer *, integer *, integer *, U_fp, U_fp, U_fp, doublereal *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer * + , doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, integer *, U_fp) + ; + extern /* Subroutine */ int ddasid_(), ddasik_(); + static integer icnflg; + static doublereal tscale, epconi; + extern /* Subroutine */ int ddatrp_(doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + doublereal *); + static doublereal floatn; + static integer nonneg; + extern /* Subroutine */ int ddawts_(integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *) + ; + extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + static integer leniwp; + extern /* Subroutine */ int xerrwd_(char *, integer *, integer *, integer + *, integer *, integer *, integer *, integer *, doublereal *, + doublereal *, ftnlen), dinvwt_(integer *, doublereal *, integer *) + ; + static doublereal uround, ypnorm; + + /* Fortran I/O blocks */ + static cilist io___49 = { 0, 6, 0, 0, 0 }; + static cilist io___57 = { 0, 6, 0, 0, 0 }; + static cilist io___59 = { 0, 6, 0, 0, 0 }; + static cilist io___60 = { 0, 6, 0, 0, 0 }; + + + +/* ***BEGIN PROLOGUE DDASPK */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 910624 (Added HMAX test at 525 in main driver.) */ +/* ***REVISION DATE 920929 (CJ in RES call, RES counter fix.) */ +/* ***REVISION DATE 921215 (Warnings on poor iteration performance) */ +/* ***REVISION DATE 921216 (NRMAX as optional input) */ +/* ***REVISION DATE 930315 (Name change: DDINI to DDINIT) */ +/* ***REVISION DATE 940822 (Replaced initial condition calculation) */ +/* ***REVISION DATE 941101 (Added linesearch in I.C. calculations) */ +/* ***REVISION DATE 941220 (Misc. corrections throughout) */ +/* ***REVISION DATE 950125 (Added DINVWT routine) */ +/* ***REVISION DATE 950714 (Misc. corrections throughout) */ +/* ***REVISION DATE 950802 (Default NRMAX = 5, based on tests.) */ +/* ***REVISION DATE 950808 (Optional error test added.) */ +/* ***REVISION DATE 950814 (Added I.C. constraints and INFO(14)) */ +/* ***REVISION DATE 950828 (Various minor corrections.) */ +/* ***REVISION DATE 951006 (Corrected WT scaling in DFNRMK.) */ +/* ***REVISION DATE 951030 (Corrected history update at end of DDASTP.) */ +/* ***REVISION DATE 960129 (Corrected RL bug in DLINSD, DLINSK.) */ +/* ***REVISION DATE 960301 (Added NONNEG to SAVE statement.) */ +/* ***REVISION DATE 000512 (Removed copyright notices.) */ +/* ***REVISION DATE 000622 (Corrected LWM value using NCPHI.) */ +/* ***REVISION DATE 000628 (Corrected I.C. stopping tests when index = 0.) */ +/* ***REVISION DATE 000628 (Fixed alpha test in I.C. calc., Krylov case.) */ +/* ***REVISION DATE 000628 (Improved restart in I.C. calc., Krylov case.) */ +/* ***REVISION DATE 000628 (Minor corrections throughout.) */ +/* ***REVISION DATE 000711 (Fixed Newton convergence test in DNSD, DNSK.) */ +/* ***REVISION DATE 000712 (Fixed tests on TN - TOUT below 420 and 440.) */ +/* ***CATEGORY NO. I1A2 */ +/* ***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, */ +/* IMPLICIT DIFFERENTIAL SYSTEMS, KRYLOV ITERATION */ +/* ***AUTHORS Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh, and */ +/* Clement W. Ulrich */ +/* Center for Computational Sciences & Engineering, L-316 */ +/* Lawrence Livermore National Laboratory */ +/* P.O. Box 808, */ +/* Livermore, CA 94551 */ +/* ***PURPOSE This code solves a system of differential/algebraic */ +/* equations of the form */ +/* G(t,y,y') = 0 , */ +/* using a combination of Backward Differentiation Formula */ +/* (BDF) methods and a choice of two linear system solution */ +/* methods: direct (dense or band) or Krylov (iterative). */ +/* This version is in double precision. */ +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* *Usage: */ + +/* IMPLICIT DOUBLE PRECISION(A-H,O-Z) */ +/* INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR(*) */ +/* DOUBLE PRECISION T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), */ +/* RWORK(LRW), RPAR(*) */ +/* EXTERNAL RES, JAC, PSOL */ + +/* CALL DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, */ +/* * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) */ + +/* Quantities which may be altered by the code are: */ +/* T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, IDID, RWORK(*), IWORK(*) */ + + +/* *Arguments: */ + +/* RES:EXT This is the name of a subroutine which you */ +/* provide to define the residual function G(t,y,y') */ +/* of the differential/algebraic system. */ + +/* NEQ:IN This is the number of equations in the system. */ + +/* T:INOUT This is the current value of the independent */ +/* variable. */ + +/* Y(*):INOUT This array contains the solution components at T. */ + +/* YPRIME(*):INOUT This array contains the derivatives of the solution */ +/* components at T. */ + +/* TOUT:IN This is a point at which a solution is desired. */ + +/* INFO(N):IN This is an integer array used to communicate details */ +/* of how the solution is to be carried out, such as */ +/* tolerance type, matrix structure, step size and */ +/* order limits, and choice of nonlinear system method. */ +/* N must be at least 20. */ + +/* RTOL,ATOL:INOUT These quantities represent absolute and relative */ +/* error tolerances (on local error) which you provide */ +/* to indicate how accurately you wish the solution to */ +/* be computed. You may choose them to be both scalars */ +/* or else both arrays of length NEQ. */ + +/* IDID:OUT This integer scalar is an indicator reporting what */ +/* the code did. You must monitor this variable to */ +/* decide what action to take next. */ + +/* RWORK:WORK A real work array of length LRW which provides the */ +/* code with needed storage space. */ + +/* LRW:IN The length of RWORK. */ + +/* IWORK:WORK An integer work array of length LIW which provides */ +/* the code with needed storage space. */ + +/* LIW:IN The length of IWORK. */ + +/* RPAR,IPAR:IN These are real and integer parameter arrays which */ +/* you can use for communication between your calling */ +/* program and the RES, JAC, and PSOL subroutines. */ + +/* JAC:EXT This is the name of a subroutine which you may */ +/* provide (optionally) for calculating Jacobian */ +/* (partial derivative) data involved in solving linear */ +/* systems within DDASPK. */ + +/* PSOL:EXT This is the name of a subroutine which you must */ +/* provide for solving linear systems if you selected */ +/* a Krylov method. The purpose of PSOL is to solve */ +/* linear systems involving a left preconditioner P. */ + +/* *Overview */ + +/* The DDASPK solver uses the backward differentiation formulas of */ +/* orders one through five to solve a system of the form G(t,y,y') = 0 */ +/* for y = Y and y' = YPRIME. Values for Y and YPRIME at the initial */ +/* time must be given as input. These values should be consistent, */ +/* that is, if T, Y, YPRIME are the given initial values, they should */ +/* satisfy G(T,Y,YPRIME) = 0. However, if consistent values are not */ +/* known, in many cases you can have DDASPK solve for them -- see INFO(11). */ +/* (This and other options are described in more detail below.) */ + +/* Normally, DDASPK solves the system from T to TOUT. It is easy to */ +/* continue the solution to get results at additional TOUT. This is */ +/* the interval mode of operation. Intermediate results can also be */ +/* obtained easily by specifying INFO(3). */ + +/* On each step taken by DDASPK, a sequence of nonlinear algebraic */ +/* systems arises. These are solved by one of two types of */ +/* methods: */ +/* * a Newton iteration with a direct method for the linear */ +/* systems involved (INFO(12) = 0), or */ +/* * a Newton iteration with a preconditioned Krylov iterative */ +/* method for the linear systems involved (INFO(12) = 1). */ + +/* The direct method choices are dense and band matrix solvers, */ +/* with either a user-supplied or an internal difference quotient */ +/* Jacobian matrix, as specified by INFO(5) and INFO(6). */ +/* In the band case, INFO(6) = 1, you must supply half-bandwidths */ +/* in IWORK(1) and IWORK(2). */ + +/* The Krylov method is the Generalized Minimum Residual (GMRES) */ +/* method, in either complete or incomplete form, and with */ +/* scaling and preconditioning. The method is implemented */ +/* in an algorithm called SPIGMR. Certain options in the Krylov */ +/* method case are specified by INFO(13) and INFO(15). */ + +/* If the Krylov method is chosen, you may supply a pair of routines, */ +/* JAC and PSOL, to apply preconditioning to the linear system. */ +/* If the system is A*x = b, the matrix is A = dG/dY + CJ*dG/dYPRIME */ +/* (of order NEQ). This system can then be preconditioned in the form */ +/* (P-inverse)*A*x = (P-inverse)*b, with left preconditioner P. */ +/* (DDASPK does not allow right preconditioning.) */ +/* Then the Krylov method is applied to this altered, but equivalent, */ +/* linear system, hopefully with much better performance than without */ +/* preconditioning. (In addition, a diagonal scaling matrix based on */ +/* the tolerances is also introduced into the altered system.) */ + +/* The JAC routine evaluates any data needed for solving systems */ +/* with coefficient matrix P, and PSOL carries out that solution. */ +/* In any case, in order to improve convergence, you should try to */ +/* make P approximate the matrix A as much as possible, while keeping */ +/* the system P*x = b reasonably easy and inexpensive to solve for x, */ +/* given a vector b. */ + + +/* *Description */ + +/* ------INPUT - WHAT TO DO ON THE FIRST CALL TO DDASPK------------------- */ + + +/* The first call of the code is defined to be the start of each new */ +/* problem. Read through the descriptions of all the following items, */ +/* provide sufficient storage space for designated arrays, set */ +/* appropriate variables for the initialization of the problem, and */ +/* give information about how you want the problem to be solved. */ + + +/* RES -- Provide a subroutine of the form */ + +/* SUBROUTINE RES (T, Y, YPRIME, CJ, DELTA, IRES, RPAR, IPAR) */ + +/* to define the system of differential/algebraic */ +/* equations which is to be solved. For the given values */ +/* of T, Y and YPRIME, the subroutine should return */ +/* the residual of the differential/algebraic system */ +/* DELTA = G(T,Y,YPRIME) */ +/* DELTA is a vector of length NEQ which is output from RES. */ + +/* Subroutine RES must not alter T, Y, YPRIME, or CJ. */ +/* You must declare the name RES in an EXTERNAL */ +/* statement in your program that calls DDASPK. */ +/* You must dimension Y, YPRIME, and DELTA in RES. */ + +/* The input argument CJ can be ignored, or used to rescale */ +/* constraint equations in the system (see Ref. 2, p. 145). */ +/* Note: In this respect, DDASPK is not downward-compatible */ +/* with DDASSL, which does not have the RES argument CJ. */ + +/* IRES is an integer flag which is always equal to zero */ +/* on input. Subroutine RES should alter IRES only if it */ +/* encounters an illegal value of Y or a stop condition. */ +/* Set IRES = -1 if an input value is illegal, and DDASPK */ +/* will try to solve the problem without getting IRES = -1. */ +/* If IRES = -2, DDASPK will return control to the calling */ +/* program with IDID = -11. */ + +/* RPAR and IPAR are real and integer parameter arrays which */ +/* you can use for communication between your calling program */ +/* and subroutine RES. They are not altered by DDASPK. If you */ +/* do not need RPAR or IPAR, ignore these parameters by treat- */ +/* ing them as dummy arguments. If you do choose to use them, */ +/* dimension them in your calling program and in RES as arrays */ +/* of appropriate length. */ + +/* NEQ -- Set it to the number of equations in the system (NEQ .GE. 1). */ + +/* T -- Set it to the initial point of the integration. (T must be */ +/* a variable.) */ + +/* Y(*) -- Set this array to the initial values of the NEQ solution */ +/* components at the initial point. You must dimension Y of */ +/* length at least NEQ in your calling program. */ + +/* YPRIME(*) -- Set this array to the initial values of the NEQ first */ +/* derivatives of the solution components at the initial */ +/* point. You must dimension YPRIME at least NEQ in your */ +/* calling program. */ + +/* TOUT - Set it to the first point at which a solution is desired. */ +/* You cannot take TOUT = T. Integration either forward in T */ +/* (TOUT .GT. T) or backward in T (TOUT .LT. T) is permitted. */ + +/* The code advances the solution from T to TOUT using step */ +/* sizes which are automatically selected so as to achieve the */ +/* desired accuracy. If you wish, the code will return with the */ +/* solution and its derivative at intermediate steps (the */ +/* intermediate-output mode) so that you can monitor them, */ +/* but you still must provide TOUT in accord with the basic */ +/* aim of the code. */ + +/* The first step taken by the code is a critical one because */ +/* it must reflect how fast the solution changes near the */ +/* initial point. The code automatically selects an initial */ +/* step size which is practically always suitable for the */ +/* problem. By using the fact that the code will not step past */ +/* TOUT in the first step, you could, if necessary, restrict the */ +/* length of the initial step. */ + +/* For some problems it may not be permissible to integrate */ +/* past a point TSTOP, because a discontinuity occurs there */ +/* or the solution or its derivative is not defined beyond */ +/* TSTOP. When you have declared a TSTOP point (see INFO(4) */ +/* and RWORK(1)), you have told the code not to integrate past */ +/* TSTOP. In this case any tout beyond TSTOP is invalid input. */ + +/* INFO(*) - Use the INFO array to give the code more details about */ +/* how you want your problem solved. This array should be */ +/* dimensioned of length 20, though DDASPK uses only the */ +/* first 15 entries. You must respond to all of the following */ +/* items, which are arranged as questions. The simplest use */ +/* of DDASPK corresponds to setting all entries of INFO to 0. */ + +/* INFO(1) - This parameter enables the code to initialize itself. */ +/* You must set it to indicate the start of every new */ +/* problem. */ + +/* **** Is this the first call for this problem ... */ +/* yes - set INFO(1) = 0 */ +/* no - not applicable here. */ +/* See below for continuation calls. **** */ + +/* INFO(2) - How much accuracy you want of your solution */ +/* is specified by the error tolerances RTOL and ATOL. */ +/* The simplest use is to take them both to be scalars. */ +/* To obtain more flexibility, they can both be arrays. */ +/* The code must be told your choice. */ + +/* **** Are both error tolerances RTOL, ATOL scalars ... */ +/* yes - set INFO(2) = 0 */ +/* and input scalars for both RTOL and ATOL */ +/* no - set INFO(2) = 1 */ +/* and input arrays for both RTOL and ATOL **** */ + +/* INFO(3) - The code integrates from T in the direction of TOUT */ +/* by steps. If you wish, it will return the computed */ +/* solution and derivative at the next intermediate step */ +/* (the intermediate-output mode) or TOUT, whichever comes */ +/* first. This is a good way to proceed if you want to */ +/* see the behavior of the solution. If you must have */ +/* solutions at a great many specific TOUT points, this */ +/* code will compute them efficiently. */ + +/* **** Do you want the solution only at */ +/* TOUT (and not at the next intermediate step) ... */ +/* yes - set INFO(3) = 0 */ +/* no - set INFO(3) = 1 **** */ + +/* INFO(4) - To handle solutions at a great many specific */ +/* values TOUT efficiently, this code may integrate past */ +/* TOUT and interpolate to obtain the result at TOUT. */ +/* Sometimes it is not possible to integrate beyond some */ +/* point TSTOP because the equation changes there or it is */ +/* not defined past TSTOP. Then you must tell the code */ +/* this stop condition. */ + +/* **** Can the integration be carried out without any */ +/* restrictions on the independent variable T ... */ +/* yes - set INFO(4) = 0 */ +/* no - set INFO(4) = 1 */ +/* and define the stopping point TSTOP by */ +/* setting RWORK(1) = TSTOP **** */ + +/* INFO(5) - used only when INFO(12) = 0 (direct methods). */ +/* To solve differential/algebraic systems you may wish */ +/* to use a matrix of partial derivatives of the */ +/* system of differential equations. If you do not */ +/* provide a subroutine to evaluate it analytically (see */ +/* description of the item JAC in the call list), it will */ +/* be approximated by numerical differencing in this code. */ +/* Although it is less trouble for you to have the code */ +/* compute partial derivatives by numerical differencing, */ +/* the solution will be more reliable if you provide the */ +/* derivatives via JAC. Usually numerical differencing is */ +/* more costly than evaluating derivatives in JAC, but */ +/* sometimes it is not - this depends on your problem. */ + +/* **** Do you want the code to evaluate the partial deriv- */ +/* atives automatically by numerical differences ... */ +/* yes - set INFO(5) = 0 */ +/* no - set INFO(5) = 1 */ +/* and provide subroutine JAC for evaluating the */ +/* matrix of partial derivatives **** */ + +/* INFO(6) - used only when INFO(12) = 0 (direct methods). */ +/* DDASPK will perform much better if the matrix of */ +/* partial derivatives, dG/dY + CJ*dG/dYPRIME (here CJ is */ +/* a scalar determined by DDASPK), is banded and the code */ +/* is told this. In this case, the storage needed will be */ +/* greatly reduced, numerical differencing will be performed */ +/* much cheaper, and a number of important algorithms will */ +/* execute much faster. The differential equation is said */ +/* to have half-bandwidths ML (lower) and MU (upper) if */ +/* equation i involves only unknowns Y(j) with */ +/* i-ML .le. j .le. i+MU . */ +/* For all i=1,2,...,NEQ. Thus, ML and MU are the widths */ +/* of the lower and upper parts of the band, respectively, */ +/* with the main diagonal being excluded. If you do not */ +/* indicate that the equation has a banded matrix of partial */ +/* derivatives the code works with a full matrix of NEQ**2 */ +/* elements (stored in the conventional way). Computations */ +/* with banded matrices cost less time and storage than with */ +/* full matrices if 2*ML+MU .lt. NEQ. If you tell the */ +/* code that the matrix of partial derivatives has a banded */ +/* structure and you want to provide subroutine JAC to */ +/* compute the partial derivatives, then you must be careful */ +/* to store the elements of the matrix in the special form */ +/* indicated in the description of JAC. */ + +/* **** Do you want to solve the problem using a full (dense) */ +/* matrix (and not a special banded structure) ... */ +/* yes - set INFO(6) = 0 */ +/* no - set INFO(6) = 1 */ +/* and provide the lower (ML) and upper (MU) */ +/* bandwidths by setting */ +/* IWORK(1)=ML */ +/* IWORK(2)=MU **** */ + +/* INFO(7) - You can specify a maximum (absolute value of) */ +/* stepsize, so that the code will avoid passing over very */ +/* large regions. */ + +/* **** Do you want the code to decide on its own the maximum */ +/* stepsize ... */ +/* yes - set INFO(7) = 0 */ +/* no - set INFO(7) = 1 */ +/* and define HMAX by setting */ +/* RWORK(2) = HMAX **** */ + +/* INFO(8) - Differential/algebraic problems may occasionally */ +/* suffer from severe scaling difficulties on the first */ +/* step. If you know a great deal about the scaling of */ +/* your problem, you can help to alleviate this problem */ +/* by specifying an initial stepsize H0. */ + +/* **** Do you want the code to define its own initial */ +/* stepsize ... */ +/* yes - set INFO(8) = 0 */ +/* no - set INFO(8) = 1 */ +/* and define H0 by setting */ +/* RWORK(3) = H0 **** */ + +/* INFO(9) - If storage is a severe problem, you can save some */ +/* storage by restricting the maximum method order MAXORD. */ +/* The default value is 5. For each order decrease below 5, */ +/* the code requires NEQ fewer locations, but it is likely */ +/* to be slower. In any case, you must have */ +/* 1 .le. MAXORD .le. 5. */ +/* **** Do you want the maximum order to default to 5 ... */ +/* yes - set INFO(9) = 0 */ +/* no - set INFO(9) = 1 */ +/* and define MAXORD by setting */ +/* IWORK(3) = MAXORD **** */ + +/* INFO(10) - If you know that certain components of the */ +/* solutions to your equations are always nonnegative */ +/* (or nonpositive), it may help to set this */ +/* parameter. There are three options that are */ +/* available: */ +/* 1. To have constraint checking only in the initial */ +/* condition calculation. */ +/* 2. To enforce nonnegativity in Y during the integration. */ +/* 3. To enforce both options 1 and 2. */ + +/* When selecting option 2 or 3, it is probably best to try the */ +/* code without using this option first, and only use */ +/* this option if that does not work very well. */ + +/* **** Do you want the code to solve the problem without */ +/* invoking any special inequality constraints ... */ +/* yes - set INFO(10) = 0 */ +/* no - set INFO(10) = 1 to have option 1 enforced */ +/* no - set INFO(10) = 2 to have option 2 enforced */ +/* no - set INFO(10) = 3 to have option 3 enforced **** */ + +/* If you have specified INFO(10) = 1 or 3, then you */ +/* will also need to identify how each component of Y */ +/* in the initial condition calculation is constrained. */ +/* You must set: */ +/* IWORK(40+I) = +1 if Y(I) must be .GE. 0, */ +/* IWORK(40+I) = +2 if Y(I) must be .GT. 0, */ +/* IWORK(40+I) = -1 if Y(I) must be .LE. 0, while */ +/* IWORK(40+I) = -2 if Y(I) must be .LT. 0, while */ +/* IWORK(40+I) = 0 if Y(I) is not constrained. */ + +/* INFO(11) - DDASPK normally requires the initial T, Y, and */ +/* YPRIME to be consistent. That is, you must have */ +/* G(T,Y,YPRIME) = 0 at the initial T. If you do not know */ +/* the initial conditions precisely, in some cases */ +/* DDASPK may be able to compute it. */ + +/* Denoting the differential variables in Y by Y_d */ +/* and the algebraic variables by Y_a, DDASPK can solve */ +/* one of two initialization problems: */ +/* 1. Given Y_d, calculate Y_a and Y'_d, or */ +/* 2. Given Y', calculate Y. */ +/* In either case, initial values for the given */ +/* components are input, and initial guesses for */ +/* the unknown components must also be provided as input. */ + +/* **** Are the initial T, Y, YPRIME consistent ... */ + +/* yes - set INFO(11) = 0 */ +/* no - set INFO(11) = 1 to calculate option 1 above, */ +/* or set INFO(11) = 2 to calculate option 2 **** */ + +/* If you have specified INFO(11) = 1, then you */ +/* will also need to identify which are the */ +/* differential and which are the algebraic */ +/* components (algebraic components are components */ +/* whose derivatives do not appear explicitly */ +/* in the function G(T,Y,YPRIME)). You must set: */ +/* IWORK(LID+I) = +1 if Y(I) is a differential variable */ +/* IWORK(LID+I) = -1 if Y(I) is an algebraic variable, */ +/* where LID = 40 if INFO(10) = 0 or 2 and LID = 40+NEQ */ +/* if INFO(10) = 1 or 3. */ + +/* INFO(12) - Except for the addition of the RES argument CJ, */ +/* DDASPK by default is downward-compatible with DDASSL, */ +/* which uses only direct (dense or band) methods to solve */ +/* the linear systems involved. You must set INFO(12) to */ +/* indicate whether you want the direct methods or the */ +/* Krylov iterative method. */ +/* **** Do you want DDASPK to use standard direct methods */ +/* (dense or band) or the Krylov (iterative) method ... */ +/* direct methods - set INFO(12) = 0. */ +/* Krylov method - set INFO(12) = 1, */ +/* and check the settings of INFO(13) and INFO(15). */ + +/* INFO(13) - used when INFO(12) = 1 (Krylov methods). */ +/* DDASPK uses scalars MAXL, KMP, NRMAX, and EPLI for the */ +/* iterative solution of linear systems. INFO(13) allows */ +/* you to override the default values of these parameters. */ +/* These parameters and their defaults are as follows: */ +/* MAXL = maximum number of iterations in the SPIGMR */ +/* algorithm (MAXL .le. NEQ). The default is */ +/* MAXL = MIN(5,NEQ). */ +/* KMP = number of vectors on which orthogonalization is */ +/* done in the SPIGMR algorithm. The default is */ +/* KMP = MAXL, which corresponds to complete GMRES */ +/* iteration, as opposed to the incomplete form. */ +/* NRMAX = maximum number of restarts of the SPIGMR */ +/* algorithm per nonlinear iteration. The default is */ +/* NRMAX = 5. */ +/* EPLI = convergence test constant in SPIGMR algorithm. */ +/* The default is EPLI = 0.05. */ +/* Note that the length of RWORK depends on both MAXL */ +/* and KMP. See the definition of LRW below. */ +/* **** Are MAXL, KMP, and EPLI to be given their */ +/* default values ... */ +/* yes - set INFO(13) = 0 */ +/* no - set INFO(13) = 1, */ +/* and set all of the following: */ +/* IWORK(24) = MAXL (1 .le. MAXL .le. NEQ) */ +/* IWORK(25) = KMP (1 .le. KMP .le. MAXL) */ +/* IWORK(26) = NRMAX (NRMAX .ge. 0) */ +/* RWORK(10) = EPLI (0 .lt. EPLI .lt. 1.0) **** */ + +/* INFO(14) - used with INFO(11) > 0 (initial condition */ +/* calculation is requested). In this case, you may */ +/* request control to be returned to the calling program */ +/* immediately after the initial condition calculation, */ +/* before proceeding to the integration of the system */ +/* (e.g. to examine the computed Y and YPRIME). */ +/* If this is done, and if the initialization succeeded */ +/* (IDID = 4), you should reset INFO(11) to 0 for the */ +/* next call, to prevent the solver from repeating the */ +/* initialization (and to avoid an infinite loop). */ +/* **** Do you want to proceed to the integration after */ +/* the initial condition calculation is done ... */ +/* yes - set INFO(14) = 0 */ +/* no - set INFO(14) = 1 **** */ + +/* INFO(15) - used when INFO(12) = 1 (Krylov methods). */ +/* When using preconditioning in the Krylov method, */ +/* you must supply a subroutine, PSOL, which solves the */ +/* associated linear systems using P. */ +/* The usage of DDASPK is simpler if PSOL can carry out */ +/* the solution without any prior calculation of data. */ +/* However, if some partial derivative data is to be */ +/* calculated in advance and used repeatedly in PSOL, */ +/* then you must supply a JAC routine to do this, */ +/* and set INFO(15) to indicate that JAC is to be called */ +/* for this purpose. For example, P might be an */ +/* approximation to a part of the matrix A which can be */ +/* calculated and LU-factored for repeated solutions of */ +/* the preconditioner system. The arrays WP and IWP */ +/* (described under JAC and PSOL) can be used to */ +/* communicate data between JAC and PSOL. */ +/* **** Does PSOL operate with no prior preparation ... */ +/* yes - set INFO(15) = 0 (no JAC routine) */ +/* no - set INFO(15) = 1 */ +/* and supply a JAC routine to evaluate and */ +/* preprocess any required Jacobian data. **** */ + +/* INFO(16) - option to exclude algebraic variables from */ +/* the error test. */ +/* **** Do you wish to control errors locally on */ +/* all the variables... */ +/* yes - set INFO(16) = 0 */ +/* no - set INFO(16) = 1 */ +/* If you have specified INFO(16) = 1, then you */ +/* will also need to identify which are the */ +/* differential and which are the algebraic */ +/* components (algebraic components are components */ +/* whose derivatives do not appear explicitly */ +/* in the function G(T,Y,YPRIME)). You must set: */ +/* IWORK(LID+I) = +1 if Y(I) is a differential */ +/* variable, and */ +/* IWORK(LID+I) = -1 if Y(I) is an algebraic */ +/* variable, */ +/* where LID = 40 if INFO(10) = 0 or 2 and */ +/* LID = 40 + NEQ if INFO(10) = 1 or 3. */ + +/* INFO(17) - used when INFO(11) > 0 (DDASPK is to do an */ +/* initial condition calculation). */ +/* DDASPK uses several heuristic control quantities in the */ +/* initial condition calculation. They have default values, */ +/* but can also be set by the user using INFO(17). */ +/* These parameters and their defaults are as follows: */ +/* MXNIT = maximum number of Newton iterations */ +/* per Jacobian or preconditioner evaluation. */ +/* The default is: */ +/* MXNIT = 5 in the direct case (INFO(12) = 0), and */ +/* MXNIT = 15 in the Krylov case (INFO(12) = 1). */ +/* MXNJ = maximum number of Jacobian or preconditioner */ +/* evaluations. The default is: */ +/* MXNJ = 6 in the direct case (INFO(12) = 0), and */ +/* MXNJ = 2 in the Krylov case (INFO(12) = 1). */ +/* MXNH = maximum number of values of the artificial */ +/* stepsize parameter H to be tried if INFO(11) = 1. */ +/* The default is MXNH = 5. */ +/* NOTE: the maximum number of Newton iterations */ +/* allowed in all is MXNIT*MXNJ*MXNH if INFO(11) = 1, */ +/* and MXNIT*MXNJ if INFO(11) = 2. */ +/* LSOFF = flag to turn off the linesearch algorithm */ +/* (LSOFF = 0 means linesearch is on, LSOFF = 1 means */ +/* it is turned off). The default is LSOFF = 0. */ +/* STPTOL = minimum scaled step in linesearch algorithm. */ +/* The default is STPTOL = (unit roundoff)**(2/3). */ +/* EPINIT = swing factor in the Newton iteration convergence */ +/* test. The test is applied to the residual vector, */ +/* premultiplied by the approximate Jacobian (in the */ +/* direct case) or the preconditioner (in the Krylov */ +/* case). For convergence, the weighted RMS norm of */ +/* this vector (scaled by the error weights) must be */ +/* less than EPINIT*EPCON, where EPCON = .33 is the */ +/* analogous test constant used in the time steps. */ +/* The default is EPINIT = .01. */ +/* **** Are the initial condition heuristic controls to be */ +/* given their default values... */ +/* yes - set INFO(17) = 0 */ +/* no - set INFO(17) = 1, */ +/* and set all of the following: */ +/* IWORK(32) = MXNIT (.GT. 0) */ +/* IWORK(33) = MXNJ (.GT. 0) */ +/* IWORK(34) = MXNH (.GT. 0) */ +/* IWORK(35) = LSOFF ( = 0 or 1) */ +/* RWORK(14) = STPTOL (.GT. 0.0) */ +/* RWORK(15) = EPINIT (.GT. 0.0) **** */ + +/* INFO(18) - option to get extra printing in initial condition */ +/* calculation. */ +/* **** Do you wish to have extra printing... */ +/* no - set INFO(18) = 0 */ +/* yes - set INFO(18) = 1 for minimal printing, or */ +/* set INFO(18) = 2 for full printing. */ +/* If you have specified INFO(18) .ge. 1, data */ +/* will be printed with the error handler routines. */ +/* To print to a non-default unit number L, include */ +/* the line CALL XSETUN(L) in your program. **** */ + +/* RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) */ +/* error tolerances to tell the code how accurately you */ +/* want the solution to be computed. They must be defined */ +/* as variables because the code may change them. */ +/* you have two choices -- */ +/* Both RTOL and ATOL are scalars (INFO(2) = 0), or */ +/* both RTOL and ATOL are vectors (INFO(2) = 1). */ +/* In either case all components must be non-negative. */ + +/* The tolerances are used by the code in a local error */ +/* test at each step which requires roughly that */ +/* abs(local error in Y(i)) .le. EWT(i) , */ +/* where EWT(i) = RTOL*abs(Y(i)) + ATOL is an error weight */ +/* quantity, for each vector component. */ +/* (More specifically, a root-mean-square norm is used to */ +/* measure the size of vectors, and the error test uses the */ +/* magnitude of the solution at the beginning of the step.) */ + +/* The true (global) error is the difference between the */ +/* true solution of the initial value problem and the */ +/* computed approximation. Practically all present day */ +/* codes, including this one, control the local error at */ +/* each step and do not even attempt to control the global */ +/* error directly. */ + +/* Usually, but not always, the true accuracy of */ +/* the computed Y is comparable to the error tolerances. */ +/* This code will usually, but not always, deliver a more */ +/* accurate solution if you reduce the tolerances and */ +/* integrate again. By comparing two such solutions you */ +/* can get a fairly reliable idea of the true error in the */ +/* solution at the larger tolerances. */ + +/* Setting ATOL = 0. results in a pure relative error test */ +/* on that component. Setting RTOL = 0. results in a pure */ +/* absolute error test on that component. A mixed test */ +/* with non-zero RTOL and ATOL corresponds roughly to a */ +/* relative error test when the solution component is */ +/* much bigger than ATOL and to an absolute error test */ +/* when the solution component is smaller than the */ +/* threshold ATOL. */ + +/* The code will not attempt to compute a solution at an */ +/* accuracy unreasonable for the machine being used. It */ +/* will advise you if you ask for too much accuracy and */ +/* inform you as to the maximum accuracy it believes */ +/* possible. */ + +/* RWORK(*) -- a real work array, which should be dimensioned in your */ +/* calling program with a length equal to the value of */ +/* LRW (or greater). */ + +/* LRW -- Set it to the declared length of the RWORK array. The */ +/* minimum length depends on the options you have selected, */ +/* given by a base value plus additional storage as described */ +/* below. */ + +/* If INFO(12) = 0 (standard direct method), the base value is */ +/* base = 50 + max(MAXORD+4,7)*NEQ. */ +/* The default value is MAXORD = 5 (see INFO(9)). With the */ +/* default MAXORD, base = 50 + 9*NEQ. */ +/* Additional storage must be added to the base value for */ +/* any or all of the following options: */ +/* if INFO(6) = 0 (dense matrix), add NEQ**2 */ +/* if INFO(6) = 1 (banded matrix), then */ +/* if INFO(5) = 0, add (2*ML+MU+1)*NEQ + 2*(NEQ/(ML+MU+1)+1), */ +/* if INFO(5) = 1, add (2*ML+MU+1)*NEQ, */ +/* if INFO(16) = 1, add NEQ. */ + +/* If INFO(12) = 1 (Krylov method), the base value is */ +/* base = 50 + (MAXORD+5)*NEQ + (MAXL+3+MIN0(1,MAXL-KMP))*NEQ + */ +/* + (MAXL+3)*MAXL + 1 + LENWP. */ +/* See PSOL for description of LENWP. The default values are: */ +/* MAXORD = 5 (see INFO(9)), MAXL = min(5,NEQ) and KMP = MAXL */ +/* (see INFO(13)). */ +/* With the default values for MAXORD, MAXL and KMP, */ +/* base = 91 + 18*NEQ + LENWP. */ +/* Additional storage must be added to the base value for */ +/* any or all of the following options: */ +/* if INFO(16) = 1, add NEQ. */ + + +/* IWORK(*) -- an integer work array, which should be dimensioned in */ +/* your calling program with a length equal to the value */ +/* of LIW (or greater). */ + +/* LIW -- Set it to the declared length of the IWORK array. The */ +/* minimum length depends on the options you have selected, */ +/* given by a base value plus additional storage as described */ +/* below. */ + +/* If INFO(12) = 0 (standard direct method), the base value is */ +/* base = 40 + NEQ. */ +/* IF INFO(10) = 1 or 3, add NEQ to the base value. */ +/* If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value. */ + +/* If INFO(12) = 1 (Krylov method), the base value is */ +/* base = 40 + LENIWP. */ +/* See PSOL for description of LENIWP. */ +/* IF INFO(10) = 1 or 3, add NEQ to the base value. */ +/* If INFO(11) = 1 or INFO(16) = 1, add NEQ to the base value. */ + + +/* RPAR, IPAR -- These are arrays of double precision and integer type, */ +/* respectively, which are available for you to use */ +/* for communication between your program that calls */ +/* DDASPK and the RES subroutine (and the JAC and PSOL */ +/* subroutines). They are not altered by DDASPK. */ +/* If you do not need RPAR or IPAR, ignore these */ +/* parameters by treating them as dummy arguments. */ +/* If you do choose to use them, dimension them in */ +/* your calling program and in RES (and in JAC and PSOL) */ +/* as arrays of appropriate length. */ + +/* JAC -- This is the name of a routine that you may supply */ +/* (optionally) that relates to the Jacobian matrix of the */ +/* nonlinear system that the code must solve at each T step. */ +/* The role of JAC (and its call sequence) depends on whether */ +/* a direct (INFO(12) = 0) or Krylov (INFO(12) = 1) method */ +/* is selected. */ + +/* **** INFO(12) = 0 (direct methods): */ +/* If you are letting the code generate partial derivatives */ +/* numerically (INFO(5) = 0), then JAC can be absent */ +/* (or perhaps a dummy routine to satisfy the loader). */ +/* Otherwise you must supply a JAC routine to compute */ +/* the matrix A = dG/dY + CJ*dG/dYPRIME. It must have */ +/* the form */ + +/* SUBROUTINE JAC (T, Y, YPRIME, PD, CJ, RPAR, IPAR) */ + +/* The JAC routine must dimension Y, YPRIME, and PD (and RPAR */ +/* and IPAR if used). CJ is a scalar which is input to JAC. */ +/* For the given values of T, Y, and YPRIME, the JAC routine */ +/* must evaluate the nonzero elements of the matrix A, and */ +/* store these values in the array PD. The elements of PD are */ +/* set to zero before each call to JAC, so that only nonzero */ +/* elements need to be defined. */ +/* The way you store the elements into the PD array depends */ +/* on the structure of the matrix indicated by INFO(6). */ +/* *** INFO(6) = 0 (full or dense matrix) *** */ +/* Give PD a first dimension of NEQ. When you evaluate the */ +/* nonzero partial derivatives of equation i (i.e. of G(i)) */ +/* with respect to component j (of Y and YPRIME), you must */ +/* store the element in PD according to */ +/* PD(i,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). */ +/* *** INFO(6) = 1 (banded matrix with half-bandwidths ML, MU */ +/* as described under INFO(6)) *** */ +/* Give PD a first dimension of 2*ML+MU+1. When you */ +/* evaluate the nonzero partial derivatives of equation i */ +/* (i.e. of G(i)) with respect to component j (of Y and */ +/* YPRIME), you must store the element in PD according to */ +/* IROW = i - j + ML + MU + 1 */ +/* PD(IROW,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). */ + +/* **** INFO(12) = 1 (Krylov method): */ +/* If you are not calculating Jacobian data in advance for use */ +/* in PSOL (INFO(15) = 0), JAC can be absent (or perhaps a */ +/* dummy routine to satisfy the loader). Otherwise, you may */ +/* supply a JAC routine to compute and preprocess any parts of */ +/* of the Jacobian matrix A = dG/dY + CJ*dG/dYPRIME that are */ +/* involved in the preconditioner matrix P. */ +/* It is to have the form */ + +/* SUBROUTINE JAC (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR, */ +/* WK, H, CJ, WP, IWP, IER, RPAR, IPAR) */ + +/* The JAC routine must dimension Y, YPRIME, REWT, SAVR, WK, */ +/* and (if used) WP, IWP, RPAR, and IPAR. */ +/* The Y, YPRIME, and SAVR arrays contain the current values */ +/* of Y, YPRIME, and the residual G, respectively. */ +/* The array WK is work space of length NEQ. */ +/* H is the step size. CJ is a scalar, input to JAC, that is */ +/* normally proportional to 1/H. REWT is an array of */ +/* reciprocal error weights, 1/EWT(i), where EWT(i) is */ +/* RTOL*abs(Y(i)) + ATOL (unless you supplied routine DDAWTS */ +/* instead), for use in JAC if needed. For example, if JAC */ +/* computes difference quotient approximations to partial */ +/* derivatives, the REWT array may be useful in setting the */ +/* increments used. The JAC routine should do any */ +/* factorization operations called for, in preparation for */ +/* solving linear systems in PSOL. The matrix P should */ +/* be an approximation to the Jacobian, */ +/* A = dG/dY + CJ*dG/dYPRIME. */ + +/* WP and IWP are real and integer work arrays which you may */ +/* use for communication between your JAC routine and your */ +/* PSOL routine. These may be used to store elements of the */ +/* preconditioner P, or related matrix data (such as factored */ +/* forms). They are not altered by DDASPK. */ +/* If you do not need WP or IWP, ignore these parameters by */ +/* treating them as dummy arguments. If you do use them, */ +/* dimension them appropriately in your JAC and PSOL routines. */ +/* See the PSOL description for instructions on setting */ +/* the lengths of WP and IWP. */ + +/* On return, JAC should set the error flag IER as follows.. */ +/* IER = 0 if JAC was successful, */ +/* IER .ne. 0 if JAC was unsuccessful (e.g. if Y or YPRIME */ +/* was illegal, or a singular matrix is found). */ +/* (If IER .ne. 0, a smaller stepsize will be tried.) */ +/* IER = 0 on entry to JAC, so need be reset only on a failure. */ +/* If RES is used within JAC, then a nonzero value of IRES will */ +/* override any nonzero value of IER (see the RES description). */ + +/* Regardless of the method type, subroutine JAC must not */ +/* alter T, Y(*), YPRIME(*), H, CJ, or REWT(*). */ +/* You must declare the name JAC in an EXTERNAL statement in */ +/* your program that calls DDASPK. */ + +/* PSOL -- This is the name of a routine you must supply if you have */ +/* selected a Krylov method (INFO(12) = 1) with preconditioning. */ +/* In the direct case (INFO(12) = 0), PSOL can be absent */ +/* (a dummy routine may have to be supplied to satisfy the */ +/* loader). Otherwise, you must provide a PSOL routine to */ +/* solve linear systems arising from preconditioning. */ +/* When supplied with INFO(12) = 1, the PSOL routine is to */ +/* have the form */ + +/* SUBROUTINE PSOL (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT, */ +/* WP, IWP, B, EPLIN, IER, RPAR, IPAR) */ + +/* The PSOL routine must solve linear systems of the form */ +/* P*x = b where P is the left preconditioner matrix. */ + +/* The right-hand side vector b is in the B array on input, and */ +/* PSOL must return the solution vector x in B. */ +/* The Y, YPRIME, and SAVR arrays contain the current values */ +/* of Y, YPRIME, and the residual G, respectively. */ + +/* Work space required by JAC and/or PSOL, and space for data to */ +/* be communicated from JAC to PSOL is made available in the form */ +/* of arrays WP and IWP, which are parts of the RWORK and IWORK */ +/* arrays, respectively. The lengths of these real and integer */ +/* work spaces WP and IWP must be supplied in LENWP and LENIWP, */ +/* respectively, as follows.. */ +/* IWORK(27) = LENWP = length of real work space WP */ +/* IWORK(28) = LENIWP = length of integer work space IWP. */ + +/* WK is a work array of length NEQ for use by PSOL. */ +/* CJ is a scalar, input to PSOL, that is normally proportional */ +/* to 1/H (H = stepsize). If the old value of CJ */ +/* (at the time of the last JAC call) is needed, it must have */ +/* been saved by JAC in WP. */ + +/* WGHT is an array of weights, to be used if PSOL uses an */ +/* iterative method and performs a convergence test. (In terms */ +/* of the argument REWT to JAC, WGHT is REWT/sqrt(NEQ).) */ +/* If PSOL uses an iterative method, it should use EPLIN */ +/* (a heuristic parameter) as the bound on the weighted norm of */ +/* the residual for the computed solution. Specifically, the */ +/* residual vector R should satisfy */ +/* SQRT (SUM ( (R(i)*WGHT(i))**2 ) ) .le. EPLIN */ + +/* PSOL must not alter NEQ, T, Y, YPRIME, SAVR, CJ, WGHT, EPLIN. */ + +/* On return, PSOL should set the error flag IER as follows.. */ +/* IER = 0 if PSOL was successful, */ +/* IER .lt. 0 if an unrecoverable error occurred, meaning */ +/* control will be passed to the calling routine, */ +/* IER .gt. 0 if a recoverable error occurred, meaning that */ +/* the step will be retried with the same step size */ +/* but with a call to JAC to update necessary data, */ +/* unless the Jacobian data is current, in which case */ +/* the step will be retried with a smaller step size. */ +/* IER = 0 on entry to PSOL so need be reset only on a failure. */ + +/* You must declare the name PSOL in an EXTERNAL statement in */ +/* your program that calls DDASPK. */ + + +/* OPTIONALLY REPLACEABLE SUBROUTINE: */ + +/* DDASPK uses a weighted root-mean-square norm to measure the */ +/* size of various error vectors. The weights used in this norm */ +/* are set in the following subroutine: */ + +/* SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, EWT, RPAR, IPAR) */ +/* DIMENSION RTOL(*), ATOL(*), Y(*), EWT(*), RPAR(*), IPAR(*) */ + +/* A DDAWTS routine has been included with DDASPK which sets the */ +/* weights according to */ +/* EWT(I) = RTOL*ABS(Y(I)) + ATOL */ +/* in the case of scalar tolerances (IWT = 0) or */ +/* EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I) */ +/* in the case of array tolerances (IWT = 1). (IWT is INFO(2).) */ +/* In some special cases, it may be appropriate for you to define */ +/* your own error weights by writing a subroutine DDAWTS to be */ +/* called instead of the version supplied. However, this should */ +/* be attempted only after careful thought and consideration. */ +/* If you supply this routine, you may use the tolerances and Y */ +/* as appropriate, but do not overwrite these variables. You */ +/* may also use RPAR and IPAR to communicate data as appropriate. */ +/* ***Note: Aside from the values of the weights, the choice of */ +/* norm used in DDASPK (weighted root-mean-square) is not subject */ +/* to replacement by the user. In this respect, DDASPK is not */ +/* downward-compatible with the original DDASSL solver (in which */ +/* the norm routine was optionally user-replaceable). */ + + +/* ------OUTPUT - AFTER ANY RETURN FROM DDASPK---------------------------- */ + +/* The principal aim of the code is to return a computed solution at */ +/* T = TOUT, although it is also possible to obtain intermediate */ +/* results along the way. To find out whether the code achieved its */ +/* goal or if the integration process was interrupted before the task */ +/* was completed, you must check the IDID parameter. */ + + +/* T -- The output value of T is the point to which the solution */ +/* was successfully advanced. */ + +/* Y(*) -- contains the computed solution approximation at T. */ + +/* YPRIME(*) -- contains the computed derivative approximation at T. */ + +/* IDID -- reports what the code did, described as follows: */ + +/* *** TASK COMPLETED *** */ +/* Reported by positive values of IDID */ + +/* IDID = 1 -- a step was successfully taken in the */ +/* intermediate-output mode. The code has not */ +/* yet reached TOUT. */ + +/* IDID = 2 -- the integration to TSTOP was successfully */ +/* completed (T = TSTOP) by stepping exactly to TSTOP. */ + +/* IDID = 3 -- the integration to TOUT was successfully */ +/* completed (T = TOUT) by stepping past TOUT. */ +/* Y(*) and YPRIME(*) are obtained by interpolation. */ + +/* IDID = 4 -- the initial condition calculation, with */ +/* INFO(11) > 0, was successful, and INFO(14) = 1. */ +/* No integration steps were taken, and the solution */ +/* is not considered to have been started. */ + +/* *** TASK INTERRUPTED *** */ +/* Reported by negative values of IDID */ + +/* IDID = -1 -- a large amount of work has been expended */ +/* (about 500 steps). */ + +/* IDID = -2 -- the error tolerances are too stringent. */ + +/* IDID = -3 -- the local error test cannot be satisfied */ +/* because you specified a zero component in ATOL */ +/* and the corresponding computed solution component */ +/* is zero. Thus, a pure relative error test is */ +/* impossible for this component. */ + +/* IDID = -5 -- there were repeated failures in the evaluation */ +/* or processing of the preconditioner (in JAC). */ + +/* IDID = -6 -- DDASPK had repeated error test failures on the */ +/* last attempted step. */ + +/* IDID = -7 -- the nonlinear system solver in the time integration */ +/* could not converge. */ + +/* IDID = -8 -- the matrix of partial derivatives appears */ +/* to be singular (direct method). */ + +/* IDID = -9 -- the nonlinear system solver in the time integration */ +/* failed to achieve convergence, and there were repeated */ +/* error test failures in this step. */ + +/* IDID =-10 -- the nonlinear system solver in the time integration */ +/* failed to achieve convergence because IRES was equal */ +/* to -1. */ + +/* IDID =-11 -- IRES = -2 was encountered and control is */ +/* being returned to the calling program. */ + +/* IDID =-12 -- DDASPK failed to compute the initial Y, YPRIME. */ + +/* IDID =-13 -- unrecoverable error encountered inside user's */ +/* PSOL routine, and control is being returned to */ +/* the calling program. */ + +/* IDID =-14 -- the Krylov linear system solver could not */ +/* achieve convergence. */ + +/* IDID =-15,..,-32 -- Not applicable for this code. */ + +/* *** TASK TERMINATED *** */ +/* reported by the value of IDID=-33 */ + +/* IDID = -33 -- the code has encountered trouble from which */ +/* it cannot recover. A message is printed */ +/* explaining the trouble and control is returned */ +/* to the calling program. For example, this occurs */ +/* when invalid input is detected. */ + +/* RTOL, ATOL -- these quantities remain unchanged except when */ +/* IDID = -2. In this case, the error tolerances have been */ +/* increased by the code to values which are estimated to */ +/* be appropriate for continuing the integration. However, */ +/* the reported solution at T was obtained using the input */ +/* values of RTOL and ATOL. */ + +/* RWORK, IWORK -- contain information which is usually of no interest */ +/* to the user but necessary for subsequent calls. */ +/* However, you may be interested in the performance data */ +/* listed below. These quantities are accessed in RWORK */ +/* and IWORK but have internal mnemonic names, as follows.. */ + +/* RWORK(3)--contains H, the step size h to be attempted */ +/* on the next step. */ + +/* RWORK(4)--contains TN, the current value of the */ +/* independent variable, i.e. the farthest point */ +/* integration has reached. This will differ */ +/* from T if interpolation has been performed */ +/* (IDID = 3). */ + +/* RWORK(7)--contains HOLD, the stepsize used on the last */ +/* successful step. If INFO(11) = INFO(14) = 1, */ +/* this contains the value of H used in the */ +/* initial condition calculation. */ + +/* IWORK(7)--contains K, the order of the method to be */ +/* attempted on the next step. */ + +/* IWORK(8)--contains KOLD, the order of the method used */ +/* on the last step. */ + +/* IWORK(11)--contains NST, the number of steps (in T) */ +/* taken so far. */ + +/* IWORK(12)--contains NRE, the number of calls to RES */ +/* so far. */ + +/* IWORK(13)--contains NJE, the number of calls to JAC so */ +/* far (Jacobian or preconditioner evaluations). */ + +/* IWORK(14)--contains NETF, the total number of error test */ +/* failures so far. */ + +/* IWORK(15)--contains NCFN, the total number of nonlinear */ +/* convergence failures so far (includes counts */ +/* of singular iteration matrix or singular */ +/* preconditioners). */ + +/* IWORK(16)--contains NCFL, the number of convergence */ +/* failures of the linear iteration so far. */ + +/* IWORK(17)--contains LENIW, the length of IWORK actually */ +/* required. This is defined on normal returns */ +/* and on an illegal input return for */ +/* insufficient storage. */ + +/* IWORK(18)--contains LENRW, the length of RWORK actually */ +/* required. This is defined on normal returns */ +/* and on an illegal input return for */ +/* insufficient storage. */ + +/* IWORK(19)--contains NNI, the total number of nonlinear */ +/* iterations so far (each of which calls a */ +/* linear solver). */ + +/* IWORK(20)--contains NLI, the total number of linear */ +/* (Krylov) iterations so far. */ + +/* IWORK(21)--contains NPS, the number of PSOL calls so */ +/* far, for preconditioning solve operations or */ +/* for solutions with the user-supplied method. */ + +/* Note: The various counters in IWORK do not include */ +/* counts during a call made with INFO(11) > 0 and */ +/* INFO(14) = 1. */ + + +/* ------INPUT - WHAT TO DO TO CONTINUE THE INTEGRATION ----------------- */ +/* (CALLS AFTER THE FIRST) */ + +/* This code is organized so that subsequent calls to continue the */ +/* integration involve little (if any) additional effort on your */ +/* part. You must monitor the IDID parameter in order to determine */ +/* what to do next. */ + +/* Recalling that the principal task of the code is to integrate */ +/* from T to TOUT (the interval mode), usually all you will need */ +/* to do is specify a new TOUT upon reaching the current TOUT. */ + +/* Do not alter any quantity not specifically permitted below. In */ +/* particular do not alter NEQ, T, Y(*), YPRIME(*), RWORK(*), */ +/* IWORK(*), or the differential equation in subroutine RES. Any */ +/* such alteration constitutes a new problem and must be treated */ +/* as such, i.e. you must start afresh. */ + +/* You cannot change from array to scalar error control or vice */ +/* versa (INFO(2)), but you can change the size of the entries of */ +/* RTOL or ATOL. Increasing a tolerance makes the equation easier */ +/* to integrate. Decreasing a tolerance will make the equation */ +/* harder to integrate and should generally be avoided. */ + +/* You can switch from the intermediate-output mode to the */ +/* interval mode (INFO(3)) or vice versa at any time. */ + +/* If it has been necessary to prevent the integration from going */ +/* past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the */ +/* code will not integrate to any TOUT beyond the currently */ +/* specified TSTOP. Once TSTOP has been reached, you must change */ +/* the value of TSTOP or set INFO(4) = 0. You may change INFO(4) */ +/* or TSTOP at any time but you must supply the value of TSTOP in */ +/* RWORK(1) whenever you set INFO(4) = 1. */ + +/* Do not change INFO(5), INFO(6), INFO(12-17) or their associated */ +/* IWORK/RWORK locations unless you are going to restart the code. */ + +/* *** FOLLOWING A COMPLETED TASK *** */ + +/* If.. */ +/* IDID = 1, call the code again to continue the integration */ +/* another step in the direction of TOUT. */ + +/* IDID = 2 or 3, define a new TOUT and call the code again. */ +/* TOUT must be different from T. You cannot change */ +/* the direction of integration without restarting. */ + +/* IDID = 4, reset INFO(11) = 0 and call the code again to begin */ +/* the integration. (If you leave INFO(11) > 0 and */ +/* INFO(14) = 1, you may generate an infinite loop.) */ +/* In this situation, the next call to DASPK is */ +/* considered to be the first call for the problem, */ +/* in that all initializations are done. */ + +/* *** FOLLOWING AN INTERRUPTED TASK *** */ + +/* To show the code that you realize the task was interrupted and */ +/* that you want to continue, you must take appropriate action and */ +/* set INFO(1) = 1. */ + +/* If.. */ +/* IDID = -1, the code has taken about 500 steps. If you want to */ +/* continue, set INFO(1) = 1 and call the code again. */ +/* An additional 500 steps will be allowed. */ + + +/* IDID = -2, the error tolerances RTOL, ATOL have been increased */ +/* to values the code estimates appropriate for */ +/* continuing. You may want to change them yourself. */ +/* If you are sure you want to continue with relaxed */ +/* error tolerances, set INFO(1) = 1 and call the code */ +/* again. */ + +/* IDID = -3, a solution component is zero and you set the */ +/* corresponding component of ATOL to zero. If you */ +/* are sure you want to continue, you must first alter */ +/* the error criterion to use positive values of ATOL */ +/* for those components corresponding to zero solution */ +/* components, then set INFO(1) = 1 and call the code */ +/* again. */ + +/* IDID = -4 --- cannot occur with this code. */ + +/* IDID = -5, your JAC routine failed with the Krylov method. Check */ +/* for errors in JAC and restart the integration. */ + +/* IDID = -6, repeated error test failures occurred on the last */ +/* attempted step in DDASPK. A singularity in the */ +/* solution may be present. If you are absolutely */ +/* certain you want to continue, you should restart */ +/* the integration. (Provide initial values of Y and */ +/* YPRIME which are consistent.) */ + +/* IDID = -7, repeated convergence test failures occurred on the last */ +/* attempted step in DDASPK. An inaccurate or ill- */ +/* conditioned Jacobian or preconditioner may be the */ +/* problem. If you are absolutely certain you want */ +/* to continue, you should restart the integration. */ + + +/* IDID = -8, the matrix of partial derivatives is singular, with */ +/* the use of direct methods. Some of your equations */ +/* may be redundant. DDASPK cannot solve the problem */ +/* as stated. It is possible that the redundant */ +/* equations could be removed, and then DDASPK could */ +/* solve the problem. It is also possible that a */ +/* solution to your problem either does not exist */ +/* or is not unique. */ + +/* IDID = -9, DDASPK had multiple convergence test failures, preceded */ +/* by multiple error test failures, on the last */ +/* attempted step. It is possible that your problem is */ +/* ill-posed and cannot be solved using this code. Or, */ +/* there may be a discontinuity or a singularity in the */ +/* solution. If you are absolutely certain you want to */ +/* continue, you should restart the integration. */ + +/* IDID = -10, DDASPK had multiple convergence test failures */ +/* because IRES was equal to -1. If you are */ +/* absolutely certain you want to continue, you */ +/* should restart the integration. */ + +/* IDID = -11, there was an unrecoverable error (IRES = -2) from RES */ +/* inside the nonlinear system solver. Determine the */ +/* cause before trying again. */ + +/* IDID = -12, DDASPK failed to compute the initial Y and YPRIME */ +/* vectors. This could happen because the initial */ +/* approximation to Y or YPRIME was not very good, or */ +/* because no consistent values of these vectors exist. */ +/* The problem could also be caused by an inaccurate or */ +/* singular iteration matrix, or a poor preconditioner. */ + +/* IDID = -13, there was an unrecoverable error encountered inside */ +/* your PSOL routine. Determine the cause before */ +/* trying again. */ + +/* IDID = -14, the Krylov linear system solver failed to achieve */ +/* convergence. This may be due to ill-conditioning */ +/* in the iteration matrix, or a singularity in the */ +/* preconditioner (if one is being used). */ +/* Another possibility is that there is a better */ +/* choice of Krylov parameters (see INFO(13)). */ +/* Possibly the failure is caused by redundant equations */ +/* in the system, or by inconsistent equations. */ +/* In that case, reformulate the system to make it */ +/* consistent and non-redundant. */ + +/* IDID = -15,..,-32 --- Cannot occur with this code. */ + +/* *** FOLLOWING A TERMINATED TASK *** */ + +/* If IDID = -33, you cannot continue the solution of this problem. */ +/* An attempt to do so will result in your run being */ +/* terminated. */ + +/* --------------------------------------------------------------------- */ + +/* ***REFERENCES */ +/* 1. L. R. Petzold, A Description of DASSL: A Differential/Algebraic */ +/* System Solver, in Scientific Computing, R. S. Stepleman et al. */ +/* (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. */ +/* 2. K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical */ +/* Solution of Initial-Value Problems in Differential-Algebraic */ +/* Equations, Elsevier, New York, 1989. */ +/* 3. P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods */ +/* in Stiff ODE Systems, J. Applied Mathematics and Computation, */ +/* 31 (1989), pp. 40-91. */ +/* 4. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov */ +/* Methods in the Solution of Large-Scale Differential-Algebraic */ +/* Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. */ +/* 5. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent */ +/* Initial Condition Calculation for Differential-Algebraic */ +/* Systems, SIAM J. Sci. Comp. 19 (1998), pp. 1495-1512. */ + +/* ***ROUTINES CALLED */ + +/* The following are all the subordinate routines used by DDASPK. */ + +/* DDASIC computes consistent initial conditions. */ +/* DYYPNW updates Y and YPRIME in linesearch for initial condition */ +/* calculation. */ +/* DDSTP carries out one step of the integration. */ +/* DCNSTR/DCNST0 check the current solution for constraint violations. */ +/* DDAWTS sets error weight quantities. */ +/* DINVWT tests and inverts the error weights. */ +/* DDATRP performs interpolation to get an output solution. */ +/* DDWNRM computes the weighted root-mean-square norm of a vector. */ +/* D1MACH provides the unit roundoff of the computer. */ +/* XERRWD/XSETF/XSETUN/IXSAV is a package to handle error messages. */ +/* DDASID nonlinear equation driver to initialize Y and YPRIME using */ +/* direct linear system solver methods. Interfaces to Newton */ +/* solver (direct case). */ +/* DNSID solves the nonlinear system for unknown initial values by */ +/* modified Newton iteration and direct linear system methods. */ +/* DLINSD carries out linesearch algorithm for initial condition */ +/* calculation (direct case). */ +/* DFNRMD calculates weighted norm of preconditioned residual in */ +/* initial condition calculation (direct case). */ +/* DNEDD nonlinear equation driver for direct linear system solver */ +/* methods. Interfaces to Newton solver (direct case). */ +/* DMATD assembles the iteration matrix (direct case). */ +/* DNSD solves the associated nonlinear system by modified */ +/* Newton iteration and direct linear system methods. */ +/* DSLVD interfaces to linear system solver (direct case). */ +/* DDASIK nonlinear equation driver to initialize Y and YPRIME using */ +/* Krylov iterative linear system methods. Interfaces to */ +/* Newton solver (Krylov case). */ +/* DNSIK solves the nonlinear system for unknown initial values by */ +/* Newton iteration and Krylov iterative linear system methods. */ +/* DLINSK carries out linesearch algorithm for initial condition */ +/* calculation (Krylov case). */ +/* DFNRMK calculates weighted norm of preconditioned residual in */ +/* initial condition calculation (Krylov case). */ +/* DNEDK nonlinear equation driver for iterative linear system solver */ +/* methods. Interfaces to Newton solver (Krylov case). */ +/* DNSK solves the associated nonlinear system by Inexact Newton */ +/* iteration and (linear) Krylov iteration. */ +/* DSLVK interfaces to linear system solver (Krylov case). */ +/* DSPIGM solves a linear system by SPIGMR algorithm. */ +/* DATV computes matrix-vector product in Krylov algorithm. */ +/* DORTH performs orthogonalization of Krylov basis vectors. */ +/* DHEQR performs QR factorization of Hessenberg matrix. */ +/* DHELS finds least-squares solution of Hessenberg linear system. */ +/* DGEFA, DGESL, DGBFA, DGBSL are LINPACK routines for solving */ +/* linear systems (dense or band direct methods). */ +/* DAXPY, DCOPY, DDOT, DNRM2, DSCAL are Basic Linear Algebra (BLAS) */ +/* routines. */ + +/* The routines called directly by DDASPK are: */ +/* DCNST0, DDAWTS, DINVWT, D1MACH, DDWNRM, DDASIC, DDATRP, DDSTP, */ +/* XERRWD */ + +/* ***END PROLOGUE DDASPK */ + + + +/* Set pointers into IWORK. */ + + +/* Set pointers into RWORK. */ + + + + +/* ***FIRST EXECUTABLE STATEMENT DDASPK */ + + + /* Parameter adjustments */ + --y; + --yprime; + --info; + --rtol; + --atol; + --rwork; + --iwork; + --rpar; + --ipar; + + /* Function Body */ + if (info[1] != 0) { + goto L100; + } + +/* ----------------------------------------------------------------------- */ +/* This block is executed for the initial call only. */ +/* It contains checking of inputs and initializations. */ +/* ----------------------------------------------------------------------- */ + +/* First check INFO array to make sure all elements of INFO */ +/* Are within the proper range. (INFO(1) is checked later, because */ +/* it must be tested on every call.) ITEMP holds the location */ +/* within INFO which may be out of range. */ + + for (i__ = 2; i__ <= 9; ++i__) { + itemp = i__; + if (info[i__] != 0 && info[i__] != 1) { + goto L701; + } +/* L10: */ + } + itemp = 10; + if (info[10] < 0 || info[10] > 3) { + goto L701; + } + itemp = 11; + if (info[11] < 0 || info[11] > 2) { + goto L701; + } + for (i__ = 12; i__ <= 17; ++i__) { + itemp = i__; + if (info[i__] != 0 && info[i__] != 1) { + goto L701; + } +/* L15: */ + } + itemp = 18; + if (info[18] < 0 || info[18] > 2) { + goto L701; + } + +/* Check NEQ to see if it is positive. */ + + if (*neq <= 0) { + goto L702; + } + +/* Check and compute maximum order. */ + + mxord = 5; + if (info[9] != 0) { + mxord = iwork[3]; + if (mxord < 1 || mxord > 5) { + goto L703; + } + } + iwork[3] = mxord; + +/* Set and/or check inputs for constraint checking (INFO(10) .NE. 0). */ +/* Set values for ICNFLG, NONNEG, and pointer LID. */ + + icnflg = 0; + nonneg = 0; + lid = 41; + if (info[10] == 0) { + goto L20; + } + if (info[10] == 1) { + icnflg = 1; + nonneg = 0; + lid = *neq + 41; + } else if (info[10] == 2) { + icnflg = 0; + nonneg = 1; + } else { + icnflg = 1; + nonneg = 1; + lid = *neq + 41; + } + +L20: + +/* Set and/or check inputs for Krylov solver (INFO(12) .NE. 0). */ +/* If indicated, set default values for MAXL, KMP, NRMAX, and EPLI. */ +/* Otherwise, verify inputs required for iterative solver. */ + + if (info[12] == 0) { + goto L25; + } + + iwork[23] = info[12]; + if (info[13] == 0) { + iwork[24] = min(5,*neq); + iwork[25] = iwork[24]; + iwork[26] = 5; + rwork[10] = .05; + } else { + if (iwork[24] < 1 || iwork[24] > *neq) { + goto L720; + } + if (iwork[25] < 1 || iwork[25] > iwork[24]) { + goto L721; + } + if (iwork[26] < 0) { + goto L722; + } + if (rwork[10] <= 0. || rwork[10] >= 1.) { + goto L723; + } + } + +L25: + +/* Set and/or check controls for the initial condition calculation */ +/* (INFO(11) .GT. 0). If indicated, set default values. */ +/* Otherwise, verify inputs required for iterative solver. */ + + if (info[11] == 0) { + goto L30; + } + if (info[17] == 0) { + iwork[32] = 5; + if (info[12] > 0) { + iwork[32] = 15; + } + iwork[33] = 6; + if (info[12] > 0) { + iwork[33] = 2; + } + iwork[34] = 5; + iwork[35] = 0; + rwork[15] = .01; + } else { + if (iwork[32] <= 0) { + goto L725; + } + if (iwork[33] <= 0) { + goto L725; + } + if (iwork[34] <= 0) { + goto L725; + } + lsoff = iwork[35]; + if (lsoff < 0 || lsoff > 1) { + goto L725; + } + if (rwork[15] <= 0.) { + goto L725; + } + } + +L30: + +/* Below is the computation and checking of the work array lengths */ +/* LENIW and LENRW, using direct methods (INFO(12) = 0) or */ +/* the Krylov methods (INFO(12) = 1). */ + + lenic = 0; + if (info[10] == 1 || info[10] == 3) { + lenic = *neq; + } + lenid = 0; + if (info[11] == 1 || info[16] == 1) { + lenid = *neq; + } + if (info[12] == 0) { + +/* Compute MTYPE, etc. Check ML and MU. */ + +/* Computing MAX */ + i__1 = mxord + 1; + ncphi = max(i__1,4); + if (info[6] == 0) { +/* Computing 2nd power */ + i__1 = *neq; + lenpd = i__1 * i__1; + lenrw = (ncphi + 3) * *neq + 50 + lenpd; + if (info[5] == 0) { + iwork[4] = 2; + } else { + iwork[4] = 1; + } + } else { + if (iwork[1] < 0 || iwork[1] >= *neq) { + goto L717; + } + if (iwork[2] < 0 || iwork[2] >= *neq) { + goto L718; + } + lenpd = ((iwork[1] << 1) + iwork[2] + 1) * *neq; + if (info[5] == 0) { + iwork[4] = 5; + mband = iwork[1] + iwork[2] + 1; + msave = *neq / mband + 1; + lenrw = (ncphi + 3) * *neq + 50 + lenpd + (msave << 1); + } else { + iwork[4] = 4; + lenrw = (ncphi + 3) * *neq + 50 + lenpd; + } + } + +/* Compute LENIW, LENWP, LENIWP. */ + + leniw = lenic + 40 + lenid + *neq; + lenwp = 0; + leniwp = 0; + + } else if (info[12] == 1) { + ncphi = mxord + 1; + maxl = iwork[24]; + lenwp = iwork[27]; + leniwp = iwork[28]; +/* Computing MIN */ + i__1 = 1, i__2 = maxl - iwork[25]; + lenpd = (maxl + 3 + min(i__1,i__2)) * *neq + (maxl + 3) * maxl + 1 + + lenwp; + lenrw = (mxord + 5) * *neq + 50 + lenpd; + leniw = lenic + 40 + lenid + leniwp; + + } + if (info[16] != 0) { + lenrw += *neq; + } + +/* Check lengths of RWORK and IWORK. */ + + iwork[17] = leniw; + iwork[18] = lenrw; + iwork[22] = lenpd; + iwork[29] = lenpd - lenwp + 1; + if (*lrw < lenrw) { + goto L704; + } + if (*liw < leniw) { + goto L705; + } + +/* Check ICNSTR for legality. */ + + if (lenic > 0) { + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + ici = iwork[i__ + 40]; + if (ici < -2 || ici > 2) { + goto L726; + } +/* L40: */ + } + } + +/* Check Y for consistency with constraints. */ + + if (lenic > 0) { + dcnst0_(neq, &y[1], &iwork[41], &iret); + if (iret != 0) { + goto L727; + } + } + +/* Check ID for legality and set INDEX = 0 or 1. */ + + index = 1; + if (lenid > 0) { + index = 0; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + idi = iwork[lid - 1 + i__]; + if (idi != 1 && idi != -1) { + goto L724; + } + if (idi == -1) { + index = 1; + } +/* L50: */ + } + } + +/* Check to see that TOUT is different from T. */ + + if (*tout == *t) { + goto L719; + } + +/* Check HMAX. */ + + if (info[7] != 0) { + hmax = rwork[2]; + if (hmax <= 0.) { + goto L710; + } + } + +/* Initialize counters and other flags. */ + + iwork[11] = 0; + iwork[12] = 0; + iwork[13] = 0; + iwork[14] = 0; + iwork[15] = 0; + iwork[19] = 0; + iwork[20] = 0; + iwork[21] = 0; + iwork[16] = 0; + iwork[31] = info[18]; + *idid = 1; + goto L200; + +/* ----------------------------------------------------------------------- */ +/* This block is for continuation calls only. */ +/* Here we check INFO(1), and if the last step was interrupted, */ +/* we check whether appropriate action was taken. */ +/* ----------------------------------------------------------------------- */ + +L100: + if (info[1] == 1) { + goto L110; + } + itemp = 1; + if (info[1] != -1) { + goto L701; + } + +/* If we are here, the last step was interrupted by an error */ +/* condition from DDSTP, and appropriate action was not taken. */ +/* This is a fatal error. */ + + s_copy(msg, "DASPK-- THE LAST STEP TERMINATED WITH A NEGATIVE", (ftnlen) + 80, (ftnlen)49); + xerrwd_(msg, &c__49, &c__201, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + s_copy(msg, "DASPK-- VALUE (=I1) OF IDID AND NO APPROPRIATE", (ftnlen)80, + (ftnlen)47); + xerrwd_(msg, &c__47, &c__202, &c__0, &c__1, idid, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + s_copy(msg, "DASPK-- ACTION WAS TAKEN. RUN TERMINATED", (ftnlen)80, ( + ftnlen)41); + xerrwd_(msg, &c__41, &c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + return 0; +L110: + +/* ----------------------------------------------------------------------- */ +/* This block is executed on all calls. */ + +/* Counters are saved for later checks of performance. */ +/* Then the error tolerance parameters are checked, and the */ +/* work array pointers are set. */ +/* ----------------------------------------------------------------------- */ + +L200: + +/* Save counters for use later. */ + + iwork[10] = iwork[11]; + nli0 = iwork[20]; + nni0 = iwork[19]; + ncfn0 = iwork[15]; + ncfl0 = iwork[16]; + nwarn = 0; + +/* Check RTOL and ATOL. */ + + nzflg = 0; + rtoli = rtol[1]; + atoli = atol[1]; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + if (info[2] == 1) { + rtoli = rtol[i__]; + } + if (info[2] == 1) { + atoli = atol[i__]; + } + if (rtoli > 0. || atoli > 0.) { + nzflg = 1; + } + if (rtoli < 0.) { + goto L706; + } + if (atoli < 0.) { + goto L707; + } +/* L210: */ + } + if (nzflg == 0) { + goto L708; + } + +/* Set pointers to RWORK and IWORK segments. */ +/* For direct methods, SAVR is not used. */ + + iwork[30] = lid + lenid; + lsavr = 51; + if (info[12] != 0) { + lsavr = *neq + 51; + } + le = lsavr + *neq; + lwt = le + *neq; + lvt = lwt; + if (info[16] != 0) { + lvt = lwt + *neq; + } + lphi = lvt + *neq; + lwm = lphi + ncphi * *neq; + if (info[1] == 1) { + goto L400; + } + +/* ----------------------------------------------------------------------- */ +/* This block is executed on the initial call only. */ +/* Set the initial step size, the error weight vector, and PHI. */ +/* Compute unknown initial components of Y and YPRIME, if requested. */ +/* ----------------------------------------------------------------------- */ + +/* L300: */ + tn = *t; + *idid = 1; + +/* Set error weight array WT and altered weight array VT. */ + + ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], & + ipar[1]); + dinvwt_(neq, &rwork[lwt], &ier); + if (ier != 0) { + goto L713; + } + if (info[16] != 0) { + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L305: */ +/* Computing MAX */ + i__2 = iwork[lid + i__ - 1]; + rwork[lvt + i__ - 1] = max(i__2,0) * rwork[lwt + i__ - 1]; + } + } + +/* Compute unit roundoff and HMIN. */ + + uround = d1mach_(&c__4); + rwork[9] = uround; +/* Computing MAX */ + d__1 = abs(*t), d__2 = abs(*tout); + hmin = uround * 4. * max(d__1,d__2); + +/* Set/check STPTOL control for initial condition calculation. */ + + if (info[11] != 0) { + if (info[17] == 0) { + rwork[14] = pow_dd(&uround, &c_b67); + } else { + if (rwork[14] <= 0.) { + goto L725; + } + } + } + +/* Compute EPCON and square root of NEQ and its reciprocal, used */ +/* inside iterative solver. */ + + rwork[13] = .33; + floatn = (doublereal) (*neq); + rwork[11] = sqrt(floatn); + rwork[12] = 1. / rwork[11]; + +/* Check initial interval to see that it is long enough. */ + + tdist = (d__1 = *tout - *t, abs(d__1)); + if (tdist < hmin) { + goto L714; + } + +/* Check H0, if this was input. */ + + if (info[8] == 0) { + goto L310; + } + h0 = rwork[3]; + if ((*tout - *t) * h0 < 0.) { + goto L711; + } + if (h0 == 0.) { + goto L712; + } + goto L320; +L310: + +/* Compute initial stepsize, to be used by either */ +/* DDSTP or DDASIC, depending on INFO(11). */ + + h0 = tdist * .001; + ypnorm = ddwnrm_(neq, &yprime[1], &rwork[lvt], &rpar[1], &ipar[1]); + if (ypnorm > .5 / h0) { + h0 = .5 / ypnorm; + } + d__1 = *tout - *t; + h0 = d_sign(&h0, &d__1); + +/* Adjust H0 if necessary to meet HMAX bound. */ + +L320: + if (info[7] == 0) { + goto L330; + } + rh = abs(h0) / rwork[2]; + if (rh > 1.) { + h0 /= rh; + } + +/* Check against TSTOP, if applicable. */ + +L330: + if (info[4] == 0) { + goto L340; + } + tstop = rwork[1]; + s_wsle(&io___49); + do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8); + do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal)); + e_wsle(); + if ((tstop - *t) * h0 < 0.) { + goto L715; + } + if ((*t + h0 - tstop) * h0 > 0.) { + h0 = tstop - *t; + } + if ((tstop - *tout) * h0 < 0.) { + goto L709; + } + +L340: + if (info[11] == 0) { + goto L370; + } + +/* Compute unknown components of initial Y and YPRIME, depending */ +/* on INFO(11) and INFO(12). INFO(12) represents the nonlinear */ +/* solver type (direct/Krylov). Pass the name of the specific */ +/* nonlinear solver, depending on INFO(12). The location of the work */ +/* arrays SAVR, YIC, YPIC, PWK also differ in the two cases. */ +/* For use in stopping tests, pass TSCALE = TDIST if INDEX = 0. */ + + nwt = 1; + epconi = rwork[15] * rwork[13]; + tscale = 0.; + if (index == 0) { + tscale = tdist; + } +L350: + if (info[12] == 0) { + lyic = lphi + (*neq << 1); + lypic = lyic + *neq; + lpwk = lypic; + ddasic_(&tn, &y[1], &yprime[1], neq, &info[11], &iwork[lid], (U_fp) + res, (U_fp)jac, (U_fp)psol, &h0, &tscale, &rwork[lwt], &nwt, + idid, &rpar[1], &ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[ + 51], &rwork[le], &rwork[lyic], &rwork[lypic], &rwork[lpwk], & + rwork[lwm], &iwork[1], &rwork[9], &rwork[10], &rwork[11], & + rwork[12], &epconi, &rwork[14], &info[15], &icnflg, &iwork[41] + , (U_fp)ddasid_); + } else if (info[12] == 1) { + lyic = lwm; + lypic = lyic + *neq; + lpwk = lypic + *neq; + ddasic_(&tn, &y[1], &yprime[1], neq, &info[11], &iwork[lid], (U_fp) + res, (U_fp)jac, (U_fp)psol, &h0, &tscale, &rwork[lwt], &nwt, + idid, &rpar[1], &ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[ + 51], &rwork[le], &rwork[lyic], &rwork[lypic], &rwork[lpwk], & + rwork[lwm], &iwork[1], &rwork[9], &rwork[10], &rwork[11], & + rwork[12], &epconi, &rwork[14], &info[15], &icnflg, &iwork[41] + , (U_fp)ddasik_); + } + + if (*idid < 0) { + goto L600; + } + +/* DDASIC was successful. If this was the first call to DDASIC, */ +/* update the WT array (with the current Y) and call it again. */ + + if (nwt == 2) { + goto L355; + } + nwt = 2; + ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], & + ipar[1]); + dinvwt_(neq, &rwork[lwt], &ier); + if (ier != 0) { + goto L713; + } + goto L350; + +/* If INFO(14) = 1, return now with IDID = 4. */ + +L355: + if (info[14] == 1) { + *idid = 4; + h__ = h0; + if (info[11] == 1) { + rwork[7] = h0; + } + goto L590; + } + +/* Update the WT and VT arrays one more time, with the new Y. */ + + ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], & + ipar[1]); + dinvwt_(neq, &rwork[lwt], &ier); + if (ier != 0) { + goto L713; + } + if (info[16] != 0) { + i__2 = *neq; + for (i__ = 1; i__ <= i__2; ++i__) { +/* L357: */ +/* Computing MAX */ + i__1 = iwork[lid + i__ - 1]; + rwork[lvt + i__ - 1] = max(i__1,0) * rwork[lwt + i__ - 1]; + } + } + +/* Reset the initial stepsize to be used by DDSTP. */ +/* Use H0, if this was input. Otherwise, recompute H0, */ +/* and adjust it if necessary to meet HMAX bound. */ + + if (info[8] != 0) { + h0 = rwork[3]; + goto L360; + } + + h0 = tdist * .001; + ypnorm = ddwnrm_(neq, &yprime[1], &rwork[lvt], &rpar[1], &ipar[1]); + if (ypnorm > .5 / h0) { + h0 = .5 / ypnorm; + } + d__1 = *tout - *t; + h0 = d_sign(&h0, &d__1); + +L360: + if (info[7] != 0) { + rh = abs(h0) / rwork[2]; + if (rh > 1.) { + h0 /= rh; + } + } + +/* Check against TSTOP, if applicable. */ + + if (info[4] != 0) { + tstop = rwork[1]; + s_wsle(&io___57); + do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8); + do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal)); + e_wsle(); + if ((*t + h0 - tstop) * h0 > 0.) { + h0 = tstop - *t; + } + } + +/* Load H and RWORK(LH) with H0. */ + +L370: + h__ = h0; + rwork[3] = h__; + +/* Load Y and H*YPRIME into PHI(*,1) and PHI(*,2). */ + + itemp = lphi + *neq; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + rwork[lphi + i__ - 1] = y[i__]; +/* L380: */ + rwork[itemp + i__ - 1] = h__ * yprime[i__]; + } + + goto L500; + +/* ----------------------------------------------------------------------- */ +/* This block is for continuation calls only. */ +/* Its purpose is to check stop conditions before taking a step. */ +/* Adjust H if necessary to meet HMAX bound. */ +/* ----------------------------------------------------------------------- */ + +L400: + uround = rwork[9]; + done = FALSE_; + tn = rwork[4]; + h__ = rwork[3]; + if (info[7] == 0) { + goto L410; + } + rh = abs(h__) / rwork[2]; + if (rh > 1.) { + h__ /= rh; + } +L410: + if (*t == *tout) { + goto L719; + } + if ((*t - *tout) * h__ > 0.) { + goto L711; + } + if (info[4] == 1) { + goto L430; + } + if (info[3] == 1) { + goto L420; + } + if ((tn - *tout) * h__ < 0.) { + goto L490; + } + ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *t = *tout; + *idid = 3; + done = TRUE_; + goto L490; +L420: + if ((tn - *t) * h__ <= 0.) { + goto L490; + } + if ((tn - *tout) * h__ >= 0.) { + goto L425; + } + ddatrp_(&tn, &tn, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &rwork[ + 39]); + *t = tn; + *idid = 1; + done = TRUE_; + goto L490; +L425: + ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *t = *tout; + *idid = 3; + done = TRUE_; + goto L490; +L430: + if (info[3] == 1) { + goto L440; + } + tstop = rwork[1]; + s_wsle(&io___59); + do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8); + do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal)); + e_wsle(); + if ((tn - tstop) * h__ > 0.) { + goto L715; + } + if ((tstop - *tout) * h__ < 0.) { + goto L709; + } + if ((tn - *tout) * h__ < 0.) { + goto L450; + } + ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *t = *tout; + *idid = 3; + done = TRUE_; + goto L490; +L440: + tstop = rwork[1]; + s_wsle(&io___60); + do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8); + do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal)); + e_wsle(); + if ((tn - tstop) * h__ > 0.) { + goto L715; + } + if ((tstop - *tout) * h__ < 0.) { + goto L709; + } + if ((tn - *t) * h__ <= 0.) { + goto L450; + } + if ((tn - *tout) * h__ >= 0.) { + goto L445; + } + ddatrp_(&tn, &tn, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &rwork[ + 39]); + *t = tn; + *idid = 1; + done = TRUE_; + goto L490; +L445: + ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *t = *tout; + *idid = 3; + done = TRUE_; + goto L490; +L450: + +/* Check whether we are within roundoff of TSTOP. */ + + if ((d__1 = tn - tstop, abs(d__1)) > uround * 100. * (abs(tn) + abs(h__))) + { + goto L460; + } + ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *idid = 2; + *t = tstop; + done = TRUE_; + goto L490; +L460: + tnext = tn + h__; + if ((tnext - tstop) * h__ <= 0.) { + goto L490; + } + h__ = tstop - tn; + rwork[3] = h__; + +L490: + if (done) { + goto L590; + } + +/* ----------------------------------------------------------------------- */ +/* The next block contains the call to the one-step integrator DDSTP. */ +/* This is a looping point for the integration steps. */ +/* Check for too many steps. */ +/* Check for poor Newton/Krylov performance. */ +/* Update WT. Check for too much accuracy requested. */ +/* Compute minimum stepsize. */ +/* ----------------------------------------------------------------------- */ + +L500: + +/* Check for too many steps. */ + + if (iwork[11] - iwork[10] < 500) { + goto L505; + } + *idid = -1; + goto L527; + +/* Check for poor Newton/Krylov performance. */ + +L505: + if (info[12] == 0) { + goto L510; + } + nstd = iwork[11] - iwork[10]; + nnid = iwork[19] - nni0; + if (nstd < 10 || nnid == 0) { + goto L510; + } + avlin = (real) (iwork[20] - nli0) / (real) nnid; + rcfn = (real) (iwork[15] - ncfn0) / (real) nstd; + rcfl = (real) (iwork[16] - ncfl0) / (real) nnid; + fmaxl = (doublereal) iwork[24]; + lavl = avlin > fmaxl; + lcfn = rcfn > .9; + lcfl = rcfl > .9; + lwarn = lavl || lcfn || lcfl; + if (! lwarn) { + goto L510; + } + ++nwarn; + if (nwarn > 10) { + goto L510; + } + if (lavl) { + s_copy(msg, "DASPK-- Warning. Poor iterative algorithm performance " + , (ftnlen)80, (ftnlen)56); + xerrwd_(msg, &c__56, &c__501, &c__0, &c__0, &c__0, &c__0, &c__0, & + c_b37, &c_b37, (ftnlen)80); + s_copy(msg, " at T = R1. Average no. of linear iterations = R2 " + , (ftnlen)80, (ftnlen)56); + xerrwd_(msg, &c__56, &c__501, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, + &avlin, (ftnlen)80); + } + if (lcfn) { + s_copy(msg, "DASPK-- Warning. Poor iterative algorithm performance " + , (ftnlen)80, (ftnlen)56); + xerrwd_(msg, &c__56, &c__502, &c__0, &c__0, &c__0, &c__0, &c__0, & + c_b37, &c_b37, (ftnlen)80); + s_copy(msg, " at T = R1. Nonlinear convergence failure rate = R2" + , (ftnlen)80, (ftnlen)56); + xerrwd_(msg, &c__56, &c__502, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, + &rcfn, (ftnlen)80); + } + if (lcfl) { + s_copy(msg, "DASPK-- Warning. Poor iterative algorithm performance " + , (ftnlen)80, (ftnlen)56); + xerrwd_(msg, &c__56, &c__503, &c__0, &c__0, &c__0, &c__0, &c__0, & + c_b37, &c_b37, (ftnlen)80); + s_copy(msg, " at T = R1. Linear convergence failure rate = R2 " + , (ftnlen)80, (ftnlen)56); + xerrwd_(msg, &c__56, &c__503, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, + &rcfl, (ftnlen)80); + } + +/* Update WT and VT, if this is not the first call. */ + +L510: + ddawts_(neq, &info[2], &rtol[1], &atol[1], &rwork[lphi], &rwork[lwt], & + rpar[1], &ipar[1]); + dinvwt_(neq, &rwork[lwt], &ier); + if (ier != 0) { + *idid = -3; + goto L527; + } + if (info[16] != 0) { + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L515: */ +/* Computing MAX */ + i__2 = iwork[lid + i__ - 1]; + rwork[lvt + i__ - 1] = max(i__2,0) * rwork[lwt + i__ - 1]; + } + } + +/* Test for too much accuracy requested. */ + + r__ = ddwnrm_(neq, &rwork[lphi], &rwork[lwt], &rpar[1], &ipar[1]) * 100. * + uround; + if (r__ <= 1.) { + goto L525; + } + +/* Multiply RTOL and ATOL by R and return. */ + + if (info[2] == 1) { + goto L523; + } + rtol[1] = r__ * rtol[1]; + atol[1] = r__ * atol[1]; + *idid = -2; + goto L527; +L523: + i__2 = *neq; + for (i__ = 1; i__ <= i__2; ++i__) { + rtol[i__] = r__ * rtol[i__]; +/* L524: */ + atol[i__] = r__ * atol[i__]; + } + *idid = -2; + goto L527; +L525: + +/* Compute minimum stepsize. */ + +/* Computing MAX */ + d__1 = abs(tn), d__2 = abs(*tout); + hmin = uround * 4. * max(d__1,d__2); + +/* Test H vs. HMAX */ + if (info[7] != 0) { + rh = abs(h__) / rwork[2]; + if (rh > 1.) { + h__ /= rh; + } + } + +/* Call the one-step integrator. */ +/* Note that INFO(12) represents the nonlinear solver type. */ +/* Pass the required nonlinear solver, depending upon INFO(12). */ + + if (info[12] == 0) { + ddstp_(&tn, &y[1], &yprime[1], neq, (U_fp)res, (U_fp)jac, (U_fp)psol, + &h__, &rwork[lwt], &rwork[lvt], &info[1], idid, &rpar[1], & + ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[51], &rwork[le], + &rwork[lwm], &iwork[1], &rwork[21], &rwork[27], &rwork[33], & + rwork[39], &rwork[45], &rwork[5], &rwork[6], &rwork[7], & + rwork[8], &hmin, &rwork[9], &rwork[10], &rwork[11], &rwork[12] + , &rwork[13], &iwork[6], &iwork[5], &info[15], &iwork[7], & + iwork[8], &iwork[9], &nonneg, &info[12], (U_fp)dnedd_); + } else if (info[12] == 1) { + ddstp_(&tn, &y[1], &yprime[1], neq, (U_fp)res, (U_fp)jac, (U_fp)psol, + &h__, &rwork[lwt], &rwork[lvt], &info[1], idid, &rpar[1], & + ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[51], &rwork[le], + &rwork[lwm], &iwork[1], &rwork[21], &rwork[27], &rwork[33], & + rwork[39], &rwork[45], &rwork[5], &rwork[6], &rwork[7], & + rwork[8], &hmin, &rwork[9], &rwork[10], &rwork[11], &rwork[12] + , &rwork[13], &iwork[6], &iwork[5], &info[15], &iwork[7], & + iwork[8], &iwork[9], &nonneg, &info[12], (U_fp)dnedk_); + } + +L527: + if (*idid < 0) { + goto L600; + } + +/* ----------------------------------------------------------------------- */ +/* This block handles the case of a successful return from DDSTP */ +/* (IDID=1). Test for stop conditions. */ +/* ----------------------------------------------------------------------- */ + + if (info[4] != 0) { + goto L540; + } + if (info[3] != 0) { + goto L530; + } + if ((tn - *tout) * h__ < 0.) { + goto L500; + } + ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *idid = 3; + *t = *tout; + goto L580; +L530: + if ((tn - *tout) * h__ >= 0.) { + goto L535; + } + *t = tn; + *idid = 1; + goto L580; +L535: + ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *idid = 3; + *t = *tout; + goto L580; +L540: + if (info[3] != 0) { + goto L550; + } + if ((tn - *tout) * h__ < 0.) { + goto L542; + } + ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *t = *tout; + *idid = 3; + goto L580; +L542: + if ((d__1 = tn - tstop, abs(d__1)) <= uround * 100. * (abs(tn) + abs(h__)) + ) { + goto L545; + } + tnext = tn + h__; + if ((tnext - tstop) * h__ <= 0.) { + goto L500; + } + h__ = tstop - tn; + goto L500; +L545: + ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *idid = 2; + *t = tstop; + goto L580; +L550: + if ((tn - *tout) * h__ >= 0.) { + goto L555; + } + if ((d__1 = tn - tstop, abs(d__1)) <= uround * 100. * (abs(tn) + abs(h__)) + ) { + goto L552; + } + *t = tn; + *idid = 1; + goto L580; +L552: + ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *idid = 2; + *t = tstop; + goto L580; +L555: + ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & + rwork[39]); + *t = *tout; + *idid = 3; +L580: + +/* ----------------------------------------------------------------------- */ +/* All successful returns from DDASPK are made from this block. */ +/* ----------------------------------------------------------------------- */ + +L590: + rwork[4] = tn; + rwork[3] = h__; + return 0; + +/* ----------------------------------------------------------------------- */ +/* This block handles all unsuccessful returns other than for */ +/* illegal input. */ +/* ----------------------------------------------------------------------- */ + +L600: + itemp = -(*idid); + switch (itemp) { + case 1: goto L610; + case 2: goto L620; + case 3: goto L630; + case 4: goto L700; + case 5: goto L655; + case 6: goto L640; + case 7: goto L650; + case 8: goto L660; + case 9: goto L670; + case 10: goto L675; + case 11: goto L680; + case 12: goto L685; + case 13: goto L690; + case 14: goto L695; + } + +/* The maximum number of steps was taken before */ +/* reaching tout. */ + +L610: + s_copy(msg, "DASPK-- AT CURRENT T (=R1) 500 STEPS", (ftnlen)80, (ftnlen) + 38); + xerrwd_(msg, &c__38, &c__610, &c__0, &c__0, &c__0, &c__0, &c__1, &tn, & + c_b37, (ftnlen)80); + s_copy(msg, "DASPK-- TAKEN ON THIS CALL BEFORE REACHING TOUT", (ftnlen) + 80, (ftnlen)48); + xerrwd_(msg, &c__48, &c__611, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* Too much accuracy for machine precision. */ + +L620: + s_copy(msg, "DASPK-- AT T (=R1) TOO MUCH ACCURACY REQUESTED", (ftnlen)80, + (ftnlen)47); + xerrwd_(msg, &c__47, &c__620, &c__0, &c__0, &c__0, &c__0, &c__1, &tn, & + c_b37, (ftnlen)80); + s_copy(msg, "DASPK-- FOR PRECISION OF MACHINE. RTOL AND ATOL", (ftnlen) + 80, (ftnlen)48); + xerrwd_(msg, &c__48, &c__621, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + s_copy(msg, "DASPK-- WERE INCREASED TO APPROPRIATE VALUES", (ftnlen)80, ( + ftnlen)45); + xerrwd_(msg, &c__45, &c__622, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* WT(I) .LE. 0.0D0 for some I (not at start of problem). */ + +L630: + s_copy(msg, "DASPK-- AT T (=R1) SOME ELEMENT OF WT", (ftnlen)80, (ftnlen) + 38); + xerrwd_(msg, &c__38, &c__630, &c__0, &c__0, &c__0, &c__0, &c__1, &tn, & + c_b37, (ftnlen)80); + s_copy(msg, "DASPK-- HAS BECOME .LE. 0.0", (ftnlen)80, (ftnlen)28); + xerrwd_(msg, &c__28, &c__631, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* Error test failed repeatedly or with H=HMIN. */ + +L640: + s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( + ftnlen)44); + xerrwd_(msg, &c__44, &c__640, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & + h__, (ftnlen)80); + s_copy(msg, "DASPK-- ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN", ( + ftnlen)80, (ftnlen)57); + xerrwd_(msg, &c__57, &c__641, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* Nonlinear solver failed to converge repeatedly or with H=HMIN. */ + +L650: + s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( + ftnlen)44); + xerrwd_(msg, &c__44, &c__650, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & + h__, (ftnlen)80); + s_copy(msg, "DASPK-- NONLINEAR SOLVER FAILED TO CONVERGE", (ftnlen)80, ( + ftnlen)44); + xerrwd_(msg, &c__44, &c__651, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + s_copy(msg, "DASPK-- REPEATEDLY OR WITH ABS(H)=HMIN", (ftnlen)80, ( + ftnlen)39); + xerrwd_(msg, &c__40, &c__652, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* The preconditioner had repeated failures. */ + +L655: + s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( + ftnlen)44); + xerrwd_(msg, &c__44, &c__655, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & + h__, (ftnlen)80); + s_copy(msg, "DASPK-- PRECONDITIONER HAD REPEATED FAILURES.", (ftnlen)80, + (ftnlen)46); + xerrwd_(msg, &c__46, &c__656, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* The iteration matrix is singular. */ + +L660: + s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( + ftnlen)44); + xerrwd_(msg, &c__44, &c__660, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & + h__, (ftnlen)80); + s_copy(msg, "DASPK-- ITERATION MATRIX IS SINGULAR.", (ftnlen)80, (ftnlen) + 38); + xerrwd_(msg, &c__38, &c__661, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* Nonlinear system failure preceded by error test failures. */ + +L670: + s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( + ftnlen)44); + xerrwd_(msg, &c__44, &c__670, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & + h__, (ftnlen)80); + s_copy(msg, "DASPK-- NONLINEAR SOLVER COULD NOT CONVERGE.", (ftnlen)80, ( + ftnlen)45); + xerrwd_(msg, &c__45, &c__671, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + s_copy(msg, "DASPK-- ALSO, THE ERROR TEST FAILED REPEATEDLY.", (ftnlen) + 80, (ftnlen)48); + xerrwd_(msg, &c__49, &c__672, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* Nonlinear system failure because IRES = -1. */ + +L675: + s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( + ftnlen)44); + xerrwd_(msg, &c__44, &c__675, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & + h__, (ftnlen)80); + s_copy(msg, "DASPK-- NONLINEAR SYSTEM SOLVER COULD NOT CONVERGE", ( + ftnlen)80, (ftnlen)51); + xerrwd_(msg, &c__51, &c__676, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + s_copy(msg, "DASPK-- BECAUSE IRES WAS EQUAL TO MINUS ONE", (ftnlen)80, ( + ftnlen)44); + xerrwd_(msg, &c__44, &c__677, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* Failure because IRES = -2. */ + +L680: + s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2)", (ftnlen)80, ( + ftnlen)40); + xerrwd_(msg, &c__40, &c__680, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & + h__, (ftnlen)80); + s_copy(msg, "DASPK-- IRES WAS EQUAL TO MINUS TWO", (ftnlen)80, (ftnlen) + 36); + xerrwd_(msg, &c__36, &c__681, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* Failed to compute initial YPRIME. */ + +L685: + s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( + ftnlen)44); + xerrwd_(msg, &c__44, &c__685, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + s_copy(msg, "DASPK-- INITIAL (Y,YPRIME) COULD NOT BE COMPUTED", (ftnlen) + 80, (ftnlen)49); + xerrwd_(msg, &c__49, &c__686, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &h0, + (ftnlen)80); + goto L700; + +/* Failure because IER was negative from PSOL. */ + +L690: + s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2)", (ftnlen)80, ( + ftnlen)40); + xerrwd_(msg, &c__40, &c__690, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & + h__, (ftnlen)80); + s_copy(msg, "DASPK-- IER WAS NEGATIVE FROM PSOL", (ftnlen)80, (ftnlen)35) + ; + xerrwd_(msg, &c__35, &c__691, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + +/* Failure because the linear system solver could not converge. */ + +L695: + s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( + ftnlen)44); + xerrwd_(msg, &c__44, &c__695, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & + h__, (ftnlen)80); + s_copy(msg, "DASPK-- LINEAR SYSTEM SOLVER COULD NOT CONVERGE.", (ftnlen) + 80, (ftnlen)49); + xerrwd_(msg, &c__50, &c__696, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L700; + + +L700: + info[1] = -1; + *t = tn; + rwork[4] = tn; + rwork[3] = h__; + return 0; + +/* ----------------------------------------------------------------------- */ +/* This block handles all error returns due to illegal input, */ +/* as detected before calling DDSTP. */ +/* First the error message routine is called. If this happens */ +/* twice in succession, execution is terminated. */ +/* ----------------------------------------------------------------------- */ + +L701: + s_copy(msg, "DASPK-- ELEMENT (=I1) OF INFO VECTOR IS NOT VALID", (ftnlen) + 80, (ftnlen)50); + xerrwd_(msg, &c__50, &c__1, &c__0, &c__1, &itemp, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L702: + s_copy(msg, "DASPK-- NEQ (=I1) .LE. 0", (ftnlen)80, (ftnlen)25); + xerrwd_(msg, &c__25, &c__2, &c__0, &c__1, neq, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L703: + s_copy(msg, "DASPK-- MAXORD (=I1) NOT IN RANGE", (ftnlen)80, (ftnlen)34); + xerrwd_(msg, &c__34, &c__3, &c__0, &c__1, &mxord, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L704: + s_copy(msg, "DASPK-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)" + , (ftnlen)80, (ftnlen)60); + xerrwd_(msg, &c__60, &c__4, &c__0, &c__2, &lenrw, lrw, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L705: + s_copy(msg, "DASPK-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)" + , (ftnlen)80, (ftnlen)60); + xerrwd_(msg, &c__60, &c__5, &c__0, &c__2, &leniw, liw, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L706: + s_copy(msg, "DASPK-- SOME ELEMENT OF RTOL IS .LT. 0", (ftnlen)80, ( + ftnlen)39); + xerrwd_(msg, &c__39, &c__6, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L707: + s_copy(msg, "DASPK-- SOME ELEMENT OF ATOL IS .LT. 0", (ftnlen)80, ( + ftnlen)39); + xerrwd_(msg, &c__39, &c__7, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L708: + s_copy(msg, "DASPK-- ALL ELEMENTS OF RTOL AND ATOL ARE ZERO", (ftnlen)80, + (ftnlen)47); + xerrwd_(msg, &c__47, &c__8, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L709: + s_copy(msg, "DASPK-- INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)", ( + ftnlen)80, (ftnlen)54); + xerrwd_(msg, &c__54, &c__9, &c__0, &c__0, &c__0, &c__0, &c__2, &tstop, + tout, (ftnlen)80); + goto L750; +L710: + s_copy(msg, "DASPK-- HMAX (=R1) .LT. 0.0", (ftnlen)80, (ftnlen)28); + xerrwd_(msg, &c__28, &c__10, &c__0, &c__0, &c__0, &c__0, &c__1, &hmax, & + c_b37, (ftnlen)80); + goto L750; +L711: + s_copy(msg, "DASPK-- TOUT (=R1) BEHIND T (=R2)", (ftnlen)80, (ftnlen)34); + xerrwd_(msg, &c__34, &c__11, &c__0, &c__0, &c__0, &c__0, &c__2, tout, t, ( + ftnlen)80); + goto L750; +L712: + s_copy(msg, "DASPK-- INFO(8)=1 AND H0=0.0", (ftnlen)80, (ftnlen)29); + xerrwd_(msg, &c__29, &c__12, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L713: + s_copy(msg, "DASPK-- SOME ELEMENT OF WT IS .LE. 0.0", (ftnlen)80, ( + ftnlen)39); + xerrwd_(msg, &c__39, &c__13, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L714: + s_copy(msg, "DASPK-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION" + , (ftnlen)80, (ftnlen)60); + xerrwd_(msg, &c__60, &c__14, &c__0, &c__0, &c__0, &c__0, &c__2, tout, t, ( + ftnlen)80); + goto L750; +L715: + s_copy(msg, "DASPK-- INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)", (ftnlen) + 80, (ftnlen)49); + xerrwd_(msg, &c__49, &c__15, &c__0, &c__0, &c__0, &c__0, &c__2, &tstop, t, + (ftnlen)80); + goto L750; +L717: + s_copy(msg, "DASPK-- ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ", ( + ftnlen)80, (ftnlen)52); + xerrwd_(msg, &c__52, &c__17, &c__0, &c__1, &iwork[1], &c__0, &c__0, & + c_b37, &c_b37, (ftnlen)80); + goto L750; +L718: + s_copy(msg, "DASPK-- MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ", ( + ftnlen)80, (ftnlen)52); + xerrwd_(msg, &c__52, &c__18, &c__0, &c__1, &iwork[2], &c__0, &c__0, & + c_b37, &c_b37, (ftnlen)80); + goto L750; +L719: + s_copy(msg, "DASPK-- TOUT (=R1) IS EQUAL TO T (=R2)", (ftnlen)80, ( + ftnlen)39); + xerrwd_(msg, &c__39, &c__19, &c__0, &c__0, &c__0, &c__0, &c__2, tout, t, ( + ftnlen)80); + goto L750; +L720: + s_copy(msg, "DASPK-- MAXL (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. NEQ", ( + ftnlen)80, (ftnlen)54); + xerrwd_(msg, &c__54, &c__20, &c__0, &c__1, &iwork[24], &c__0, &c__0, & + c_b37, &c_b37, (ftnlen)80); + goto L750; +L721: + s_copy(msg, "DASPK-- KMP (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. MAXL", ( + ftnlen)80, (ftnlen)54); + xerrwd_(msg, &c__54, &c__21, &c__0, &c__1, &iwork[25], &c__0, &c__0, & + c_b37, &c_b37, (ftnlen)80); + goto L750; +L722: + s_copy(msg, "DASPK-- NRMAX (=I1) ILLEGAL. .LT. 0", (ftnlen)80, (ftnlen) + 36); + xerrwd_(msg, &c__36, &c__22, &c__0, &c__1, &iwork[26], &c__0, &c__0, & + c_b37, &c_b37, (ftnlen)80); + goto L750; +L723: + s_copy(msg, "DASPK-- EPLI (=R1) ILLEGAL. EITHER .LE. 0.D0 OR .GE. 1.D0", + (ftnlen)80, (ftnlen)58); + xerrwd_(msg, &c__58, &c__23, &c__0, &c__0, &c__0, &c__0, &c__1, &rwork[10] + , &c_b37, (ftnlen)80); + goto L750; +L724: + s_copy(msg, "DASPK-- ILLEGAL IWORK VALUE FOR INFO(11) .NE. 0", (ftnlen) + 80, (ftnlen)48); + xerrwd_(msg, &c__48, &c__24, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L725: + s_copy(msg, "DASPK-- ONE OF THE INPUTS FOR INFO(17) = 1 IS ILLEGAL", ( + ftnlen)80, (ftnlen)54); + xerrwd_(msg, &c__54, &c__25, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L726: + s_copy(msg, "DASPK-- ILLEGAL IWORK VALUE FOR INFO(10) .NE. 0", (ftnlen) + 80, (ftnlen)48); + xerrwd_(msg, &c__48, &c__26, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L727: + s_copy(msg, "DASPK-- Y(I) AND IWORK(40+I) (I=I1) INCONSISTENT", (ftnlen) + 80, (ftnlen)49); + xerrwd_(msg, &c__49, &c__27, &c__0, &c__1, &iret, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + goto L750; +L750: + if (info[1] == -1) { + goto L760; + } + info[1] = -1; + *idid = -33; + return 0; +L760: + s_copy(msg, "DASPK-- REPEATED OCCURRENCES OF ILLEGAL INPUT", (ftnlen)80, + (ftnlen)46); + xerrwd_(msg, &c__46, &c__701, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); +/* L770: */ + s_copy(msg, "DASPK-- RUN TERMINATED. APPARENT INFINITE LOOP", (ftnlen)80, + (ftnlen)47); + xerrwd_(msg, &c__47, &c__702, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b37, & + c_b37, (ftnlen)80); + return 0; + +/* ------END OF SUBROUTINE DDASPK----------------------------------------- */ +} /* ddaspk_ */ + +/* Subroutine */ int ddasic_(doublereal *x, doublereal *y, doublereal *yprime, + integer *neq, integer *icopt, integer *id, U_fp res, U_fp jac, U_fp + psol, doublereal *h__, doublereal *tscale, doublereal *wt, integer * + nic, integer *idid, doublereal *rpar, integer *ipar, doublereal *phi, + doublereal *savr, doublereal *delta, doublereal *e, doublereal *yic, + doublereal *ypic, doublereal *pwk, doublereal *wm, integer *iwm, + doublereal *uround, doublereal *epli, doublereal *sqrtn, doublereal * + rsqrtn, doublereal *epconi, doublereal *stptol, integer *jflg, + integer *icnflg, integer *icnstr, S_fp nlsic) +{ + /* Initialized data */ + + static doublereal rhcut = .1; + static doublereal ratemx = .8; + + /* System generated locals */ + integer phi_dim1, phi_offset; + + /* Local variables */ + static doublereal cj; + static integer nh, mxnh; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + static integer jskip, iernls; + + +/* ***BEGIN PROLOGUE DDASIC */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 940628 (YYMMDD) */ +/* ***REVISION DATE 941206 (YYMMDD) */ +/* ***REVISION DATE 950714 (YYMMDD) */ +/* ***REVISION DATE 000628 TSCALE argument added. */ + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DDASIC is a driver routine to compute consistent initial values */ +/* for Y and YPRIME. There are two different options: */ +/* Denoting the differential variables in Y by Y_d, and */ +/* the algebraic variables by Y_a, the problem solved is either: */ +/* 1. Given Y_d, calculate Y_a and Y_d', or */ +/* 2. Given Y', calculate Y. */ +/* In either case, initial values for the given components */ +/* are input, and initial guesses for the unknown components */ +/* must also be provided as input. */ + +/* The external routine NLSIC solves the resulting nonlinear system. */ + +/* The parameters represent */ + +/* X -- Independent variable. */ +/* Y -- Solution vector at X. */ +/* YPRIME -- Derivative of solution vector. */ +/* NEQ -- Number of equations to be integrated. */ +/* ICOPT -- Flag indicating initial condition option chosen. */ +/* ICOPT = 1 for option 1 above. */ +/* ICOPT = 2 for option 2. */ +/* ID -- Array of dimension NEQ, which must be initialized */ +/* if option 1 is chosen. */ +/* ID(i) = +1 if Y_i is a differential variable, */ +/* ID(i) = -1 if Y_i is an algebraic variable. */ +/* RES -- External user-supplied subroutine to evaluate the */ +/* residual. See RES description in DDASPK prologue. */ +/* JAC -- External user-supplied routine to update Jacobian */ +/* or preconditioner information in the nonlinear solver */ +/* (optional). See JAC description in DDASPK prologue. */ +/* PSOL -- External user-supplied routine to solve */ +/* a linear system using preconditioning. */ +/* See PSOL in DDASPK prologue. */ +/* H -- Scaling factor in iteration matrix. DDASIC may */ +/* reduce H to achieve convergence. */ +/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ +/* WT -- Vector of weights for error criterion. */ +/* NIC -- Input number of initial condition calculation call */ +/* (= 1 or 2). */ +/* IDID -- Completion code. See IDID in DDASPK prologue. */ +/* RPAR,IPAR -- Real and integer parameter arrays that */ +/* are used for communication between the */ +/* calling program and external user routines. */ +/* They are not altered by DNSK */ +/* PHI -- Work space for DDASIC of length at least 2*NEQ. */ +/* SAVR -- Work vector for DDASIC of length NEQ. */ +/* DELTA -- Work vector for DDASIC of length NEQ. */ +/* E -- Work vector for DDASIC of length NEQ. */ +/* YIC,YPIC -- Work vectors for DDASIC, each of length NEQ. */ +/* PWK -- Work vector for DDASIC of length NEQ. */ +/* WM,IWM -- Real and integer arrays storing */ +/* information required by the linear solver. */ +/* EPCONI -- Test constant for Newton iteration convergence. */ +/* ICNFLG -- Flag showing whether constraints on Y are to apply. */ +/* ICNSTR -- Integer array of length NEQ with constraint types. */ + +/* The other parameters are for use internally by DDASIC. */ + +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* DCOPY, NLSIC */ + +/* ***END PROLOGUE DDASIC */ + + + + +/* The following parameters are data-loaded here: */ +/* RHCUT = factor by which H is reduced on retry of Newton solve. */ +/* RATEMX = maximum convergence rate for which Newton iteration */ +/* is considered converging. */ + + /* Parameter adjustments */ + --y; + --yprime; + phi_dim1 = *neq; + phi_offset = 1 + phi_dim1; + phi -= phi_offset; + --id; + --wt; + --rpar; + --ipar; + --savr; + --delta; + --e; + --yic; + --ypic; + --pwk; + --wm; + --iwm; + --icnstr; + + /* Function Body */ + + +/* ----------------------------------------------------------------------- */ +/* BLOCK 1. */ +/* Initializations. */ +/* JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that */ +/* the initial call to the JAC routine is to be skipped then. */ +/* Save Y and YPRIME in PHI. Initialize IDID, NH, and CJ. */ +/* ----------------------------------------------------------------------- */ + + mxnh = iwm[34]; + *idid = 1; + nh = 1; + jskip = 0; + if (*nic == 2) { + jskip = 1; + } + dcopy_(neq, &y[1], &c__1, &phi[phi_dim1 + 1], &c__1); + dcopy_(neq, &yprime[1], &c__1, &phi[(phi_dim1 << 1) + 1], &c__1); + + if (*icopt == 2) { + cj = 0.; + } else { + cj = 1. / *h__; + } + +/* ----------------------------------------------------------------------- */ +/* BLOCK 2 */ +/* Call the nonlinear system solver to obtain */ +/* consistent initial values for Y and YPRIME. */ +/* ----------------------------------------------------------------------- */ + +L200: + (*nlsic)(x, &y[1], &yprime[1], neq, icopt, &id[1], (U_fp)res, (U_fp)jac, ( + U_fp)psol, h__, tscale, &wt[1], &jskip, &rpar[1], &ipar[1], &savr[ + 1], &delta[1], &e[1], &yic[1], &ypic[1], &pwk[1], &wm[1], &iwm[1], + &cj, uround, epli, sqrtn, rsqrtn, epconi, &ratemx, stptol, jflg, + icnflg, &icnstr[1], &iernls); + + if (iernls == 0) { + return 0; + } + +/* ----------------------------------------------------------------------- */ +/* BLOCK 3 */ +/* The nonlinear solver was unsuccessful. Increment NCFN. */ +/* Return with IDID = -12 if either */ +/* IERNLS = -1: error is considered unrecoverable, */ +/* ICOPT = 2: we are doing initialization problem type 2, or */ +/* NH = MXNH: the maximum number of H values has been tried. */ +/* Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again. */ +/* If IERNLS > 1, restore Y and YPRIME to their original values. */ +/* ----------------------------------------------------------------------- */ + + ++iwm[15]; + jskip = 0; + + if (iernls == -1) { + goto L350; + } + if (*icopt == 2) { + goto L350; + } + if (nh == mxnh) { + goto L350; + } + + ++nh; + *h__ *= rhcut; + cj = 1. / *h__; + + if (iernls == 1) { + goto L200; + } + + dcopy_(neq, &phi[phi_dim1 + 1], &c__1, &y[1], &c__1); + dcopy_(neq, &phi[(phi_dim1 << 1) + 1], &c__1, &yprime[1], &c__1); + goto L200; + +L350: + *idid = -12; + return 0; + +/* ------END OF SUBROUTINE DDASIC----------------------------------------- */ +} /* ddasic_ */ + +/* Subroutine */ int dyypnw_(integer *neq, doublereal *y, doublereal *yprime, + doublereal *cj, doublereal *rl, doublereal *p, integer *icopt, + integer *id, doublereal *ynew, doublereal *ypnew) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__; + + +/* ***BEGIN PROLOGUE DYYPNW */ +/* ***REFER TO DLINSK */ +/* ***DATE WRITTEN 940830 (YYMMDD) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DYYPNW calculates the new (Y,YPRIME) pair needed in the */ +/* linesearch algorithm based on the current lambda value. It is */ +/* called by DLINSK and DLINSD. Based on the ICOPT and ID values, */ +/* the corresponding entry in Y or YPRIME is updated. */ + +/* In addition to the parameters described in the calling programs, */ +/* the parameters represent */ + +/* P -- Array of length NEQ that contains the current */ +/* approximate Newton step. */ +/* RL -- Scalar containing the current lambda value. */ +/* YNEW -- Array of length NEQ containing the updated Y vector. */ +/* YPNEW -- Array of length NEQ containing the updated YPRIME */ +/* vector. */ +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED (NONE) */ + +/* ***END PROLOGUE DYYPNW */ + + + + /* Parameter adjustments */ + --ypnew; + --ynew; + --id; + --p; + --yprime; + --y; + + /* Function Body */ + if (*icopt == 1) { + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + if (id[i__] < 0) { + ynew[i__] = y[i__] - *rl * p[i__]; + ypnew[i__] = yprime[i__]; + } else { + ynew[i__] = y[i__]; + ypnew[i__] = yprime[i__] - *rl * *cj * p[i__]; + } +/* L10: */ + } + } else { + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + ynew[i__] = y[i__] - *rl * p[i__]; + ypnew[i__] = yprime[i__]; +/* L20: */ + } + } + return 0; +/* ----------------------- END OF SUBROUTINE DYYPNW ---------------------- */ +} /* dyypnw_ */ + +/* Subroutine */ int ddstp_(doublereal *x, doublereal *y, doublereal *yprime, + integer *neq, U_fp res, U_fp jac, U_fp psol, doublereal *h__, + doublereal *wt, doublereal *vt, integer *jstart, integer *idid, + doublereal *rpar, integer *ipar, doublereal *phi, doublereal *savr, + doublereal *delta, doublereal *e, doublereal *wm, integer *iwm, + doublereal *alpha, doublereal *beta, doublereal *gamma, doublereal * + psi, doublereal *sigma, doublereal *cj, doublereal *cjold, doublereal + *hold, doublereal *s, doublereal *hmin, doublereal *uround, + doublereal *epli, doublereal *sqrtn, doublereal *rsqrtn, doublereal * + epcon, integer *iphase, integer *jcalc, integer *jflg, integer *k, + integer *kold, integer *ns, integer *nonneg, integer *ntype, S_fp nls) +{ + /* System generated locals */ + integer phi_dim1, phi_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Builtin functions */ + double pow_dd(doublereal *, doublereal *); + + /* Local variables */ + static integer i__, j; + static doublereal r__; + static integer j1; + static doublereal ck; + static integer km1, kp1, kp2, ncf, nef; + static doublereal erk, err, est; + static integer nsp1; + static doublereal hnew, terk, xold; + static integer knew; + static doublereal erkm1, erkm2, erkp1, temp1, temp2; + static integer kdiff; + static doublereal enorm, alpha0, terkm1, terkm2, terkp1, alphas; + extern /* Subroutine */ int ddatrp_(doublereal *, doublereal *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + doublereal *); + static doublereal cjlast; + extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + static integer iernls; + + +/* ***BEGIN PROLOGUE DDSTP */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***REVISION DATE 940909 (YYMMDD) (Reset PSI(1), PHI(*,2) at 690) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DDSTP solves a system of differential/algebraic equations of */ +/* the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H). */ + +/* The methods used are modified divided difference, fixed leading */ +/* coefficient forms of backward differentiation formulas. */ +/* The code adjusts the stepsize and order to control the local error */ +/* per step. */ + + +/* The parameters represent */ +/* X -- Independent variable. */ +/* Y -- Solution vector at X. */ +/* YPRIME -- Derivative of solution vector */ +/* after successful step. */ +/* NEQ -- Number of equations to be integrated. */ +/* RES -- External user-supplied subroutine */ +/* to evaluate the residual. See RES description */ +/* in DDASPK prologue. */ +/* JAC -- External user-supplied routine to update */ +/* Jacobian or preconditioner information in the */ +/* nonlinear solver. See JAC description in DDASPK */ +/* prologue. */ +/* PSOL -- External user-supplied routine to solve */ +/* a linear system using preconditioning. */ +/* (This is optional). See PSOL in DDASPK prologue. */ +/* H -- Appropriate step size for next step. */ +/* Normally determined by the code. */ +/* WT -- Vector of weights for error criterion used in Newton test. */ +/* VT -- Masked vector of weights used in error test. */ +/* JSTART -- Integer variable set 0 for */ +/* first step, 1 otherwise. */ +/* IDID -- Completion code returned from the nonlinear solver. */ +/* See IDID description in DDASPK prologue. */ +/* RPAR,IPAR -- Real and integer parameter arrays that */ +/* are used for communication between the */ +/* calling program and external user routines. */ +/* They are not altered by DNSK */ +/* PHI -- Array of divided differences used by */ +/* DDSTP. The length is NEQ*(K+1), where */ +/* K is the maximum order. */ +/* SAVR -- Work vector for DDSTP of length NEQ. */ +/* DELTA,E -- Work vectors for DDSTP of length NEQ. */ +/* WM,IWM -- Real and integer arrays storing */ +/* information required by the linear solver. */ + +/* The other parameters are information */ +/* which is needed internally by DDSTP to */ +/* continue from step to step. */ + +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* NLS, DDWNRM, DDATRP */ + +/* ***END PROLOGUE DDSTP */ + + + + + +/* ----------------------------------------------------------------------- */ +/* BLOCK 1. */ +/* Initialize. On the first call, set */ +/* the order to 1 and initialize */ +/* other variables. */ +/* ----------------------------------------------------------------------- */ + +/* Initializations for all calls */ + + /* Parameter adjustments */ + --y; + --yprime; + phi_dim1 = *neq; + phi_offset = 1 + phi_dim1; + phi -= phi_offset; + --wt; + --vt; + --rpar; + --ipar; + --savr; + --delta; + --e; + --wm; + --iwm; + --alpha; + --beta; + --gamma; + --psi; + --sigma; + + /* Function Body */ + xold = *x; + ncf = 0; + nef = 0; + if (*jstart != 0) { + goto L120; + } + +/* If this is the first step, perform */ +/* other initializations */ + + *k = 1; + *kold = 0; + *hold = 0.; + psi[1] = *h__; + *cj = 1. / *h__; + *iphase = 0; + *ns = 0; +L120: + + + + + +/* ----------------------------------------------------------------------- */ +/* BLOCK 2 */ +/* Compute coefficients of formulas for */ +/* this step. */ +/* ----------------------------------------------------------------------- */ +L200: + kp1 = *k + 1; + kp2 = *k + 2; + km1 = *k - 1; + if (*h__ != *hold || *k != *kold) { + *ns = 0; + } +/* Computing MIN */ + i__1 = *ns + 1, i__2 = *kold + 2; + *ns = min(i__1,i__2); + nsp1 = *ns + 1; + if (kp1 < *ns) { + goto L230; + } + + beta[1] = 1.; + alpha[1] = 1.; + temp1 = *h__; + gamma[1] = 0.; + sigma[1] = 1.; + i__1 = kp1; + for (i__ = 2; i__ <= i__1; ++i__) { + temp2 = psi[i__ - 1]; + psi[i__ - 1] = temp1; + beta[i__] = beta[i__ - 1] * psi[i__ - 1] / temp2; + temp1 = temp2 + *h__; + alpha[i__] = *h__ / temp1; + sigma[i__] = (i__ - 1) * sigma[i__ - 1] * alpha[i__]; + gamma[i__] = gamma[i__ - 1] + alpha[i__ - 1] / *h__; +/* L210: */ + } + psi[kp1] = temp1; +L230: + +/* Compute ALPHAS, ALPHA0 */ + + alphas = 0.; + alpha0 = 0.; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + alphas -= 1. / i__; + alpha0 -= alpha[i__]; +/* L240: */ + } + +/* Compute leading coefficient CJ */ + + cjlast = *cj; + *cj = -alphas / *h__; + +/* Compute variable stepsize error coefficient CK */ + + ck = (d__1 = alpha[kp1] + alphas - alpha0, abs(d__1)); +/* Computing MAX */ + d__1 = ck, d__2 = alpha[kp1]; + ck = max(d__1,d__2); + +/* Change PHI to PHI STAR */ + + if (kp1 < nsp1) { + goto L280; + } + i__1 = kp1; + for (j = nsp1; j <= i__1; ++j) { + i__2 = *neq; + for (i__ = 1; i__ <= i__2; ++i__) { +/* L260: */ + phi[i__ + j * phi_dim1] = beta[j] * phi[i__ + j * phi_dim1]; + } +/* L270: */ + } +L280: + +/* Update time */ + + *x += *h__; + +/* Initialize IDID to 1 */ + + *idid = 1; + + + + + +/* ----------------------------------------------------------------------- */ +/* BLOCK 3 */ +/* Call the nonlinear system solver to obtain the solution and */ +/* derivative. */ +/* ----------------------------------------------------------------------- */ + + (*nls)(x, &y[1], &yprime[1], neq, (U_fp)res, (U_fp)jac, (U_fp)psol, h__, & + wt[1], jstart, idid, &rpar[1], &ipar[1], &phi[phi_offset], &gamma[ + 1], &savr[1], &delta[1], &e[1], &wm[1], &iwm[1], cj, cjold, & + cjlast, s, uround, epli, sqrtn, rsqrtn, epcon, jcalc, jflg, &kp1, + nonneg, ntype, &iernls); + + if (iernls != 0) { + goto L600; + } + + + + + +/* ----------------------------------------------------------------------- */ +/* BLOCK 4 */ +/* Estimate the errors at orders K,K-1,K-2 */ +/* as if constant stepsize was used. Estimate */ +/* the local error at order K and test */ +/* whether the current step is successful. */ +/* ----------------------------------------------------------------------- */ + +/* Estimate errors at orders K,K-1,K-2 */ + + enorm = ddwnrm_(neq, &e[1], &vt[1], &rpar[1], &ipar[1]); + erk = sigma[*k + 1] * enorm; + terk = (*k + 1) * erk; + est = erk; + knew = *k; + if (*k == 1) { + goto L430; + } + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L405: */ + delta[i__] = phi[i__ + kp1 * phi_dim1] + e[i__]; + } + erkm1 = sigma[*k] * ddwnrm_(neq, &delta[1], &vt[1], &rpar[1], &ipar[1]); + terkm1 = *k * erkm1; + if (*k > 2) { + goto L410; + } + if (terkm1 <= terk * .5f) { + goto L420; + } + goto L430; +L410: + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L415: */ + delta[i__] = phi[i__ + *k * phi_dim1] + delta[i__]; + } + erkm2 = sigma[*k - 1] * ddwnrm_(neq, &delta[1], &vt[1], &rpar[1], &ipar[1] + ); + terkm2 = (*k - 1) * erkm2; + if (max(terkm1,terkm2) > terk) { + goto L430; + } + +/* Lower the order */ + +L420: + knew = *k - 1; + est = erkm1; + + +/* Calculate the local error for the current step */ +/* to see if the step was successful */ + +L430: + err = ck * enorm; + if (err > 1.) { + goto L600; + } + + + + + +/* ----------------------------------------------------------------------- */ +/* BLOCK 5 */ +/* The step is successful. Determine */ +/* the best order and stepsize for */ +/* the next step. Update the differences */ +/* for the next step. */ +/* ----------------------------------------------------------------------- */ + *idid = 1; + ++iwm[11]; + kdiff = *k - *kold; + *kold = *k; + *hold = *h__; + + +/* Estimate the error at order K+1 unless */ +/* already decided to lower order, or */ +/* already using maximum order, or */ +/* stepsize not constant, or */ +/* order raised in previous step */ + + if (knew == km1 || *k == iwm[3]) { + *iphase = 1; + } + if (*iphase == 0) { + goto L545; + } + if (knew == km1) { + goto L540; + } + if (*k == iwm[3]) { + goto L550; + } + if (kp1 >= *ns || kdiff == 1) { + goto L550; + } + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L510: */ + delta[i__] = e[i__] - phi[i__ + kp2 * phi_dim1]; + } + erkp1 = 1. / (*k + 2) * ddwnrm_(neq, &delta[1], &vt[1], &rpar[1], &ipar[1] + ); + terkp1 = (*k + 2) * erkp1; + if (*k > 1) { + goto L520; + } + if (terkp1 >= terk * .5) { + goto L550; + } + goto L530; +L520: + if (terkm1 <= min(terk,terkp1)) { + goto L540; + } + if (terkp1 >= terk || *k == iwm[3]) { + goto L550; + } + +/* Raise order */ + +L530: + *k = kp1; + est = erkp1; + goto L550; + +/* Lower order */ + +L540: + *k = km1; + est = erkm1; + goto L550; + +/* If IPHASE = 0, increase order by one and multiply stepsize by */ +/* factor two */ + +L545: + *k = kp1; + hnew = *h__ * 2.; + *h__ = hnew; + goto L575; + + +/* Determine the appropriate stepsize for */ +/* the next step. */ + +L550: + hnew = *h__; + temp2 = (doublereal) (*k + 1); + d__1 = est * 2. + 1e-4; + d__2 = -1. / temp2; + r__ = pow_dd(&d__1, &d__2); + if (r__ < 2.) { + goto L555; + } + hnew = *h__ * 2.; + goto L560; +L555: + if (r__ > 1.) { + goto L560; + } +/* Computing MAX */ + d__1 = .5, d__2 = min(.9,r__); + r__ = max(d__1,d__2); + hnew = *h__ * r__; +L560: + *h__ = hnew; + + +/* Update differences for next step */ + +L575: + if (*kold == iwm[3]) { + goto L585; + } + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L580: */ + phi[i__ + kp2 * phi_dim1] = e[i__]; + } +L585: + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L590: */ + phi[i__ + kp1 * phi_dim1] += e[i__]; + } + i__1 = kp1; + for (j1 = 2; j1 <= i__1; ++j1) { + j = kp1 - j1 + 1; + i__2 = *neq; + for (i__ = 1; i__ <= i__2; ++i__) { +/* L595: */ + phi[i__ + j * phi_dim1] += phi[i__ + (j + 1) * phi_dim1]; + } + } + *jstart = 1; + return 0; + + + + + +/* ----------------------------------------------------------------------- */ +/* BLOCK 6 */ +/* The step is unsuccessful. Restore X,PSI,PHI */ +/* Determine appropriate stepsize for */ +/* continuing the integration, or exit with */ +/* an error flag if there have been many */ +/* failures. */ +/* ----------------------------------------------------------------------- */ +L600: + *iphase = 1; + +/* Restore X,PHI,PSI */ + + *x = xold; + if (kp1 < nsp1) { + goto L630; + } + i__2 = kp1; + for (j = nsp1; j <= i__2; ++j) { + temp1 = 1. / beta[j]; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L610: */ + phi[i__ + j * phi_dim1] = temp1 * phi[i__ + j * phi_dim1]; + } +/* L620: */ + } +L630: + i__2 = kp1; + for (i__ = 2; i__ <= i__2; ++i__) { +/* L640: */ + psi[i__ - 1] = psi[i__] - *h__; + } + + +/* Test whether failure is due to nonlinear solver */ +/* or error test */ + + if (iernls == 0) { + goto L660; + } + ++iwm[15]; + + +/* The nonlinear solver failed to converge. */ +/* Determine the cause of the failure and take appropriate action. */ +/* If IERNLS .LT. 0, then return. Otherwise, reduce the stepsize */ +/* and try again, unless too many failures have occurred. */ + + if (iernls < 0) { + goto L675; + } + ++ncf; + r__ = .25; + *h__ *= r__; + if (ncf < 10 && abs(*h__) >= *hmin) { + goto L690; + } + if (*idid == 1) { + *idid = -7; + } + if (nef >= 3) { + *idid = -9; + } + goto L675; + + +/* The nonlinear solver converged, and the cause */ +/* of the failure was the error estimate */ +/* exceeding the tolerance. */ + +L660: + ++nef; + ++iwm[14]; + if (nef > 1) { + goto L665; + } + +/* On first error test failure, keep current order or lower */ +/* order by one. Compute new stepsize based on differences */ +/* of the solution. */ + + *k = knew; + temp2 = (doublereal) (*k + 1); + d__1 = est * 2. + 1e-4; + d__2 = -1. / temp2; + r__ = pow_dd(&d__1, &d__2) * .9; +/* Computing MAX */ + d__1 = .25, d__2 = min(.9,r__); + r__ = max(d__1,d__2); + *h__ *= r__; + if (abs(*h__) >= *hmin) { + goto L690; + } + *idid = -6; + goto L675; + +/* On second error test failure, use the current order or */ +/* decrease order by one. Reduce the stepsize by a factor of */ +/* one quarter. */ + +L665: + if (nef > 2) { + goto L670; + } + *k = knew; + r__ = .25; + *h__ = r__ * *h__; + if (abs(*h__) >= *hmin) { + goto L690; + } + *idid = -6; + goto L675; + +/* On third and subsequent error test failures, set the order to */ +/* one, and reduce the stepsize by a factor of one quarter. */ + +L670: + *k = 1; + r__ = .25; + *h__ = r__ * *h__; + if (abs(*h__) >= *hmin) { + goto L690; + } + *idid = -6; + goto L675; + + + + +/* For all crashes, restore Y to its last value, */ +/* interpolate to find YPRIME at last X, and return. */ + +/* Before returning, verify that the user has not set */ +/* IDID to a nonnegative value. If the user has set IDID */ +/* to a nonnegative value, then reset IDID to be -7, indicating */ +/* a failure in the nonlinear system solver. */ + +L675: + ddatrp_(x, x, &y[1], &yprime[1], neq, k, &phi[phi_offset], &psi[1]); + *jstart = 1; + if (*idid >= 0) { + *idid = -7; + } + return 0; + + +/* Go back and try this step again. */ +/* If this is the first step, reset PSI(1) and rescale PHI(*,2). */ + +L690: + if (*kold == 0) { + psi[1] = *h__; + i__2 = *neq; + for (i__ = 1; i__ <= i__2; ++i__) { +/* L695: */ + phi[i__ + (phi_dim1 << 1)] = r__ * phi[i__ + (phi_dim1 << 1)]; + } + } + goto L200; + +/* ------END OF SUBROUTINE DDSTP------------------------------------------ */ +} /* ddstp_ */ + +/* Subroutine */ int dcnstr_(integer *neq, doublereal *y, doublereal *ynew, + integer *icnstr, doublereal *tau, doublereal *rlx, integer *iret, + integer *ivar) +{ + /* Initialized data */ + + static doublereal fac = .6; + static doublereal fac2 = .9; + static doublereal zero = 0.; + + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Local variables */ + static integer i__; + static doublereal rdy, rdymx; + + +/* ***BEGIN PROLOGUE DCNSTR */ +/* ***DATE WRITTEN 950808 (YYMMDD) */ +/* ***REVISION DATE 950814 (YYMMDD) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* This subroutine checks for constraint violations in the proposed */ +/* new approximate solution YNEW. */ +/* If a constraint violation occurs, then a new step length, TAU, */ +/* is calculated, and this value is to be given to the linesearch routine */ +/* to calculate a new approximate solution YNEW. */ + +/* On entry: */ + +/* NEQ -- size of the nonlinear system, and the length of arrays */ +/* Y, YNEW and ICNSTR. */ + +/* Y -- real array containing the current approximate y. */ + +/* YNEW -- real array containing the new approximate y. */ + +/* ICNSTR -- INTEGER array of length NEQ containing flags indicating */ +/* which entries in YNEW are to be constrained. */ +/* if ICNSTR(I) = 2, then YNEW(I) must be .GT. 0, */ +/* if ICNSTR(I) = 1, then YNEW(I) must be .GE. 0, */ +/* if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while */ +/* if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while */ +/* if ICNSTR(I) = 0, then YNEW(I) is not constrained. */ + +/* RLX -- real scalar restricting update, if ICNSTR(I) = 2 or -2, */ +/* to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I. */ + +/* TAU -- the current size of the step length for the linesearch. */ + +/* On return */ + +/* TAU -- the adjusted size of the step length if a constraint */ +/* violation occurred (otherwise, it is unchanged). it is */ +/* the step length to give to the linesearch routine. */ + +/* IRET -- output flag. */ +/* IRET=0 means that YNEW satisfied all constraints. */ +/* IRET=1 means that YNEW failed to satisfy all the */ +/* constraints, and a new linesearch step */ +/* must be computed. */ + +/* IVAR -- index of variable causing constraint to be violated. */ + +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --icnstr; + --ynew; + --y; + + /* Function Body */ +/* ----------------------------------------------------------------------- */ +/* Check constraints for proposed new step YNEW. If a constraint has */ +/* been violated, then calculate a new step length, TAU, to be */ +/* used in the linesearch routine. */ +/* ----------------------------------------------------------------------- */ + *iret = 0; + rdymx = zero; + *ivar = 0; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (icnstr[i__] == 2) { + rdy = (d__1 = (ynew[i__] - y[i__]) / y[i__], abs(d__1)); + if (rdy > rdymx) { + rdymx = rdy; + *ivar = i__; + } + if (ynew[i__] <= zero) { + *tau = fac * *tau; + *ivar = i__; + *iret = 1; + return 0; + } + + } else if (icnstr[i__] == 1) { + if (ynew[i__] < zero) { + *tau = fac * *tau; + *ivar = i__; + *iret = 1; + return 0; + } + + } else if (icnstr[i__] == -1) { + if (ynew[i__] > zero) { + *tau = fac * *tau; + *ivar = i__; + *iret = 1; + return 0; + } + + } else if (icnstr[i__] == -2) { + rdy = (d__1 = (ynew[i__] - y[i__]) / y[i__], abs(d__1)); + if (rdy > rdymx) { + rdymx = rdy; + *ivar = i__; + } + if (ynew[i__] >= zero) { + *tau = fac * *tau; + *ivar = i__; + *iret = 1; + return 0; + } + + } +/* L100: */ + } + if (rdymx >= *rlx) { + *tau = fac2 * *tau * *rlx / rdymx; + *iret = 1; + } + + return 0; +/* ----------------------- END OF SUBROUTINE DCNSTR ---------------------- */ +} /* dcnstr_ */ + +/* Subroutine */ int dcnst0_(integer *neq, doublereal *y, integer *icnstr, + integer *iret) +{ + /* Initialized data */ + + static doublereal zero = 0.; + + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__; + + +/* ***BEGIN PROLOGUE DCNST0 */ +/* ***DATE WRITTEN 950808 (YYMMDD) */ +/* ***REVISION DATE 950808 (YYMMDD) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* This subroutine checks for constraint violations in the initial */ +/* approximate solution u. */ + +/* On entry */ + +/* NEQ -- size of the nonlinear system, and the length of arrays */ +/* Y and ICNSTR. */ + +/* Y -- real array containing the initial approximate root. */ + +/* ICNSTR -- INTEGER array of length NEQ containing flags indicating */ +/* which entries in Y are to be constrained. */ +/* if ICNSTR(I) = 2, then Y(I) must be .GT. 0, */ +/* if ICNSTR(I) = 1, then Y(I) must be .GE. 0, */ +/* if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while */ +/* if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while */ +/* if ICNSTR(I) = 0, then Y(I) is not constrained. */ + +/* On return */ + +/* IRET -- output flag. */ +/* IRET=0 means that u satisfied all constraints. */ +/* IRET.NE.0 means that Y(IRET) failed to satisfy its */ +/* constraint. */ + +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --icnstr; + --y; + + /* Function Body */ +/* ----------------------------------------------------------------------- */ +/* Check constraints for initial Y. If a constraint has been violated, */ +/* set IRET = I to signal an error return to calling routine. */ +/* ----------------------------------------------------------------------- */ + *iret = 0; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + if (icnstr[i__] == 2) { + if (y[i__] <= zero) { + *iret = i__; + return 0; + } + } else if (icnstr[i__] == 1) { + if (y[i__] < zero) { + *iret = i__; + return 0; + } + } else if (icnstr[i__] == -1) { + if (y[i__] > zero) { + *iret = i__; + return 0; + } + } else if (icnstr[i__] == -2) { + if (y[i__] >= zero) { + *iret = i__; + return 0; + } + } +/* L100: */ + } + return 0; +/* ----------------------- END OF SUBROUTINE DCNST0 ---------------------- */ +} /* dcnst0_ */ + +/* Subroutine */ int ddawts_(integer *neq, integer *iwt, doublereal *rtol, + doublereal *atol, doublereal *y, doublereal *wt, doublereal *rpar, + integer *ipar) +{ + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Local variables */ + static integer i__; + static doublereal atoli, rtoli; + + +/* ***BEGIN PROLOGUE DDAWTS */ +/* ***REFER TO DDASPK */ +/* ***ROUTINES CALLED (NONE) */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***END PROLOGUE DDAWTS */ +/* ----------------------------------------------------------------------- */ +/* This subroutine sets the error weight vector, */ +/* WT, according to WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), */ +/* I = 1 to NEQ. */ +/* RTOL and ATOL are scalars if IWT = 0, */ +/* and vectors if IWT = 1. */ +/* ----------------------------------------------------------------------- */ + + /* Parameter adjustments */ + --ipar; + --rpar; + --wt; + --y; + --atol; + --rtol; + + /* Function Body */ + rtoli = rtol[1]; + atoli = atol[1]; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*iwt == 0) { + goto L10; + } + rtoli = rtol[i__]; + atoli = atol[i__]; +L10: + wt[i__] = rtoli * (d__1 = y[i__], abs(d__1)) + atoli; +/* L20: */ + } + return 0; + +/* ------END OF SUBROUTINE DDAWTS----------------------------------------- */ +} /* ddawts_ */ + +/* Subroutine */ int dinvwt_(integer *neq, doublereal *wt, integer *ier) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__; + + +/* ***BEGIN PROLOGUE DINVWT */ +/* ***REFER TO DDASPK */ +/* ***ROUTINES CALLED (NONE) */ +/* ***DATE WRITTEN 950125 (YYMMDD) */ +/* ***END PROLOGUE DINVWT */ +/* ----------------------------------------------------------------------- */ +/* This subroutine checks the error weight vector WT, of length NEQ, */ +/* for components that are .le. 0, and if none are found, it */ +/* inverts the WT(I) in place. This replaces division operations */ +/* with multiplications in all norm evaluations. */ +/* IER is returned as 0 if all WT(I) were found positive, */ +/* and the first I with WT(I) .le. 0.0 otherwise. */ +/* ----------------------------------------------------------------------- */ + + + /* Parameter adjustments */ + --wt; + + /* Function Body */ + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + if (wt[i__] <= 0.) { + goto L30; + } +/* L10: */ + } + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L20: */ + wt[i__] = 1. / wt[i__]; + } + *ier = 0; + return 0; + +L30: + *ier = i__; + return 0; + +/* ------END OF SUBROUTINE DINVWT----------------------------------------- */ +} /* dinvwt_ */ + +/* Subroutine */ int ddatrp_(doublereal *x, doublereal *xout, doublereal * + yout, doublereal *ypout, integer *neq, integer *kold, doublereal *phi, + doublereal *psi) +{ + /* System generated locals */ + integer phi_dim1, phi_offset, i__1, i__2; + + /* Local variables */ + static doublereal c__, d__; + static integer i__, j; + static doublereal temp1, gamma; + static integer koldp1; + + +/* ***BEGIN PROLOGUE DDATRP */ +/* ***REFER TO DDASPK */ +/* ***ROUTINES CALLED (NONE) */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***END PROLOGUE DDATRP */ + +/* ----------------------------------------------------------------------- */ +/* The methods in subroutine DDSTP use polynomials */ +/* to approximate the solution. DDATRP approximates the */ +/* solution and its derivative at time XOUT by evaluating */ +/* one of these polynomials, and its derivative, there. */ +/* Information defining this polynomial is passed from */ +/* DDSTP, so DDATRP cannot be used alone. */ + +/* The parameters are */ + +/* X The current time in the integration. */ +/* XOUT The time at which the solution is desired. */ +/* YOUT The interpolated approximation to Y at XOUT. */ +/* (This is output.) */ +/* YPOUT The interpolated approximation to YPRIME at XOUT. */ +/* (This is output.) */ +/* NEQ Number of equations. */ +/* KOLD Order used on last successful step. */ +/* PHI Array of scaled divided differences of Y. */ +/* PSI Array of past stepsize history. */ +/* ----------------------------------------------------------------------- */ + + /* Parameter adjustments */ + --yout; + --ypout; + phi_dim1 = *neq; + phi_offset = 1 + phi_dim1; + phi -= phi_offset; + --psi; + + /* Function Body */ + koldp1 = *kold + 1; + temp1 = *xout - *x; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + yout[i__] = phi[i__ + phi_dim1]; +/* L10: */ + ypout[i__] = 0.; + } + c__ = 1.; + d__ = 0.; + gamma = temp1 / psi[1]; + i__1 = koldp1; + for (j = 2; j <= i__1; ++j) { + d__ = d__ * gamma + c__ / psi[j - 1]; + c__ *= gamma; + gamma = (temp1 + psi[j - 1]) / psi[j]; + i__2 = *neq; + for (i__ = 1; i__ <= i__2; ++i__) { + yout[i__] += c__ * phi[i__ + j * phi_dim1]; +/* L20: */ + ypout[i__] += d__ * phi[i__ + j * phi_dim1]; + } +/* L30: */ + } + return 0; + +/* ------END OF SUBROUTINE DDATRP----------------------------------------- */ +} /* ddatrp_ */ + +doublereal ddwnrm_(integer *neq, doublereal *v, doublereal *rwt, doublereal * + rpar, integer *ipar) +{ + /* System generated locals */ + integer i__1; + doublereal ret_val, d__1, d__2; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static integer i__; + static doublereal sum, vmax; + + +/* ***BEGIN PROLOGUE DDWNRM */ +/* ***ROUTINES CALLED (NONE) */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***END PROLOGUE DDWNRM */ +/* ----------------------------------------------------------------------- */ +/* This function routine computes the weighted */ +/* root-mean-square norm of the vector of length */ +/* NEQ contained in the array V, with reciprocal weights */ +/* contained in the array RWT of length NEQ. */ +/* DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2) */ +/* ----------------------------------------------------------------------- */ + + /* Parameter adjustments */ + --ipar; + --rpar; + --rwt; + --v; + + /* Function Body */ + ret_val = 0.; + vmax = 0.; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = v[i__] * rwt[i__], abs(d__1)) > vmax) { + vmax = (d__2 = v[i__] * rwt[i__], abs(d__2)); + } +/* L10: */ + } + if (vmax <= 0.) { + goto L30; + } + sum = 0.; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L20: */ +/* Computing 2nd power */ + d__1 = v[i__] * rwt[i__] / vmax; + sum += d__1 * d__1; + } + ret_val = vmax * sqrt(sum / *neq); +L30: + return ret_val; + +/* ------END OF FUNCTION DDWNRM------------------------------------------- */ +} /* ddwnrm_ */ + +/* Subroutine */ int ddasid_(doublereal *x, doublereal *y, doublereal *yprime, + integer *neq, integer *icopt, integer *id, S_fp res, U_fp jacd, + doublereal *pdum, doublereal *h__, doublereal *tscale, doublereal *wt, + integer *jsdum, doublereal *rpar, integer *ipar, doublereal *dumsvr, + doublereal *delta, doublereal *r__, doublereal *yic, doublereal *ypic, + doublereal *dumpwk, doublereal *wm, integer *iwm, doublereal *cj, + doublereal *uround, doublereal *dume, doublereal *dums, doublereal * + dumr, doublereal *epcon, doublereal *ratemx, doublereal *stptol, + integer *jfdum, integer *icnflg, integer *icnstr, integer *iernls) +{ + static integer nj, ierj, ires, mxnj; + extern /* Subroutine */ int dmatd_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *, S_fp, + integer *, doublereal *, U_fp, doublereal *, integer *), dnsid_( + doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, S_fp, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, integer *, + integer *); + static integer mxnit, iernew; + + +/* ***BEGIN PROLOGUE DDASID */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 940701 (YYMMDD) */ +/* ***REVISION DATE 950808 (YYMMDD) */ +/* ***REVISION DATE 951110 Removed unreachable block 390. */ +/* ***REVISION DATE 000628 TSCALE argument added. */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + + +/* DDASID solves a nonlinear system of algebraic equations of the */ +/* form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in */ +/* the initial conditions. */ + +/* The method used is a modified Newton scheme. */ + +/* The parameters represent */ + +/* X -- Independent variable. */ +/* Y -- Solution vector. */ +/* YPRIME -- Derivative of solution vector. */ +/* NEQ -- Number of unknowns. */ +/* ICOPT -- Initial condition option chosen (1 or 2). */ +/* ID -- Array of dimension NEQ, which must be initialized */ +/* if ICOPT = 1. See DDASIC. */ +/* RES -- External user-supplied subroutine to evaluate the */ +/* residual. See RES description in DDASPK prologue. */ +/* JACD -- External user-supplied routine to evaluate the */ +/* Jacobian. See JAC description for the case */ +/* INFO(12) = 0 in the DDASPK prologue. */ +/* PDUM -- Dummy argument. */ +/* H -- Scaling factor for this initial condition calc. */ +/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ +/* WT -- Vector of weights for error criterion. */ +/* JSDUM -- Dummy argument. */ +/* RPAR,IPAR -- Real and integer arrays used for communication */ +/* between the calling program and external user */ +/* routines. They are not altered within DASPK. */ +/* DUMSVR -- Dummy argument. */ +/* DELTA -- Work vector for NLS of length NEQ. */ +/* R -- Work vector for NLS of length NEQ. */ +/* YIC,YPIC -- Work vectors for NLS, each of length NEQ. */ +/* DUMPWK -- Dummy argument. */ +/* WM,IWM -- Real and integer arrays storing matrix information */ +/* such as the matrix of partial derivatives, */ +/* permutation vector, and various other information. */ +/* CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */ +/* UROUND -- Unit roundoff. */ +/* DUME -- Dummy argument. */ +/* DUMS -- Dummy argument. */ +/* DUMR -- Dummy argument. */ +/* EPCON -- Tolerance to test for convergence of the Newton */ +/* iteration. */ +/* RATEMX -- Maximum convergence rate for which Newton iteration */ +/* is considered converging. */ +/* JFDUM -- Dummy argument. */ +/* STPTOL -- Tolerance used in calculating the minimum lambda */ +/* value allowed. */ +/* ICNFLG -- Integer scalar. If nonzero, then constraint */ +/* violations in the proposed new approximate solution */ +/* will be checked for, and the maximum step length */ +/* will be adjusted accordingly. */ +/* ICNSTR -- Integer array of length NEQ containing flags for */ +/* checking constraints. */ +/* IERNLS -- Error flag for nonlinear solver. */ +/* 0 ==> nonlinear solver converged. */ +/* 1,2 ==> recoverable error inside nonlinear solver. */ +/* 1 => retry with current Y, YPRIME */ +/* 2 => retry with original Y, YPRIME */ +/* -1 ==> unrecoverable error in nonlinear solver. */ + +/* All variables with "DUM" in their names are dummy variables */ +/* which are not used in this routine. */ + +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED */ +/* RES, DMATD, DNSID */ + +/* ***END PROLOGUE DDASID */ + + + + + +/* Perform initializations. */ + + /* Parameter adjustments */ + --icnstr; + --iwm; + --wm; + --ypic; + --yic; + --r__; + --delta; + --ipar; + --rpar; + --wt; + --id; + --yprime; + --y; + + /* Function Body */ + mxnit = iwm[32]; + mxnj = iwm[33]; + *iernls = 0; + nj = 0; + +/* Call RES to initialize DELTA. */ + + ires = 0; + ++iwm[12]; + (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]); + if (ires < 0) { + goto L370; + } + +/* Looping point for updating the Jacobian. */ + +L300: + +/* Initialize all error flags to zero. */ + + ierj = 0; + ires = 0; + iernew = 0; + +/* Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME, */ +/* where G(X,Y,YPRIME) = 0. */ + + ++nj; + ++iwm[13]; + dmatd_(neq, x, &y[1], &yprime[1], &delta[1], cj, h__, &ierj, &wt[1], &r__[ + 1], &wm[1], &iwm[1], (S_fp)res, &ires, uround, (U_fp)jacd, &rpar[ + 1], &ipar[1]); + if (ires < 0 || ierj != 0) { + goto L370; + } + +/* Call the nonlinear Newton solver for up to MXNIT iterations. */ + + dnsid_(x, &y[1], &yprime[1], neq, icopt, &id[1], (S_fp)res, &wt[1], &rpar[ + 1], &ipar[1], &delta[1], &r__[1], &yic[1], &ypic[1], &wm[1], &iwm[ + 1], cj, tscale, epcon, ratemx, &mxnit, stptol, icnflg, &icnstr[1], + &iernew); + + if (iernew == 1 && nj < mxnj) { + +/* MXNIT iterations were done, the convergence rate is < 1, */ +/* and the number of Jacobian evaluations is less than MXNJ. */ +/* Call RES, reevaluate the Jacobian, and try again. */ + + ++iwm[12]; + (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]) + ; + if (ires < 0) { + goto L370; + } + goto L300; + } + + if (iernew != 0) { + goto L380; + } + return 0; + + +/* Unsuccessful exits from nonlinear solver. */ +/* Compute IERNLS accordingly. */ + +L370: + *iernls = 2; + if (ires <= -2) { + *iernls = -1; + } + return 0; + +L380: + *iernls = min(iernew,2); + return 0; + +/* ------END OF SUBROUTINE DDASID----------------------------------------- */ +} /* ddasid_ */ + +/* Subroutine */ int dnsid_(doublereal *x, doublereal *y, doublereal *yprime, + integer *neq, integer *icopt, integer *id, S_fp res, doublereal *wt, + doublereal *rpar, integer *ipar, doublereal *delta, doublereal *r__, + doublereal *yic, doublereal *ypic, doublereal *wm, integer *iwm, + doublereal *cj, doublereal *tscale, doublereal *epcon, doublereal * + ratemx, integer *maxit, doublereal *stptol, integer *icnflg, integer * + icnstr, integer *iernew) +{ + static integer m; + static doublereal rlx, rate, fnrm; + static integer iret, ires, lsoff; + extern /* Subroutine */ int dslvd_(integer *, doublereal *, doublereal *, + integer *), dcopy_(integer *, doublereal *, integer *, doublereal + *, integer *), dlinsd_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + S_fp, integer *, doublereal *, integer *, doublereal *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + integer *, doublereal *, doublereal *, integer *); + static doublereal oldfnm, delnrm; + extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + + +/* ***BEGIN PROLOGUE DNSID */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 940701 (YYMMDD) */ +/* ***REVISION DATE 950713 (YYMMDD) */ +/* ***REVISION DATE 000628 TSCALE argument added. */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DNSID solves a nonlinear system of algebraic equations of the */ +/* form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME */ +/* in the initial conditions. */ + +/* The method used is a modified Newton scheme. */ + +/* The parameters represent */ + +/* X -- Independent variable. */ +/* Y -- Solution vector. */ +/* YPRIME -- Derivative of solution vector. */ +/* NEQ -- Number of unknowns. */ +/* ICOPT -- Initial condition option chosen (1 or 2). */ +/* ID -- Array of dimension NEQ, which must be initialized */ +/* if ICOPT = 1. See DDASIC. */ +/* RES -- External user-supplied subroutine to evaluate the */ +/* residual. See RES description in DDASPK prologue. */ +/* WT -- Vector of weights for error criterion. */ +/* RPAR,IPAR -- Real and integer arrays used for communication */ +/* between the calling program and external user */ +/* routines. They are not altered within DASPK. */ +/* DELTA -- Residual vector on entry, and work vector of */ +/* length NEQ for DNSID. */ +/* WM,IWM -- Real and integer arrays storing matrix information */ +/* such as the matrix of partial derivatives, */ +/* permutation vector, and various other information. */ +/* CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */ +/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ +/* R -- Array of length NEQ used as workspace by the */ +/* linesearch routine DLINSD. */ +/* YIC,YPIC -- Work vectors for DLINSD, each of length NEQ. */ +/* EPCON -- Tolerance to test for convergence of the Newton */ +/* iteration. */ +/* RATEMX -- Maximum convergence rate for which Newton iteration */ +/* is considered converging. */ +/* MAXIT -- Maximum allowed number of Newton iterations. */ +/* STPTOL -- Tolerance used in calculating the minimum lambda */ +/* value allowed. */ +/* ICNFLG -- Integer scalar. If nonzero, then constraint */ +/* violations in the proposed new approximate solution */ +/* will be checked for, and the maximum step length */ +/* will be adjusted accordingly. */ +/* ICNSTR -- Integer array of length NEQ containing flags for */ +/* checking constraints. */ +/* IERNEW -- Error flag for Newton iteration. */ +/* 0 ==> Newton iteration converged. */ +/* 1 ==> failed to converge, but RATE .le. RATEMX. */ +/* 2 ==> failed to converge, RATE .gt. RATEMX. */ +/* 3 ==> other recoverable error (IRES = -1, or */ +/* linesearch failed). */ +/* -1 ==> unrecoverable error (IRES = -2). */ + +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED */ +/* DSLVD, DDWNRM, DLINSD, DCOPY */ + +/* ***END PROLOGUE DNSID */ + + + + + +/* Initializations. M is the Newton iteration counter. */ + + /* Parameter adjustments */ + --icnstr; + --iwm; + --wm; + --ypic; + --yic; + --r__; + --delta; + --ipar; + --rpar; + --wt; + --id; + --yprime; + --y; + + /* Function Body */ + lsoff = iwm[35]; + m = 0; + rate = 1.; + rlx = .4; + +/* Compute a new step vector DELTA by back-substitution. */ + + dslvd_(neq, &delta[1], &wm[1], &iwm[1]); + +/* Get norm of DELTA. Return now if norm(DELTA) .le. EPCON. */ + + delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); + fnrm = delnrm; + if (*tscale > 0.) { + fnrm = fnrm * *tscale * abs(*cj); + } + if (fnrm <= *epcon) { + return 0; + } + +/* Newton iteration loop. */ + +L300: + ++iwm[19]; + +/* Call linesearch routine for global strategy and set RATE */ + + oldfnm = fnrm; + + dlinsd_(neq, &y[1], x, &yprime[1], cj, tscale, &delta[1], &delnrm, &wt[1], + &lsoff, stptol, &iret, (S_fp)res, &ires, &wm[1], &iwm[1], &fnrm, + icopt, &id[1], &r__[1], &yic[1], &ypic[1], icnflg, &icnstr[1], & + rlx, &rpar[1], &ipar[1]); + + rate = fnrm / oldfnm; + +/* Check for error condition from linesearch. */ + if (iret != 0) { + goto L390; + } + +/* Test for convergence of the iteration, and return or loop. */ + + if (fnrm <= *epcon) { + return 0; + } + +/* The iteration has not yet converged. Update M. */ +/* Test whether the maximum number of iterations have been tried. */ + + ++m; + if (m >= *maxit) { + goto L380; + } + +/* Copy the residual to DELTA and its norm to DELNRM, and loop for */ +/* another iteration. */ + + dcopy_(neq, &r__[1], &c__1, &delta[1], &c__1); + delnrm = fnrm; + goto L300; + +/* The maximum number of iterations was done. Set IERNEW and return. */ + +L380: + if (rate <= *ratemx) { + *iernew = 1; + } else { + *iernew = 2; + } + return 0; + +L390: + if (ires <= -2) { + *iernew = -1; + } else { + *iernew = 3; + } + return 0; + + +/* ------END OF SUBROUTINE DNSID------------------------------------------ */ +} /* dnsid_ */ + +/* Subroutine */ int dlinsd_(integer *neq, doublereal *y, doublereal *t, + doublereal *yprime, doublereal *cj, doublereal *tscale, doublereal *p, + doublereal *pnrm, doublereal *wt, integer *lsoff, doublereal *stptol, + integer *iret, S_fp res, integer *ires, doublereal *wm, integer *iwm, + doublereal *fnrm, integer *icopt, integer *id, doublereal *r__, + doublereal *ynew, doublereal *ypnew, integer *icnflg, integer *icnstr, + doublereal *rlx, doublereal *rpar, integer *ipar) +{ + /* Initialized data */ + + static doublereal alpha = 1e-4; + static doublereal one = 1.; + static doublereal two = 2.; + + /* System generated locals */ + integer i__1; + + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + + /* Local variables */ + static integer i__; + static doublereal rl; + static char msg[80]; + static doublereal tau; + static integer ivar; + static doublereal slpi, f1nrm, ratio; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + static doublereal rlmin, fnrmp; + static integer kprin; + static doublereal ratio1, f1nrmp; + extern /* Subroutine */ int dfnrmd_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, S_fp, integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *), dcnstr_(integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *, integer *), xerrwd_(char *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, doublereal + *, doublereal *, ftnlen), dyypnw_(integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *, doublereal *, doublereal *); + + +/* ***BEGIN PROLOGUE DLINSD */ +/* ***REFER TO DNSID */ +/* ***DATE WRITTEN 941025 (YYMMDD) */ +/* ***REVISION DATE 941215 (YYMMDD) */ +/* ***REVISION DATE 960129 Moved line RL = ONE to top block. */ +/* ***REVISION DATE 000628 TSCALE argument added. */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME) */ +/* pair (YNEW,YPNEW) such that */ + +/* f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) , */ + +/* where 0 < RL <= 1. Here, f(y,y') is defined as */ + +/* f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 , */ + +/* where norm() is the weighted RMS vector norm, G is the DAE */ +/* system residual function, and J is the system iteration matrix */ +/* (Jacobian). */ + +/* In addition to the parameters defined elsewhere, we have */ + +/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ +/* P -- Approximate Newton step used in backtracking. */ +/* PNRM -- Weighted RMS norm of P. */ +/* LSOFF -- Flag showing whether the linesearch algorithm is */ +/* to be invoked. 0 means do the linesearch, and */ +/* 1 means turn off linesearch. */ +/* STPTOL -- Tolerance used in calculating the minimum lambda */ +/* value allowed. */ +/* ICNFLG -- Integer scalar. If nonzero, then constraint violations */ +/* in the proposed new approximate solution will be */ +/* checked for, and the maximum step length will be */ +/* adjusted accordingly. */ +/* ICNSTR -- Integer array of length NEQ containing flags for */ +/* checking constraints. */ +/* RLX -- Real scalar restricting update size in DCNSTR. */ +/* YNEW -- Array of length NEQ used to hold the new Y in */ +/* performing the linesearch. */ +/* YPNEW -- Array of length NEQ used to hold the new YPRIME in */ +/* performing the linesearch. */ +/* Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). */ +/* YPRIME -- Array of length NEQ containing the new YPRIME */ +/* (i.e.,=YPNEW). */ +/* FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the */ +/* current (Y,YPRIME) on input and output. */ +/* R -- Work array of length NEQ, containing the scaled */ +/* residual (J-inverse)*G(t,y,y') on return. */ +/* IRET -- Return flag. */ +/* IRET=0 means that a satisfactory (Y,YPRIME) was found. */ +/* IRET=1 means that the routine failed to find a new */ +/* (Y,YPRIME) that was sufficiently distinct from */ +/* the current (Y,YPRIME) pair. */ +/* IRET=2 means IRES .ne. 0 from RES. */ +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED */ +/* DFNRMD, DYYPNW, DCNSTR, DCOPY, XERRWD */ + +/* ***END PROLOGUE DLINSD */ + + + + /* Parameter adjustments */ + --ipar; + --rpar; + --icnstr; + --ypnew; + --ynew; + --r__; + --id; + --iwm; + --wm; + --wt; + --p; + --yprime; + --y; + + /* Function Body */ + + kprin = iwm[31]; + + f1nrm = *fnrm * *fnrm / two; + ratio = one; + if (kprin >= 2) { + s_copy(msg, "------ IN ROUTINE DLINSD-- PNRM = (R1)", (ftnlen)80, ( + ftnlen)38); + xerrwd_(msg, &c__38, &c__901, &c__0, &c__0, &c__0, &c__0, &c__1, pnrm, + &c_b37, (ftnlen)80); + } + tau = *pnrm; + rl = one; +/* ----------------------------------------------------------------------- */ +/* Check for violations of the constraints, if any are imposed. */ +/* If any violations are found, the step vector P is rescaled, and the */ +/* constraint check is repeated, until no violations are found. */ +/* ----------------------------------------------------------------------- */ + if (*icnflg != 0) { +L10: + dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[ + 1], &ypnew[1]); + dcnstr_(neq, &y[1], &ynew[1], &icnstr[1], &tau, rlx, iret, &ivar); + if (*iret == 1) { + ratio1 = tau / *pnrm; + ratio *= ratio1; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L20: */ + p[i__] *= ratio1; + } + *pnrm = tau; + if (kprin >= 2) { + s_copy(msg, "------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (" + "I1)", (ftnlen)80, (ftnlen)50); + xerrwd_(msg, &c__50, &c__902, &c__0, &c__1, &ivar, &c__0, & + c__1, pnrm, &c_b37, (ftnlen)80); + } + if (*pnrm <= *stptol) { + *iret = 1; + return 0; + } + goto L10; + } + } + + slpi = -two * f1nrm * ratio; + rlmin = *stptol / *pnrm; + if (*lsoff == 0 && kprin >= 2) { + s_copy(msg, "------ MIN. LAMBDA = (R1)", (ftnlen)80, (ftnlen)25); + xerrwd_(msg, &c__25, &c__903, &c__0, &c__0, &c__0, &c__0, &c__1, & + rlmin, &c_b37, (ftnlen)80); + } +/* ----------------------------------------------------------------------- */ +/* Begin iteration to find RL value satisfying alpha-condition. */ +/* If RL becomes less than RLMIN, then terminate with IRET = 1. */ +/* ----------------------------------------------------------------------- */ +L100: + dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[1], & + ypnew[1]); + dfnrmd_(neq, &ynew[1], t, &ypnew[1], &r__[1], cj, tscale, &wt[1], (S_fp) + res, ires, &fnrmp, &wm[1], &iwm[1], &rpar[1], &ipar[1]); + ++iwm[12]; + if (*ires != 0) { + *iret = 2; + return 0; + } + if (*lsoff == 1) { + goto L150; + } + + f1nrmp = fnrmp * fnrmp / two; + if (kprin >= 2) { + s_copy(msg, "------ LAMBDA = (R1)", (ftnlen)80, (ftnlen)20); + xerrwd_(msg, &c__20, &c__904, &c__0, &c__0, &c__0, &c__0, &c__1, &rl, + &c_b37, (ftnlen)80); + s_copy(msg, "------ NORM(F1) = (R1), NORM(F1NEW) = (R2)", (ftnlen)80, + (ftnlen)43); + xerrwd_(msg, &c__43, &c__905, &c__0, &c__0, &c__0, &c__0, &c__2, & + f1nrm, &f1nrmp, (ftnlen)80); + } + if (f1nrmp > f1nrm + alpha * slpi * rl) { + goto L200; + } +/* ----------------------------------------------------------------------- */ +/* Alpha-condition is satisfied, or linesearch is turned off. */ +/* Copy YNEW,YPNEW to Y,YPRIME and return. */ +/* ----------------------------------------------------------------------- */ +L150: + *iret = 0; + dcopy_(neq, &ynew[1], &c__1, &y[1], &c__1); + dcopy_(neq, &ypnew[1], &c__1, &yprime[1], &c__1); + *fnrm = fnrmp; + if (kprin >= 1) { + s_copy(msg, "------ LEAVING ROUTINE DLINSD, FNRM = (R1)", (ftnlen)80, + (ftnlen)42); + xerrwd_(msg, &c__42, &c__906, &c__0, &c__0, &c__0, &c__0, &c__1, fnrm, + &c_b37, (ftnlen)80); + } + return 0; +/* ----------------------------------------------------------------------- */ +/* Alpha-condition not satisfied. Perform backtrack to compute new RL */ +/* value. If no satisfactory YNEW,YPNEW can be found sufficiently */ +/* distinct from Y,YPRIME, then return IRET = 1. */ +/* ----------------------------------------------------------------------- */ +L200: + if (rl < rlmin) { + *iret = 1; + return 0; + } + + rl /= two; + goto L100; + +/* ----------------------- END OF SUBROUTINE DLINSD ---------------------- */ +} /* dlinsd_ */ + +/* Subroutine */ int dfnrmd_(integer *neq, doublereal *y, doublereal *t, + doublereal *yprime, doublereal *r__, doublereal *cj, doublereal * + tscale, doublereal *wt, S_fp res, integer *ires, doublereal *fnorm, + doublereal *wm, integer *iwm, doublereal *rpar, integer *ipar) +{ + extern /* Subroutine */ int dslvd_(integer *, doublereal *, doublereal *, + integer *); + extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + + +/* ***BEGIN PROLOGUE DFNRMD */ +/* ***REFER TO DLINSD */ +/* ***DATE WRITTEN 941025 (YYMMDD) */ +/* ***REVISION DATE 000628 TSCALE argument added. */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DFNRMD calculates the scaled preconditioned norm of the nonlinear */ +/* function used in the nonlinear iteration for obtaining consistent */ +/* initial conditions. Specifically, DFNRMD calculates the weighted */ +/* root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME), */ +/* where J is the Jacobian matrix. */ + +/* In addition to the parameters described in the calling program */ +/* DLINSD, the parameters represent */ + +/* R -- Array of length NEQ that contains */ +/* (J-inverse)*G(T,Y,YPRIME) on return. */ +/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ +/* FNORM -- Scalar containing the weighted norm of R on return. */ +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED */ +/* RES, DSLVD, DDWNRM */ + +/* ***END PROLOGUE DFNRMD */ + + +/* ----------------------------------------------------------------------- */ +/* Call RES routine. */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ipar; + --rpar; + --iwm; + --wm; + --wt; + --r__; + --yprime; + --y; + + /* Function Body */ + *ires = 0; + (*res)(t, &y[1], &yprime[1], cj, &r__[1], ires, &rpar[1], &ipar[1]); + if (*ires < 0) { + return 0; + } +/* ----------------------------------------------------------------------- */ +/* Apply inverse of Jacobian to vector R. */ +/* ----------------------------------------------------------------------- */ + dslvd_(neq, &r__[1], &wm[1], &iwm[1]); +/* ----------------------------------------------------------------------- */ +/* Calculate norm of R. */ +/* ----------------------------------------------------------------------- */ + *fnorm = ddwnrm_(neq, &r__[1], &wt[1], &rpar[1], &ipar[1]); + if (*tscale > 0.) { + *fnorm = *fnorm * *tscale * abs(*cj); + } + + return 0; +/* ----------------------- END OF SUBROUTINE DFNRMD ---------------------- */ +} /* dfnrmd_ */ + +/* Subroutine */ int dnedd_(doublereal *x, doublereal *y, doublereal *yprime, + integer *neq, S_fp res, U_fp jacd, doublereal *pdum, doublereal *h__, + doublereal *wt, integer *jstart, integer *idid, doublereal *rpar, + integer *ipar, doublereal *phi, doublereal *gamma, doublereal *dumsvr, + doublereal *delta, doublereal *e, doublereal *wm, integer *iwm, + doublereal *cj, doublereal *cjold, doublereal *cjlast, doublereal *s, + doublereal *uround, doublereal *dume, doublereal *dums, doublereal * + dumr, doublereal *epcon, integer *jcalc, integer *jfdum, integer *kp1, + integer *nonneg, integer *ntype, integer *iernls) +{ + /* Initialized data */ + + static integer muldel = 1; + static integer maxit = 4; + static doublereal xrate = .25; + + /* System generated locals */ + integer phi_dim1, phi_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + static integer i__, j, ierj; + extern /* Subroutine */ int dnsd_(doublereal *, doublereal *, doublereal * + , integer *, S_fp, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal * + , doublereal *, doublereal *, doublereal *, doublereal *, integer + *, integer *, integer *, integer *, integer *); + static integer idum, ires; + static doublereal temp1, temp2; + extern /* Subroutine */ int dmatd_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *, S_fp, + integer *, doublereal *, U_fp, doublereal *, integer *); + static doublereal pnorm, delnrm; + static integer iernew; + extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + static doublereal tolnew; + static integer iertyp; + + +/* ***BEGIN PROLOGUE DNEDD */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 891219 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DNEDD solves a nonlinear system of */ +/* algebraic equations of the form */ +/* G(X,Y,YPRIME) = 0 for the unknown Y. */ + +/* The method used is a modified Newton scheme. */ + +/* The parameters represent */ + +/* X -- Independent variable. */ +/* Y -- Solution vector. */ +/* YPRIME -- Derivative of solution vector. */ +/* NEQ -- Number of unknowns. */ +/* RES -- External user-supplied subroutine */ +/* to evaluate the residual. See RES description */ +/* in DDASPK prologue. */ +/* JACD -- External user-supplied routine to evaluate the */ +/* Jacobian. See JAC description for the case */ +/* INFO(12) = 0 in the DDASPK prologue. */ +/* PDUM -- Dummy argument. */ +/* H -- Appropriate step size for next step. */ +/* WT -- Vector of weights for error criterion. */ +/* JSTART -- Indicates first call to this routine. */ +/* If JSTART = 0, then this is the first call, */ +/* otherwise it is not. */ +/* IDID -- Completion flag, output by DNEDD. */ +/* See IDID description in DDASPK prologue. */ +/* RPAR,IPAR -- Real and integer arrays used for communication */ +/* between the calling program and external user */ +/* routines. They are not altered within DASPK. */ +/* PHI -- Array of divided differences used by */ +/* DNEDD. The length is NEQ*(K+1),where */ +/* K is the maximum order. */ +/* GAMMA -- Array used to predict Y and YPRIME. The length */ +/* is MAXORD+1 where MAXORD is the maximum order. */ +/* DUMSVR -- Dummy argument. */ +/* DELTA -- Work vector for NLS of length NEQ. */ +/* E -- Error accumulation vector for NLS of length NEQ. */ +/* WM,IWM -- Real and integer arrays storing */ +/* matrix information such as the matrix */ +/* of partial derivatives, permutation */ +/* vector, and various other information. */ +/* CJ -- Parameter always proportional to 1/H. */ +/* CJOLD -- Saves the value of CJ as of the last call to DMATD. */ +/* Accounts for changes in CJ needed to */ +/* decide whether to call DMATD. */ +/* CJLAST -- Previous value of CJ. */ +/* S -- A scalar determined by the approximate rate */ +/* of convergence of the Newton iteration and used */ +/* in the convergence test for the Newton iteration. */ + +/* If RATE is defined to be an estimate of the */ +/* rate of convergence of the Newton iteration, */ +/* then S = RATE/(1.D0-RATE). */ + +/* The closer RATE is to 0., the faster the Newton */ +/* iteration is converging; the closer RATE is to 1., */ +/* the slower the Newton iteration is converging. */ + +/* On the first Newton iteration with an up-dated */ +/* preconditioner S = 100.D0, Thus the initial */ +/* RATE of convergence is approximately 1. */ + +/* S is preserved from call to call so that the rate */ +/* estimate from a previous step can be applied to */ +/* the current step. */ +/* UROUND -- Unit roundoff. */ +/* DUME -- Dummy argument. */ +/* DUMS -- Dummy argument. */ +/* DUMR -- Dummy argument. */ +/* EPCON -- Tolerance to test for convergence of the Newton */ +/* iteration. */ +/* JCALC -- Flag used to determine when to update */ +/* the Jacobian matrix. In general: */ + +/* JCALC = -1 ==> Call the DMATD routine to update */ +/* the Jacobian matrix. */ +/* JCALC = 0 ==> Jacobian matrix is up-to-date. */ +/* JCALC = 1 ==> Jacobian matrix is out-dated, */ +/* but DMATD will not be called unless */ +/* JCALC is set to -1. */ +/* JFDUM -- Dummy argument. */ +/* KP1 -- The current order(K) + 1; updated across calls. */ +/* NONNEG -- Flag to determine nonnegativity constraints. */ +/* NTYPE -- Identification code for the NLS routine. */ +/* 0 ==> modified Newton; direct solver. */ +/* IERNLS -- Error flag for nonlinear solver. */ +/* 0 ==> nonlinear solver converged. */ +/* 1 ==> recoverable error inside nonlinear solver. */ +/* -1 ==> unrecoverable error inside nonlinear solver. */ + +/* All variables with "DUM" in their names are dummy variables */ +/* which are not used in this routine. */ + +/* Following is a list and description of local variables which */ +/* may not have an obvious usage. They are listed in roughly the */ +/* order they occur in this subroutine. */ + +/* The following group of variables are passed as arguments to */ +/* the Newton iteration solver. They are explained in greater detail */ +/* in DNSD: */ +/* TOLNEW, MULDEL, MAXIT, IERNEW */ + +/* IERTYP -- Flag which tells whether this subroutine is correct. */ +/* 0 ==> correct subroutine. */ +/* 1 ==> incorrect subroutine. */ + +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* DDWNRM, RES, DMATD, DNSD */ + +/* ***END PROLOGUE DNEDD */ + + + + + /* Parameter adjustments */ + --y; + --yprime; + phi_dim1 = *neq; + phi_offset = 1 + phi_dim1; + phi -= phi_offset; + --wt; + --rpar; + --ipar; + --gamma; + --delta; + --e; + --wm; + --iwm; + + /* Function Body */ + +/* Verify that this is the correct subroutine. */ + + iertyp = 0; + if (*ntype != 0) { + iertyp = 1; + goto L380; + } + +/* If this is the first step, perform initializations. */ + + if (*jstart == 0) { + *cjold = *cj; + *jcalc = -1; + } + +/* Perform all other initializations. */ + + *iernls = 0; + +/* Decide whether new Jacobian is needed. */ + + temp1 = (1. - xrate) / (xrate + 1.); + temp2 = 1. / temp1; + if (*cj / *cjold < temp1 || *cj / *cjold > temp2) { + *jcalc = -1; + } + if (*cj != *cjlast) { + *s = 100.; + } + +/* ----------------------------------------------------------------------- */ +/* Entry point for updating the Jacobian with current */ +/* stepsize. */ +/* ----------------------------------------------------------------------- */ +L300: + +/* Initialize all error flags to zero. */ + + ierj = 0; + ires = 0; + iernew = 0; + +/* Predict the solution and derivative and compute the tolerance */ +/* for the Newton iteration. */ + + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = phi[i__ + phi_dim1]; +/* L310: */ + yprime[i__] = 0.; + } + i__1 = *kp1; + for (j = 2; j <= i__1; ++j) { + i__2 = *neq; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += phi[i__ + j * phi_dim1]; +/* L320: */ + yprime[i__] += gamma[j] * phi[i__ + j * phi_dim1]; + } +/* L330: */ + } + pnorm = ddwnrm_(neq, &y[1], &wt[1], &rpar[1], &ipar[1]); + tolnew = *uround * 100. * pnorm; + +/* Call RES to initialize DELTA. */ + + ++iwm[12]; + (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]); + if (ires < 0) { + goto L380; + } + +/* If indicated, reevaluate the iteration matrix */ +/* J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). */ +/* Set JCALC to 0 as an indicator that this has been done. */ + + if (*jcalc == -1) { + ++iwm[13]; + *jcalc = 0; + dmatd_(neq, x, &y[1], &yprime[1], &delta[1], cj, h__, &ierj, &wt[1], & + e[1], &wm[1], &iwm[1], (S_fp)res, &ires, uround, (U_fp)jacd, & + rpar[1], &ipar[1]); + *cjold = *cj; + *s = 100.; + if (ires < 0) { + goto L380; + } + if (ierj != 0) { + goto L380; + } + } + +/* Call the nonlinear Newton solver. */ + + temp1 = 2. / (*cj / *cjold + 1.); + dnsd_(x, &y[1], &yprime[1], neq, (S_fp)res, pdum, &wt[1], &rpar[1], &ipar[ + 1], dumsvr, &delta[1], &e[1], &wm[1], &iwm[1], cj, dums, dumr, + dume, epcon, s, &temp1, &tolnew, &muldel, &maxit, &ires, &idum, & + iernew); + + if (iernew > 0 && *jcalc != 0) { + +/* The Newton iteration had a recoverable failure with an old */ +/* iteration matrix. Retry the step with a new iteration matrix. */ + + *jcalc = -1; + goto L300; + } + + if (iernew != 0) { + goto L380; + } + +/* The Newton iteration has converged. If nonnegativity of */ +/* solution is required, set the solution nonnegative, if the */ +/* perturbation to do it is small enough. If the change is too */ +/* large, then consider the corrector iteration to have failed. */ + +/* L375: */ + if (*nonneg == 0) { + goto L390; + } + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L377: */ +/* Computing MIN */ + d__1 = y[i__]; + delta[i__] = min(d__1,0.); + } + delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); + if (delnrm > *epcon) { + goto L380; + } + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L378: */ + e[i__] -= delta[i__]; + } + goto L390; + + +/* Exits from nonlinear solver. */ +/* No convergence with current iteration */ +/* matrix, or singular iteration matrix. */ +/* Compute IERNLS and IDID accordingly. */ + +L380: + if (ires <= -2 || iertyp != 0) { + *iernls = -1; + if (ires <= -2) { + *idid = -11; + } + if (iertyp != 0) { + *idid = -15; + } + } else { + *iernls = 1; + if (ires < 0) { + *idid = -10; + } + if (ierj != 0) { + *idid = -8; + } + } + +L390: + *jcalc = 1; + return 0; + +/* ------END OF SUBROUTINE DNEDD------------------------------------------ */ +} /* dnedd_ */ + +/* Subroutine */ int dnsd_(doublereal *x, doublereal *y, doublereal *yprime, + integer *neq, S_fp res, doublereal *pdum, doublereal *wt, doublereal * + rpar, integer *ipar, doublereal *dumsvr, doublereal *delta, + doublereal *e, doublereal *wm, integer *iwm, doublereal *cj, + doublereal *dums, doublereal *dumr, doublereal *dume, doublereal * + epcon, doublereal *s, doublereal *confac, doublereal *tolnew, integer + *muldel, integer *maxit, integer *ires, integer *idum, integer * + iernew) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2; + + /* Builtin functions */ + double pow_dd(doublereal *, doublereal *); + + /* Local variables */ + static integer i__, m; + static doublereal rate; + extern /* Subroutine */ int dslvd_(integer *, doublereal *, doublereal *, + integer *); + static doublereal delnrm; + extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + static doublereal oldnrm; + + +/* ***BEGIN PROLOGUE DNSD */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 891219 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***REVISION DATE 950126 (YYMMDD) */ +/* ***REVISION DATE 000711 (YYMMDD) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DNSD solves a nonlinear system of */ +/* algebraic equations of the form */ +/* G(X,Y,YPRIME) = 0 for the unknown Y. */ + +/* The method used is a modified Newton scheme. */ + +/* The parameters represent */ + +/* X -- Independent variable. */ +/* Y -- Solution vector. */ +/* YPRIME -- Derivative of solution vector. */ +/* NEQ -- Number of unknowns. */ +/* RES -- External user-supplied subroutine */ +/* to evaluate the residual. See RES description */ +/* in DDASPK prologue. */ +/* PDUM -- Dummy argument. */ +/* WT -- Vector of weights for error criterion. */ +/* RPAR,IPAR -- Real and integer arrays used for communication */ +/* between the calling program and external user */ +/* routines. They are not altered within DASPK. */ +/* DUMSVR -- Dummy argument. */ +/* DELTA -- Work vector for DNSD of length NEQ. */ +/* E -- Error accumulation vector for DNSD of length NEQ. */ +/* WM,IWM -- Real and integer arrays storing */ +/* matrix information such as the matrix */ +/* of partial derivatives, permutation */ +/* vector, and various other information. */ +/* CJ -- Parameter always proportional to 1/H (step size). */ +/* DUMS -- Dummy argument. */ +/* DUMR -- Dummy argument. */ +/* DUME -- Dummy argument. */ +/* EPCON -- Tolerance to test for convergence of the Newton */ +/* iteration. */ +/* S -- Used for error convergence tests. */ +/* In the Newton iteration: S = RATE/(1 - RATE), */ +/* where RATE is the estimated rate of convergence */ +/* of the Newton iteration. */ +/* The calling routine passes the initial value */ +/* of S to the Newton iteration. */ +/* CONFAC -- A residual scale factor to improve convergence. */ +/* TOLNEW -- Tolerance on the norm of Newton correction in */ +/* alternative Newton convergence test. */ +/* MULDEL -- A flag indicating whether or not to multiply */ +/* DELTA by CONFAC. */ +/* 0 ==> do not scale DELTA by CONFAC. */ +/* 1 ==> scale DELTA by CONFAC. */ +/* MAXIT -- Maximum allowed number of Newton iterations. */ +/* IRES -- Error flag returned from RES. See RES description */ +/* in DDASPK prologue. If IRES = -1, then IERNEW */ +/* will be set to 1. */ +/* If IRES < -1, then IERNEW will be set to -1. */ +/* IDUM -- Dummy argument. */ +/* IERNEW -- Error flag for Newton iteration. */ +/* 0 ==> Newton iteration converged. */ +/* 1 ==> recoverable error inside Newton iteration. */ +/* -1 ==> unrecoverable error inside Newton iteration. */ + +/* All arguments with "DUM" in their names are dummy arguments */ +/* which are not used in this routine. */ +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED */ +/* DSLVD, DDWNRM, RES */ + +/* ***END PROLOGUE DNSD */ + + + + +/* Initialize Newton counter M and accumulation vector E. */ + + /* Parameter adjustments */ + --iwm; + --wm; + --e; + --delta; + --ipar; + --rpar; + --wt; + --yprime; + --y; + + /* Function Body */ + m = 0; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L100: */ + e[i__] = 0.; + } + +/* Corrector loop. */ + +L300: + ++iwm[19]; + +/* If necessary, multiply residual by convergence factor. */ + + if (*muldel == 1) { + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L320: */ + delta[i__] *= *confac; + } + } + +/* Compute a new iterate (back-substitution). */ +/* Store the correction in DELTA. */ + + dslvd_(neq, &delta[1], &wm[1], &iwm[1]); + +/* Update Y, E, and YPRIME. */ + + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] -= delta[i__]; + e[i__] -= delta[i__]; +/* L340: */ + yprime[i__] -= *cj * delta[i__]; + } + +/* Test for convergence of the iteration. */ + + delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); + if (m == 0) { + oldnrm = delnrm; + if (delnrm <= *tolnew) { + goto L370; + } + } else { + d__1 = delnrm / oldnrm; + d__2 = 1. / m; + rate = pow_dd(&d__1, &d__2); + if (rate > .9) { + goto L380; + } + *s = rate / (1. - rate); + } + if (*s * delnrm <= *epcon) { + goto L370; + } + +/* The corrector has not yet converged. */ +/* Update M and test whether the */ +/* maximum number of iterations have */ +/* been tried. */ + + ++m; + if (m >= *maxit) { + goto L380; + } + +/* Evaluate the residual, */ +/* and go back to do another iteration. */ + + ++iwm[12]; + (*res)(x, &y[1], &yprime[1], cj, &delta[1], ires, &rpar[1], &ipar[1]); + if (*ires < 0) { + goto L380; + } + goto L300; + +/* The iteration has converged. */ + +L370: + return 0; + +/* The iteration has not converged. Set IERNEW appropriately. */ + +L380: + if (*ires <= -2) { + *iernew = -1; + } else { + *iernew = 1; + } + return 0; + + +/* ------END OF SUBROUTINE DNSD------------------------------------------- */ +} /* dnsd_ */ + +/* Subroutine */ int dmatd_(integer *neq, doublereal *x, doublereal *y, + doublereal *yprime, doublereal *delta, doublereal *cj, doublereal * + h__, integer *ier, doublereal *ewt, doublereal *e, doublereal *wm, + integer *iwm, S_fp res, integer *ires, doublereal *uround, S_fp jacd, + doublereal *rpar, integer *ipar) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2, d__3, d__4, d__5; + + /* Builtin functions */ + double sqrt(doublereal), d_sign(doublereal *, doublereal *); + + /* Local variables */ + static integer i__, j, k, l, n, i1, i2, ii, mba; + static doublereal del; + static integer meb1, nrow; + static doublereal squr; + extern /* Subroutine */ int dgbfa_(doublereal *, integer *, integer *, + integer *, integer *, integer *, integer *), dgefa_(doublereal *, + integer *, integer *, integer *, integer *); + static integer mband, lenpd, isave, msave; + static doublereal ysave; + static integer lipvt, mtype, meband; + static doublereal delinv; + static integer ipsave; + static doublereal ypsave; + + +/* ***BEGIN PROLOGUE DMATD */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***REVISION DATE 940701 (YYMMDD) (new LIPVT) */ + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* This routine computes the iteration matrix */ +/* J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). */ +/* Here J is computed by: */ +/* the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or */ +/* by numerical difference quotients if IWM(MTYPE) is 2 or 5. */ + +/* The parameters have the following meanings. */ +/* X = Independent variable. */ +/* Y = Array containing predicted values. */ +/* YPRIME = Array containing predicted derivatives. */ +/* DELTA = Residual evaluated at (X,Y,YPRIME). */ +/* (Used only if IWM(MTYPE)=2 or 5). */ +/* CJ = Scalar parameter defining iteration matrix. */ +/* H = Current stepsize in integration. */ +/* IER = Variable which is .NE. 0 if iteration matrix */ +/* is singular, and 0 otherwise. */ +/* EWT = Vector of error weights for computing norms. */ +/* E = Work space (temporary) of length NEQ. */ +/* WM = Real work space for matrices. On output */ +/* it contains the LU decomposition */ +/* of the iteration matrix. */ +/* IWM = Integer work space containing */ +/* matrix information. */ +/* RES = External user-supplied subroutine */ +/* to evaluate the residual. See RES description */ +/* in DDASPK prologue. */ +/* IRES = Flag which is equal to zero if no illegal values */ +/* in RES, and less than zero otherwise. (If IRES */ +/* is less than zero, the matrix was not completed). */ +/* In this case (if IRES .LT. 0), then IER = 0. */ +/* UROUND = The unit roundoff error of the machine being used. */ +/* JACD = Name of the external user-supplied routine */ +/* to evaluate the iteration matrix. (This routine */ +/* is only used if IWM(MTYPE) is 1 or 4) */ +/* See JAC description for the case INFO(12) = 0 */ +/* in DDASPK prologue. */ +/* RPAR,IPAR= Real and integer parameter arrays that */ +/* are used for communication between the */ +/* calling program and external user routines. */ +/* They are not altered by DMATD. */ +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* JACD, RES, DGEFA, DGBFA */ + +/* ***END PROLOGUE DMATD */ + + + + + /* Parameter adjustments */ + --ipar; + --rpar; + --iwm; + --wm; + --e; + --ewt; + --delta; + --yprime; + --y; + + /* Function Body */ + lipvt = iwm[30]; + *ier = 0; + mtype = iwm[4]; + switch (mtype) { + case 1: goto L100; + case 2: goto L200; + case 3: goto L300; + case 4: goto L400; + case 5: goto L500; + } + + +/* Dense user-supplied matrix. */ + +L100: + lenpd = iwm[22]; + i__1 = lenpd; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L110: */ + wm[i__] = 0.; + } + (*jacd)(x, &y[1], &yprime[1], &wm[1], cj, &rpar[1], &ipar[1]); + goto L230; + + +/* Dense finite-difference-generated matrix. */ + +L200: + *ires = 0; + nrow = 0; + squr = sqrt(*uround); + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__4 = (d__1 = y[i__], abs(d__1)), d__5 = (d__2 = *h__ * yprime[i__], + abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = 1. / ewt[ + i__], abs(d__3)); + del = squr * max(d__4,d__5); + d__1 = *h__ * yprime[i__]; + del = d_sign(&del, &d__1); + del = y[i__] + del - y[i__]; + ysave = y[i__]; + ypsave = yprime[i__]; + y[i__] += del; + yprime[i__] += *cj * del; + ++iwm[12]; + (*res)(x, &y[1], &yprime[1], cj, &e[1], ires, &rpar[1], &ipar[1]); + if (*ires < 0) { + return 0; + } + delinv = 1. / del; + i__2 = *neq; + for (l = 1; l <= i__2; ++l) { +/* L220: */ + wm[nrow + l] = (e[l] - delta[l]) * delinv; + } + nrow += *neq; + y[i__] = ysave; + yprime[i__] = ypsave; +/* L210: */ + } + + +/* Do dense-matrix LU decomposition on J. */ + +L230: + dgefa_(&wm[1], neq, neq, &iwm[lipvt], ier); + return 0; + + +/* Dummy section for IWM(MTYPE)=3. */ + +L300: + return 0; + + +/* Banded user-supplied matrix. */ + +L400: + lenpd = iwm[22]; + i__1 = lenpd; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L410: */ + wm[i__] = 0.; + } + (*jacd)(x, &y[1], &yprime[1], &wm[1], cj, &rpar[1], &ipar[1]); + meband = (iwm[1] << 1) + iwm[2] + 1; + goto L550; + + +/* Banded finite-difference-generated matrix. */ + +L500: + mband = iwm[1] + iwm[2] + 1; + mba = min(mband,*neq); + meband = mband + iwm[1]; + meb1 = meband - 1; + msave = *neq / mband + 1; + isave = iwm[22]; + ipsave = isave + msave; + *ires = 0; + squr = sqrt(*uround); + i__1 = mba; + for (j = 1; j <= i__1; ++j) { + i__2 = *neq; + i__3 = mband; + for (n = j; i__3 < 0 ? n >= i__2 : n <= i__2; n += i__3) { + k = (n - j) / mband + 1; + wm[isave + k] = y[n]; + wm[ipsave + k] = yprime[n]; +/* Computing MAX */ + d__4 = (d__1 = y[n], abs(d__1)), d__5 = (d__2 = *h__ * yprime[n], + abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = 1. / + ewt[n], abs(d__3)); + del = squr * max(d__4,d__5); + d__1 = *h__ * yprime[n]; + del = d_sign(&del, &d__1); + del = y[n] + del - y[n]; + y[n] += del; +/* L510: */ + yprime[n] += *cj * del; + } + ++iwm[12]; + (*res)(x, &y[1], &yprime[1], cj, &e[1], ires, &rpar[1], &ipar[1]); + if (*ires < 0) { + return 0; + } + i__3 = *neq; + i__2 = mband; + for (n = j; i__2 < 0 ? n >= i__3 : n <= i__3; n += i__2) { + k = (n - j) / mband + 1; + y[n] = wm[isave + k]; + yprime[n] = wm[ipsave + k]; +/* Computing MAX */ + d__4 = (d__1 = y[n], abs(d__1)), d__5 = (d__2 = *h__ * yprime[n], + abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = 1. / + ewt[n], abs(d__3)); + del = squr * max(d__4,d__5); + d__1 = *h__ * yprime[n]; + del = d_sign(&del, &d__1); + del = y[n] + del - y[n]; + delinv = 1. / del; +/* Computing MAX */ + i__4 = 1, i__5 = n - iwm[2]; + i1 = max(i__4,i__5); +/* Computing MIN */ + i__4 = *neq, i__5 = n + iwm[1]; + i2 = min(i__4,i__5); + ii = n * meb1 - iwm[1]; + i__4 = i2; + for (i__ = i1; i__ <= i__4; ++i__) { +/* L520: */ + wm[ii + i__] = (e[i__] - delta[i__]) * delinv; + } +/* L530: */ + } +/* L540: */ + } + + +/* Do LU decomposition of banded J. */ + +L550: + dgbfa_(&wm[1], &meband, neq, &iwm[1], &iwm[2], &iwm[lipvt], ier); + return 0; + +/* ------END OF SUBROUTINE DMATD------------------------------------------ */ +} /* dmatd_ */ + +/* Subroutine */ int dslvd_(integer *neq, doublereal *delta, doublereal *wm, + integer *iwm) +{ + extern /* Subroutine */ int dgbsl_(doublereal *, integer *, integer *, + integer *, integer *, integer *, doublereal *, integer *), dgesl_( + doublereal *, integer *, integer *, integer *, doublereal *, + integer *); + static integer lipvt, mtype, meband; + + +/* ***BEGIN PROLOGUE DSLVD */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***REVISION DATE 940701 (YYMMDD) (new LIPVT) */ + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* This routine manages the solution of the linear */ +/* system arising in the Newton iteration. */ +/* Real matrix information and real temporary storage */ +/* is stored in the array WM. */ +/* Integer matrix information is stored in the array IWM. */ +/* For a dense matrix, the LINPACK routine DGESL is called. */ +/* For a banded matrix, the LINPACK routine DGBSL is called. */ +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* DGESL, DGBSL */ + +/* ***END PROLOGUE DSLVD */ + + + + + /* Parameter adjustments */ + --iwm; + --wm; + --delta; + + /* Function Body */ + lipvt = iwm[30]; + mtype = iwm[4]; + switch (mtype) { + case 1: goto L100; + case 2: goto L100; + case 3: goto L300; + case 4: goto L400; + case 5: goto L400; + } + +/* Dense matrix. */ + +L100: + dgesl_(&wm[1], neq, neq, &iwm[lipvt], &delta[1], &c__0); + return 0; + +/* Dummy section for MTYPE=3. */ + +L300: + return 0; + +/* Banded matrix. */ + +L400: + meband = (iwm[1] << 1) + iwm[2] + 1; + dgbsl_(&wm[1], &meband, neq, &iwm[1], &iwm[2], &iwm[lipvt], &delta[1], & + c__0); + return 0; + +/* ------END OF SUBROUTINE DSLVD------------------------------------------ */ +} /* dslvd_ */ + +/* Subroutine */ int ddasik_(doublereal *x, doublereal *y, doublereal *yprime, + integer *neq, integer *icopt, integer *id, S_fp res, S_fp jack, U_fp + psol, doublereal *h__, doublereal *tscale, doublereal *wt, integer * + jskip, doublereal *rpar, integer *ipar, doublereal *savr, doublereal * + delta, doublereal *r__, doublereal *yic, doublereal *ypic, doublereal + *pwk, doublereal *wm, integer *iwm, doublereal *cj, doublereal * + uround, doublereal *epli, doublereal *sqrtn, doublereal *rsqrtn, + doublereal *epcon, doublereal *ratemx, doublereal *stptol, integer * + jflg, integer *icnflg, integer *icnstr, integer *iernls) +{ + static integer nj, lwp, ires, liwp, mxnj; + static doublereal eplin; + extern /* Subroutine */ int dnsik_(doublereal *, doublereal *, doublereal + *, integer *, integer *, integer *, S_fp, U_fp, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer * + , doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *); + static integer ierpj; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + static integer mxnit, iernew; + + +/* ***BEGIN PROLOGUE DDASIK */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 941026 (YYMMDD) */ +/* ***REVISION DATE 950808 (YYMMDD) */ +/* ***REVISION DATE 951110 Removed unreachable block 390. */ +/* ***REVISION DATE 000628 TSCALE argument added. */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + + +/* DDASIK solves a nonlinear system of algebraic equations of the */ +/* form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in */ +/* the initial conditions. */ + +/* An initial value for Y and initial guess for YPRIME are input. */ + +/* The method used is a Newton scheme with Krylov iteration and a */ +/* linesearch algorithm. */ + +/* The parameters represent */ + +/* X -- Independent variable. */ +/* Y -- Solution vector at x. */ +/* YPRIME -- Derivative of solution vector. */ +/* NEQ -- Number of equations to be integrated. */ +/* ICOPT -- Initial condition option chosen (1 or 2). */ +/* ID -- Array of dimension NEQ, which must be initialized */ +/* if ICOPT = 1. See DDASIC. */ +/* RES -- External user-supplied subroutine */ +/* to evaluate the residual. See RES description */ +/* in DDASPK prologue. */ +/* JACK -- External user-supplied routine to update */ +/* the preconditioner. (This is optional). */ +/* See JAC description for the case */ +/* INFO(12) = 1 in the DDASPK prologue. */ +/* PSOL -- External user-supplied routine to solve */ +/* a linear system using preconditioning. */ +/* (This is optional). See explanation inside DDASPK. */ +/* H -- Scaling factor for this initial condition calc. */ +/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ +/* WT -- Vector of weights for error criterion. */ +/* JSKIP -- input flag to signal if initial JAC call is to be */ +/* skipped. 1 => skip the call, 0 => do not skip call. */ +/* RPAR,IPAR -- Real and integer arrays used for communication */ +/* between the calling program and external user */ +/* routines. They are not altered within DASPK. */ +/* SAVR -- Work vector for DDASIK of length NEQ. */ +/* DELTA -- Work vector for DDASIK of length NEQ. */ +/* R -- Work vector for DDASIK of length NEQ. */ +/* YIC,YPIC -- Work vectors for DDASIK, each of length NEQ. */ +/* PWK -- Work vector for DDASIK of length NEQ. */ +/* WM,IWM -- Real and integer arrays storing */ +/* matrix information for linear system */ +/* solvers, and various other information. */ +/* CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */ +/* UROUND -- Unit roundoff. Not used here. */ +/* EPLI -- convergence test constant. */ +/* See DDASPK prologue for more details. */ +/* SQRTN -- Square root of NEQ. */ +/* RSQRTN -- reciprical of square root of NEQ. */ +/* EPCON -- Tolerance to test for convergence of the Newton */ +/* iteration. */ +/* RATEMX -- Maximum convergence rate for which Newton iteration */ +/* is considered converging. */ +/* JFLG -- Flag showing whether a Jacobian routine is supplied. */ +/* ICNFLG -- Integer scalar. If nonzero, then constraint */ +/* violations in the proposed new approximate solution */ +/* will be checked for, and the maximum step length */ +/* will be adjusted accordingly. */ +/* ICNSTR -- Integer array of length NEQ containing flags for */ +/* checking constraints. */ +/* IERNLS -- Error flag for nonlinear solver. */ +/* 0 ==> nonlinear solver converged. */ +/* 1,2 ==> recoverable error inside nonlinear solver. */ +/* 1 => retry with current Y, YPRIME */ +/* 2 => retry with original Y, YPRIME */ +/* -1 ==> unrecoverable error in nonlinear solver. */ + +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED */ +/* RES, JACK, DNSIK, DCOPY */ + +/* ***END PROLOGUE DDASIK */ + + + + + +/* Perform initializations. */ + + /* Parameter adjustments */ + --icnstr; + --iwm; + --wm; + --pwk; + --ypic; + --yic; + --r__; + --delta; + --savr; + --ipar; + --rpar; + --wt; + --id; + --yprime; + --y; + + /* Function Body */ + lwp = iwm[29]; + liwp = iwm[30]; + mxnit = iwm[32]; + mxnj = iwm[33]; + *iernls = 0; + nj = 0; + eplin = *epli * *epcon; + +/* Call RES to initialize DELTA. */ + + ires = 0; + ++iwm[12]; + (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]); + if (ires < 0) { + goto L370; + } + +/* Looping point for updating the preconditioner. */ + +L300: + +/* Initialize all error flags to zero. */ + + ierpj = 0; + ires = 0; + iernew = 0; + +/* If a Jacobian routine was supplied, call it. */ + + if (*jflg == 1 && *jskip == 0) { + ++nj; + ++iwm[13]; + (*jack)((S_fp)res, &ires, neq, x, &y[1], &yprime[1], &wt[1], &delta[1] + , &r__[1], h__, cj, &wm[lwp], &iwm[liwp], &ierpj, &rpar[1], & + ipar[1]); + if (ires < 0 || ierpj != 0) { + goto L370; + } + } + *jskip = 0; + +/* Call the nonlinear Newton solver for up to MXNIT iterations. */ + + dnsik_(x, &y[1], &yprime[1], neq, icopt, &id[1], (S_fp)res, (U_fp)psol, & + wt[1], &rpar[1], &ipar[1], &savr[1], &delta[1], &r__[1], &yic[1], + &ypic[1], &pwk[1], &wm[1], &iwm[1], cj, tscale, sqrtn, rsqrtn, & + eplin, epcon, ratemx, &mxnit, stptol, icnflg, &icnstr[1], &iernew) + ; + + if (iernew == 1 && nj < mxnj && *jflg == 1) { + +/* Up to MXNIT iterations were done, the convergence rate is < 1, */ +/* a Jacobian routine is supplied, and the number of JACK calls */ +/* is less than MXNJ. */ +/* Copy the residual SAVR to DELTA, call JACK, and try again. */ + + dcopy_(neq, &savr[1], &c__1, &delta[1], &c__1); + goto L300; + } + + if (iernew != 0) { + goto L380; + } + return 0; + + +/* Unsuccessful exits from nonlinear solver. */ +/* Set IERNLS accordingly. */ + +L370: + *iernls = 2; + if (ires <= -2) { + *iernls = -1; + } + return 0; + +L380: + *iernls = min(iernew,2); + return 0; + +/* ----------------------- END OF SUBROUTINE DDASIK----------------------- */ +} /* ddasik_ */ + +/* Subroutine */ int dnsik_(doublereal *x, doublereal *y, doublereal *yprime, + integer *neq, integer *icopt, integer *id, S_fp res, U_fp psol, + doublereal *wt, doublereal *rpar, integer *ipar, doublereal *savr, + doublereal *delta, doublereal *r__, doublereal *yic, doublereal *ypic, + doublereal *pwk, doublereal *wm, integer *iwm, doublereal *cj, + doublereal *tscale, doublereal *sqrtn, doublereal *rsqrtn, doublereal + *eplin, doublereal *epcon, doublereal *ratemx, integer *maxit, + doublereal *stptol, integer *icnflg, integer *icnstr, integer *iernew) +{ + static integer m, ier, lwp; + static doublereal rlx, rate; + static integer ires; + static doublereal fnrm, rhok; + static integer iret, liwp; + static doublereal fnrm0; + static integer lsoff; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + static integer iersl; + extern /* Subroutine */ int dslvk_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, S_fp, integer *, U_fp, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *); + static doublereal oldfnm; + extern /* Subroutine */ int dfnrmk_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, S_fp, + integer *, U_fp, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + static doublereal delnrm; + extern /* Subroutine */ int dlinsk_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, integer *, S_fp, integer *, + U_fp, doublereal *, integer *, doublereal *, doublereal *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *, doublereal *, doublereal *, integer *); + extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + + +/* ***BEGIN PROLOGUE DNSIK */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 940701 (YYMMDD) */ +/* ***REVISION DATE 950714 (YYMMDD) */ +/* ***REVISION DATE 000628 TSCALE argument added. */ +/* ***REVISION DATE 000628 Added criterion for IERNEW = 1 return. */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DNSIK solves a nonlinear system of algebraic equations of the */ +/* form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in */ +/* the initial conditions. */ + +/* The method used is a Newton scheme combined with a linesearch */ +/* algorithm, using Krylov iterative linear system methods. */ + +/* The parameters represent */ + +/* X -- Independent variable. */ +/* Y -- Solution vector. */ +/* YPRIME -- Derivative of solution vector. */ +/* NEQ -- Number of unknowns. */ +/* ICOPT -- Initial condition option chosen (1 or 2). */ +/* ID -- Array of dimension NEQ, which must be initialized */ +/* if ICOPT = 1. See DDASIC. */ +/* RES -- External user-supplied subroutine */ +/* to evaluate the residual. See RES description */ +/* in DDASPK prologue. */ +/* PSOL -- External user-supplied routine to solve */ +/* a linear system using preconditioning. */ +/* See explanation inside DDASPK. */ +/* WT -- Vector of weights for error criterion. */ +/* RPAR,IPAR -- Real and integer arrays used for communication */ +/* between the calling program and external user */ +/* routines. They are not altered within DASPK. */ +/* SAVR -- Work vector for DNSIK of length NEQ. */ +/* DELTA -- Residual vector on entry, and work vector of */ +/* length NEQ for DNSIK. */ +/* R -- Work vector for DNSIK of length NEQ. */ +/* YIC,YPIC -- Work vectors for DNSIK, each of length NEQ. */ +/* PWK -- Work vector for DNSIK of length NEQ. */ +/* WM,IWM -- Real and integer arrays storing */ +/* matrix information such as the matrix */ +/* of partial derivatives, permutation */ +/* vector, and various other information. */ +/* CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */ +/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ +/* SQRTN -- Square root of NEQ. */ +/* RSQRTN -- reciprical of square root of NEQ. */ +/* EPLIN -- Tolerance for linear system solver. */ +/* EPCON -- Tolerance to test for convergence of the Newton */ +/* iteration. */ +/* RATEMX -- Maximum convergence rate for which Newton iteration */ +/* is considered converging. */ +/* MAXIT -- Maximum allowed number of Newton iterations. */ +/* STPTOL -- Tolerance used in calculating the minimum lambda */ +/* value allowed. */ +/* ICNFLG -- Integer scalar. If nonzero, then constraint */ +/* violations in the proposed new approximate solution */ +/* will be checked for, and the maximum step length */ +/* will be adjusted accordingly. */ +/* ICNSTR -- Integer array of length NEQ containing flags for */ +/* checking constraints. */ +/* IERNEW -- Error flag for Newton iteration. */ +/* 0 ==> Newton iteration converged. */ +/* 1 ==> failed to converge, but RATE .lt. 1, or the */ +/* residual norm was reduced by a factor of .1. */ +/* 2 ==> failed to converge, RATE .gt. RATEMX. */ +/* 3 ==> other recoverable error. */ +/* -1 ==> unrecoverable error inside Newton iteration. */ +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED */ +/* DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY */ + +/* ***END PROLOGUE DNSIK */ + + + + + +/* Initializations. M is the Newton iteration counter. */ + + /* Parameter adjustments */ + --icnstr; + --iwm; + --wm; + --pwk; + --ypic; + --yic; + --r__; + --delta; + --savr; + --ipar; + --rpar; + --wt; + --id; + --yprime; + --y; + + /* Function Body */ + lsoff = iwm[35]; + m = 0; + rate = 1.; + lwp = iwm[29]; + liwp = iwm[30]; + rlx = .4; + +/* Save residual in SAVR. */ + + dcopy_(neq, &delta[1], &c__1, &savr[1], &c__1); + +/* Compute norm of (P-inverse)*(residual). */ + + dfnrmk_(neq, &y[1], x, &yprime[1], &savr[1], &r__[1], cj, tscale, &wt[1], + sqrtn, rsqrtn, (S_fp)res, &ires, (U_fp)psol, &c__1, &ier, &fnrm, + eplin, &wm[lwp], &iwm[liwp], &pwk[1], &rpar[1], &ipar[1]); + ++iwm[21]; + if (ier != 0) { + *iernew = 3; + return 0; + } + +/* Return now if residual norm is .le. EPCON. */ + + if (fnrm <= *epcon) { + return 0; + } + +/* Newton iteration loop. */ + + fnrm0 = fnrm; +L300: + ++iwm[19]; + +/* Compute a new step vector DELTA. */ + + dslvk_(neq, &y[1], x, &yprime[1], &savr[1], &delta[1], &wt[1], &wm[1], & + iwm[1], (S_fp)res, &ires, (U_fp)psol, &iersl, cj, eplin, sqrtn, + rsqrtn, &rhok, &rpar[1], &ipar[1]); + if (ires != 0 || iersl != 0) { + goto L390; + } + +/* Get norm of DELTA. Return now if DELTA is zero. */ + + delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); + if (delnrm == 0.) { + return 0; + } + +/* Call linesearch routine for global strategy and set RATE. */ + + oldfnm = fnrm; + + dlinsk_(neq, &y[1], x, &yprime[1], &savr[1], cj, tscale, &delta[1], & + delnrm, &wt[1], sqrtn, rsqrtn, &lsoff, stptol, &iret, (S_fp)res, & + ires, (U_fp)psol, &wm[1], &iwm[1], &rhok, &fnrm, icopt, &id[1], & + wm[lwp], &iwm[liwp], &r__[1], eplin, &yic[1], &ypic[1], &pwk[1], + icnflg, &icnstr[1], &rlx, &rpar[1], &ipar[1]); + + rate = fnrm / oldfnm; + +/* Check for error condition from linesearch. */ + if (iret != 0) { + goto L390; + } + +/* Test for convergence of the iteration, and return or loop. */ + + if (fnrm <= *epcon) { + return 0; + } + +/* The iteration has not yet converged. Update M. */ +/* Test whether the maximum number of iterations have been tried. */ + + ++m; + if (m >= *maxit) { + goto L380; + } + +/* Copy the residual SAVR to DELTA and loop for another iteration. */ + + dcopy_(neq, &savr[1], &c__1, &delta[1], &c__1); + goto L300; + +/* The maximum number of iterations was done. Set IERNEW and return. */ + +L380: + if (rate <= *ratemx || fnrm <= fnrm0 * .1) { + *iernew = 1; + } else { + *iernew = 2; + } + return 0; + +L390: + if (ires <= -2 || iersl < 0) { + *iernew = -1; + } else { + *iernew = 3; + if (ires == 0 && iersl == 1 && m >= 2 && rate < 1.) { + *iernew = 1; + } + } + return 0; + + +/* ----------------------- END OF SUBROUTINE DNSIK------------------------ */ +} /* dnsik_ */ + +/* Subroutine */ int dlinsk_(integer *neq, doublereal *y, doublereal *t, + doublereal *yprime, doublereal *savr, doublereal *cj, doublereal * + tscale, doublereal *p, doublereal *pnrm, doublereal *wt, doublereal * + sqrtn, doublereal *rsqrtn, integer *lsoff, doublereal *stptol, + integer *iret, S_fp res, integer *ires, U_fp psol, doublereal *wm, + integer *iwm, doublereal *rhok, doublereal *fnrm, integer *icopt, + integer *id, doublereal *wp, integer *iwp, doublereal *r__, + doublereal *eplin, doublereal *ynew, doublereal *ypnew, doublereal * + pwk, integer *icnflg, integer *icnstr, doublereal *rlx, doublereal * + rpar, integer *ipar) +{ + /* Initialized data */ + + static doublereal alpha = 1e-4; + static doublereal one = 1.; + static doublereal two = 2.; + + /* System generated locals */ + integer i__1; + + /* Builtin functions */ + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + + /* Local variables */ + static integer i__; + static doublereal rl; + static integer ier; + static char msg[80]; + static doublereal tau; + static integer ivar; + static doublereal slpi, f1nrm, ratio; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + static doublereal rlmin, fnrmp; + static integer kprin; + static doublereal ratio1, f1nrmp; + extern /* Subroutine */ int dfnrmk_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, S_fp, + integer *, U_fp, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *), + dcnstr_(integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *), xerrwd_(char *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, doublereal *, doublereal *, ftnlen), dyypnw_(integer * + , doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, doublereal *); + + +/* ***BEGIN PROLOGUE DLINSK */ +/* ***REFER TO DNSIK */ +/* ***DATE WRITTEN 940830 (YYMMDD) */ +/* ***REVISION DATE 951006 (Arguments SQRTN, RSQRTN added.) */ +/* ***REVISION DATE 960129 Moved line RL = ONE to top block. */ +/* ***REVISION DATE 000628 TSCALE argument added. */ +/* ***REVISION DATE 000628 RHOK*RHOK term removed in alpha test. */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME) */ +/* pair (YNEW,YPNEW) such that */ + +/* f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) */ + +/* where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of */ +/* the final residual vector in the Krylov iteration. */ +/* Here, f(y,y') is defined as */ + +/* f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 , */ + +/* where norm() is the weighted RMS vector norm, G is the DAE */ +/* system residual function, and P is the preconditioner used */ +/* in the Krylov iteration. */ + +/* In addition to the parameters defined elsewhere, we have */ + +/* SAVR -- Work array of length NEQ, containing the residual */ +/* vector G(t,y,y') on return. */ +/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ +/* P -- Approximate Newton step used in backtracking. */ +/* PNRM -- Weighted RMS norm of P. */ +/* LSOFF -- Flag showing whether the linesearch algorithm is */ +/* to be invoked. 0 means do the linesearch, */ +/* 1 means turn off linesearch. */ +/* STPTOL -- Tolerance used in calculating the minimum lambda */ +/* value allowed. */ +/* ICNFLG -- Integer scalar. If nonzero, then constraint violations */ +/* in the proposed new approximate solution will be */ +/* checked for, and the maximum step length will be */ +/* adjusted accordingly. */ +/* ICNSTR -- Integer array of length NEQ containing flags for */ +/* checking constraints. */ +/* RHOK -- Weighted norm of preconditioned Krylov residual. */ +/* RLX -- Real scalar restricting update size in DCNSTR. */ +/* YNEW -- Array of length NEQ used to hold the new Y in */ +/* performing the linesearch. */ +/* YPNEW -- Array of length NEQ used to hold the new YPRIME in */ +/* performing the linesearch. */ +/* PWK -- Work vector of length NEQ for use in PSOL. */ +/* Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). */ +/* YPRIME -- Array of length NEQ containing the new YPRIME */ +/* (i.e.,=YPNEW). */ +/* FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the */ +/* current (Y,YPRIME) on input and output. */ +/* R -- Work space length NEQ for residual vector. */ +/* IRET -- Return flag. */ +/* IRET=0 means that a satisfactory (Y,YPRIME) was found. */ +/* IRET=1 means that the routine failed to find a new */ +/* (Y,YPRIME) that was sufficiently distinct from */ +/* the current (Y,YPRIME) pair. */ +/* IRET=2 means a failure in RES or PSOL. */ +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED */ +/* DFNRMK, DYYPNW, DCNSTR, DCOPY, XERRWD */ + +/* ***END PROLOGUE DLINSK */ + + + + /* Parameter adjustments */ + --ipar; + --rpar; + --icnstr; + --pwk; + --ypnew; + --ynew; + --r__; + --iwp; + --wp; + --id; + --iwm; + --wm; + --wt; + --p; + --savr; + --yprime; + --y; + + /* Function Body */ + + kprin = iwm[31]; + f1nrm = *fnrm * *fnrm / two; + ratio = one; + + if (kprin >= 2) { + s_copy(msg, "------ IN ROUTINE DLINSK-- PNRM = (R1)", (ftnlen)80, ( + ftnlen)38); + xerrwd_(msg, &c__38, &c__921, &c__0, &c__0, &c__0, &c__0, &c__1, pnrm, + &c_b37, (ftnlen)80); + } + tau = *pnrm; + rl = one; +/* ----------------------------------------------------------------------- */ +/* Check for violations of the constraints, if any are imposed. */ +/* If any violations are found, the step vector P is rescaled, and the */ +/* constraint check is repeated, until no violations are found. */ +/* ----------------------------------------------------------------------- */ + if (*icnflg != 0) { +L10: + dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[ + 1], &ypnew[1]); + dcnstr_(neq, &y[1], &ynew[1], &icnstr[1], &tau, rlx, iret, &ivar); + if (*iret == 1) { + ratio1 = tau / *pnrm; + ratio *= ratio1; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L20: */ + p[i__] *= ratio1; + } + *pnrm = tau; + if (kprin >= 2) { + s_copy(msg, "------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (" + "I1)", (ftnlen)80, (ftnlen)50); + xerrwd_(msg, &c__50, &c__922, &c__0, &c__1, &ivar, &c__0, & + c__1, pnrm, &c_b37, (ftnlen)80); + } + if (*pnrm <= *stptol) { + *iret = 1; + return 0; + } + goto L10; + } + } + + slpi = -two * f1nrm * ratio; + rlmin = *stptol / *pnrm; + if (*lsoff == 0 && kprin >= 2) { + s_copy(msg, "------ MIN. LAMBDA = (R1)", (ftnlen)80, (ftnlen)25); + xerrwd_(msg, &c__25, &c__923, &c__0, &c__0, &c__0, &c__0, &c__1, & + rlmin, &c_b37, (ftnlen)80); + } +/* ----------------------------------------------------------------------- */ +/* Begin iteration to find RL value satisfying alpha-condition. */ +/* Update YNEW and YPNEW, then compute norm of new scaled residual and */ +/* perform alpha condition test. */ +/* ----------------------------------------------------------------------- */ +L100: + dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[1], & + ypnew[1]); + dfnrmk_(neq, &ynew[1], t, &ypnew[1], &savr[1], &r__[1], cj, tscale, &wt[1] + , sqrtn, rsqrtn, (S_fp)res, ires, (U_fp)psol, &c__0, &ier, &fnrmp, + eplin, &wp[1], &iwp[1], &pwk[1], &rpar[1], &ipar[1]); + ++iwm[12]; + if (*ires >= 0) { + ++iwm[21]; + } + if (*ires != 0 || ier != 0) { + *iret = 2; + return 0; + } + if (*lsoff == 1) { + goto L150; + } + + f1nrmp = fnrmp * fnrmp / two; + if (kprin >= 2) { + s_copy(msg, "------ LAMBDA = (R1)", (ftnlen)80, (ftnlen)20); + xerrwd_(msg, &c__20, &c__924, &c__0, &c__0, &c__0, &c__0, &c__1, &rl, + &c_b37, (ftnlen)80); + s_copy(msg, "------ NORM(F1) = (R1), NORM(F1NEW) = (R2)", (ftnlen)80, + (ftnlen)43); + xerrwd_(msg, &c__43, &c__925, &c__0, &c__0, &c__0, &c__0, &c__2, & + f1nrm, &f1nrmp, (ftnlen)80); + } + if (f1nrmp > f1nrm + alpha * slpi * rl) { + goto L200; + } +/* ----------------------------------------------------------------------- */ +/* Alpha-condition is satisfied, or linesearch is turned off. */ +/* Copy YNEW,YPNEW to Y,YPRIME and return. */ +/* ----------------------------------------------------------------------- */ +L150: + *iret = 0; + dcopy_(neq, &ynew[1], &c__1, &y[1], &c__1); + dcopy_(neq, &ypnew[1], &c__1, &yprime[1], &c__1); + *fnrm = fnrmp; + if (kprin >= 1) { + s_copy(msg, "------ LEAVING ROUTINE DLINSK, FNRM = (R1)", (ftnlen)80, + (ftnlen)42); + xerrwd_(msg, &c__42, &c__926, &c__0, &c__0, &c__0, &c__0, &c__1, fnrm, + &c_b37, (ftnlen)80); + } + return 0; +/* ----------------------------------------------------------------------- */ +/* Alpha-condition not satisfied. Perform backtrack to compute new RL */ +/* value. If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can */ +/* be found sufficiently distinct from Y,YPRIME, then return IRET = 1. */ +/* ----------------------------------------------------------------------- */ +L200: + if (rl < rlmin) { + *iret = 1; + return 0; + } + + rl /= two; + goto L100; + +/* ----------------------- END OF SUBROUTINE DLINSK ---------------------- */ +} /* dlinsk_ */ + +/* Subroutine */ int dfnrmk_(integer *neq, doublereal *y, doublereal *t, + doublereal *yprime, doublereal *savr, doublereal *r__, doublereal *cj, + doublereal *tscale, doublereal *wt, doublereal *sqrtn, doublereal * + rsqrtn, S_fp res, integer *ires, S_fp psol, integer *irin, integer * + ier, doublereal *fnorm, doublereal *eplin, doublereal *wp, integer * + iwp, doublereal *pwk, doublereal *rpar, integer *ipar) +{ + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dcopy_(integer *, doublereal *, integer *, doublereal + *, integer *); + extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + + +/* ***BEGIN PROLOGUE DFNRMK */ +/* ***REFER TO DLINSK */ +/* ***DATE WRITTEN 940830 (YYMMDD) */ +/* ***REVISION DATE 951006 (SQRTN, RSQRTN, and scaling of WT added.) */ +/* ***REVISION DATE 000628 TSCALE argument added. */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DFNRMK calculates the scaled preconditioned norm of the nonlinear */ +/* function used in the nonlinear iteration for obtaining consistent */ +/* initial conditions. Specifically, DFNRMK calculates the weighted */ +/* root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME), */ +/* where P is the preconditioner matrix. */ + +/* In addition to the parameters described in the calling program */ +/* DLINSK, the parameters represent */ + +/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ +/* IRIN -- Flag showing whether the current residual vector is */ +/* input in SAVR. 1 means it is, 0 means it is not. */ +/* R -- Array of length NEQ that contains */ +/* (P-inverse)*G(T,Y,YPRIME) on return. */ +/* FNORM -- Scalar containing the weighted norm of R on return. */ +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED */ +/* RES, DCOPY, DSCAL, PSOL, DDWNRM */ + +/* ***END PROLOGUE DFNRMK */ + + +/* ----------------------------------------------------------------------- */ +/* Call RES routine if IRIN = 0. */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ipar; + --rpar; + --pwk; + --iwp; + --wp; + --wt; + --r__; + --savr; + --yprime; + --y; + + /* Function Body */ + if (*irin == 0) { + *ires = 0; + (*res)(t, &y[1], &yprime[1], cj, &savr[1], ires, &rpar[1], &ipar[1]); + if (*ires < 0) { + return 0; + } + } +/* ----------------------------------------------------------------------- */ +/* Apply inverse of left preconditioner to vector R. */ +/* First scale WT array by 1/sqrt(N), and undo scaling afterward. */ +/* ----------------------------------------------------------------------- */ + dcopy_(neq, &savr[1], &c__1, &r__[1], &c__1); + dscal_(neq, rsqrtn, &wt[1], &c__1); + *ier = 0; + (*psol)(neq, t, &y[1], &yprime[1], &savr[1], &pwk[1], cj, &wt[1], &wp[1], + &iwp[1], &r__[1], eplin, ier, &rpar[1], &ipar[1]); + dscal_(neq, sqrtn, &wt[1], &c__1); + if (*ier != 0) { + return 0; + } +/* ----------------------------------------------------------------------- */ +/* Calculate norm of R. */ +/* ----------------------------------------------------------------------- */ + *fnorm = ddwnrm_(neq, &r__[1], &wt[1], &rpar[1], &ipar[1]); + if (*tscale > 0.) { + *fnorm = *fnorm * *tscale * abs(*cj); + } + + return 0; +/* ----------------------- END OF SUBROUTINE DFNRMK ---------------------- */ +} /* dfnrmk_ */ + +/* Subroutine */ int dnedk_(doublereal *x, doublereal *y, doublereal *yprime, + integer *neq, S_fp res, S_fp jack, U_fp psol, doublereal *h__, + doublereal *wt, integer *jstart, integer *idid, doublereal *rpar, + integer *ipar, doublereal *phi, doublereal *gamma, doublereal *savr, + doublereal *delta, doublereal *e, doublereal *wm, integer *iwm, + doublereal *cj, doublereal *cjold, doublereal *cjlast, doublereal *s, + doublereal *uround, doublereal *epli, doublereal *sqrtn, doublereal * + rsqrtn, doublereal *epcon, integer *jcalc, integer *jflg, integer * + kp1, integer *nonneg, integer *ntype, integer *iernls) +{ + /* Initialized data */ + + static integer muldel = 0; + static integer maxit = 4; + static doublereal xrate = .25; + + /* System generated locals */ + integer phi_dim1, phi_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + static integer i__, j, lwp; + extern /* Subroutine */ int dnsk_(doublereal *, doublereal *, doublereal * + , integer *, S_fp, U_fp, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *, integer *, integer *, integer *); + static integer ires, liwp; + static doublereal temp1, temp2, eplin; + static integer ierpj, iersl; + static doublereal delnrm; + static integer iernew; + extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + static doublereal tolnew; + static integer iertyp; + + +/* ***BEGIN PROLOGUE DNEDK */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 891219 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***REVISION DATE 940701 (YYMMDD) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DNEDK solves a nonlinear system of */ +/* algebraic equations of the form */ +/* G(X,Y,YPRIME) = 0 for the unknown Y. */ + +/* The method used is a matrix-free Newton scheme. */ + +/* The parameters represent */ +/* X -- Independent variable. */ +/* Y -- Solution vector at x. */ +/* YPRIME -- Derivative of solution vector */ +/* after successful step. */ +/* NEQ -- Number of equations to be integrated. */ +/* RES -- External user-supplied subroutine */ +/* to evaluate the residual. See RES description */ +/* in DDASPK prologue. */ +/* JACK -- External user-supplied routine to update */ +/* the preconditioner. (This is optional). */ +/* See JAC description for the case */ +/* INFO(12) = 1 in the DDASPK prologue. */ +/* PSOL -- External user-supplied routine to solve */ +/* a linear system using preconditioning. */ +/* (This is optional). See explanation inside DDASPK. */ +/* H -- Appropriate step size for this step. */ +/* WT -- Vector of weights for error criterion. */ +/* JSTART -- Indicates first call to this routine. */ +/* If JSTART = 0, then this is the first call, */ +/* otherwise it is not. */ +/* IDID -- Completion flag, output by DNEDK. */ +/* See IDID description in DDASPK prologue. */ +/* RPAR,IPAR -- Real and integer arrays used for communication */ +/* between the calling program and external user */ +/* routines. They are not altered within DASPK. */ +/* PHI -- Array of divided differences used by */ +/* DNEDK. The length is NEQ*(K+1), where */ +/* K is the maximum order. */ +/* GAMMA -- Array used to predict Y and YPRIME. The length */ +/* is K+1, where K is the maximum order. */ +/* SAVR -- Work vector for DNEDK of length NEQ. */ +/* DELTA -- Work vector for DNEDK of length NEQ. */ +/* E -- Error accumulation vector for DNEDK of length NEQ. */ +/* WM,IWM -- Real and integer arrays storing */ +/* matrix information for linear system */ +/* solvers, and various other information. */ +/* CJ -- Parameter always proportional to 1/H. */ +/* CJOLD -- Saves the value of CJ as of the last call to DITMD. */ +/* Accounts for changes in CJ needed to */ +/* decide whether to call DITMD. */ +/* CJLAST -- Previous value of CJ. */ +/* S -- A scalar determined by the approximate rate */ +/* of convergence of the Newton iteration and used */ +/* in the convergence test for the Newton iteration. */ + +/* If RATE is defined to be an estimate of the */ +/* rate of convergence of the Newton iteration, */ +/* then S = RATE/(1.D0-RATE). */ + +/* The closer RATE is to 0., the faster the Newton */ +/* iteration is converging; the closer RATE is to 1., */ +/* the slower the Newton iteration is converging. */ + +/* On the first Newton iteration with an up-dated */ +/* preconditioner S = 100.D0, Thus the initial */ +/* RATE of convergence is approximately 1. */ + +/* S is preserved from call to call so that the rate */ +/* estimate from a previous step can be applied to */ +/* the current step. */ +/* UROUND -- Unit roundoff. Not used here. */ +/* EPLI -- convergence test constant. */ +/* See DDASPK prologue for more details. */ +/* SQRTN -- Square root of NEQ. */ +/* RSQRTN -- reciprical of square root of NEQ. */ +/* EPCON -- Tolerance to test for convergence of the Newton */ +/* iteration. */ +/* JCALC -- Flag used to determine when to update */ +/* the Jacobian matrix. In general: */ + +/* JCALC = -1 ==> Call the DITMD routine to update */ +/* the Jacobian matrix. */ +/* JCALC = 0 ==> Jacobian matrix is up-to-date. */ +/* JCALC = 1 ==> Jacobian matrix is out-dated, */ +/* but DITMD will not be called unless */ +/* JCALC is set to -1. */ +/* JFLG -- Flag showing whether a Jacobian routine is supplied. */ +/* KP1 -- The current order + 1; updated across calls. */ +/* NONNEG -- Flag to determine nonnegativity constraints. */ +/* NTYPE -- Identification code for the DNEDK routine. */ +/* 1 ==> modified Newton; iterative linear solver. */ +/* 2 ==> modified Newton; user-supplied linear solver. */ +/* IERNLS -- Error flag for nonlinear solver. */ +/* 0 ==> nonlinear solver converged. */ +/* 1 ==> recoverable error inside non-linear solver. */ +/* -1 ==> unrecoverable error inside non-linear solver. */ + +/* The following group of variables are passed as arguments to */ +/* the Newton iteration solver. They are explained in greater detail */ +/* in DNSK: */ +/* TOLNEW, MULDEL, MAXIT, IERNEW */ + +/* IERTYP -- Flag which tells whether this subroutine is correct. */ +/* 0 ==> correct subroutine. */ +/* 1 ==> incorrect subroutine. */ + +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* RES, JACK, DDWNRM, DNSK */ + +/* ***END PROLOGUE DNEDK */ + + + + + /* Parameter adjustments */ + --y; + --yprime; + phi_dim1 = *neq; + phi_offset = 1 + phi_dim1; + phi -= phi_offset; + --wt; + --rpar; + --ipar; + --gamma; + --savr; + --delta; + --e; + --wm; + --iwm; + + /* Function Body */ + +/* Verify that this is the correct subroutine. */ + + iertyp = 0; + if (*ntype != 1) { + iertyp = 1; + goto L380; + } + +/* If this is the first step, perform initializations. */ + + if (*jstart == 0) { + *cjold = *cj; + *jcalc = -1; + *s = 100.; + } + +/* Perform all other initializations. */ + + *iernls = 0; + lwp = iwm[29]; + liwp = iwm[30]; + +/* Decide whether to update the preconditioner. */ + + if (*jflg != 0) { + temp1 = (1. - xrate) / (xrate + 1.); + temp2 = 1. / temp1; + if (*cj / *cjold < temp1 || *cj / *cjold > temp2) { + *jcalc = -1; + } + if (*cj != *cjlast) { + *s = 100.; + } + } else { + *jcalc = 0; + } + +/* Looping point for updating preconditioner with current stepsize. */ + +L300: + +/* Initialize all error flags to zero. */ + + ierpj = 0; + ires = 0; + iersl = 0; + iernew = 0; + +/* Predict the solution and derivative and compute the tolerance */ +/* for the Newton iteration. */ + + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] = phi[i__ + phi_dim1]; +/* L310: */ + yprime[i__] = 0.; + } + i__1 = *kp1; + for (j = 2; j <= i__1; ++j) { + i__2 = *neq; + for (i__ = 1; i__ <= i__2; ++i__) { + y[i__] += phi[i__ + j * phi_dim1]; +/* L320: */ + yprime[i__] += gamma[j] * phi[i__ + j * phi_dim1]; + } +/* L330: */ + } + eplin = *epli * *epcon; + tolnew = eplin; + +/* Call RES to initialize DELTA. */ + + ++iwm[12]; + (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]); + if (ires < 0) { + goto L380; + } + + +/* If indicated, update the preconditioner. */ +/* Set JCALC to 0 as an indicator that this has been done. */ + + if (*jcalc == -1) { + ++iwm[13]; + *jcalc = 0; + (*jack)((S_fp)res, &ires, neq, x, &y[1], &yprime[1], &wt[1], &delta[1] + , &e[1], h__, cj, &wm[lwp], &iwm[liwp], &ierpj, &rpar[1], & + ipar[1]); + *cjold = *cj; + *s = 100.; + if (ires < 0) { + goto L380; + } + if (ierpj != 0) { + goto L380; + } + } + +/* Call the nonlinear Newton solver. */ + + dnsk_(x, &y[1], &yprime[1], neq, (S_fp)res, (U_fp)psol, &wt[1], &rpar[1], + &ipar[1], &savr[1], &delta[1], &e[1], &wm[1], &iwm[1], cj, sqrtn, + rsqrtn, &eplin, epcon, s, &temp1, &tolnew, &muldel, &maxit, &ires, + &iersl, &iernew); + + if (iernew > 0 && *jcalc != 0) { + +/* The Newton iteration had a recoverable failure with an old */ +/* preconditioner. Retry the step with a new preconditioner. */ + + *jcalc = -1; + goto L300; + } + + if (iernew != 0) { + goto L380; + } + +/* The Newton iteration has converged. If nonnegativity of */ +/* solution is required, set the solution nonnegative, if the */ +/* perturbation to do it is small enough. If the change is too */ +/* large, then consider the corrector iteration to have failed. */ + + if (*nonneg == 0) { + goto L390; + } + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L360: */ +/* Computing MIN */ + d__1 = y[i__]; + delta[i__] = min(d__1,0.); + } + delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); + if (delnrm > *epcon) { + goto L380; + } + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L370: */ + e[i__] -= delta[i__]; + } + goto L390; + + +/* Exits from nonlinear solver. */ +/* No convergence with current preconditioner. */ +/* Compute IERNLS and IDID accordingly. */ + +L380: + if (ires <= -2 || iersl < 0 || iertyp != 0) { + *iernls = -1; + if (ires <= -2) { + *idid = -11; + } + if (iersl < 0) { + *idid = -13; + } + if (iertyp != 0) { + *idid = -15; + } + } else { + *iernls = 1; + if (ires == -1) { + *idid = -10; + } + if (ierpj != 0) { + *idid = -5; + } + if (iersl > 0) { + *idid = -14; + } + } + + +L390: + *jcalc = 1; + return 0; + +/* ------END OF SUBROUTINE DNEDK------------------------------------------ */ +} /* dnedk_ */ + +/* Subroutine */ int dnsk_(doublereal *x, doublereal *y, doublereal *yprime, + integer *neq, S_fp res, U_fp psol, doublereal *wt, doublereal *rpar, + integer *ipar, doublereal *savr, doublereal *delta, doublereal *e, + doublereal *wm, integer *iwm, doublereal *cj, doublereal *sqrtn, + doublereal *rsqrtn, doublereal *eplin, doublereal *epcon, doublereal * + s, doublereal *confac, doublereal *tolnew, integer *muldel, integer * + maxit, integer *ires, integer *iersl, integer *iernew) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2; + + /* Builtin functions */ + double pow_dd(doublereal *, doublereal *); + + /* Local variables */ + static integer i__, m; + static doublereal rate, rhok; + extern /* Subroutine */ int dslvk_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, S_fp, integer *, U_fp, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *); + static doublereal delnrm; + extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, + doublereal *, integer *); + static doublereal oldnrm; + + +/* ***BEGIN PROLOGUE DNSK */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 891219 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***REVISION DATE 950126 (YYMMDD) */ +/* ***REVISION DATE 000711 (YYMMDD) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DNSK solves a nonlinear system of */ +/* algebraic equations of the form */ +/* G(X,Y,YPRIME) = 0 for the unknown Y. */ + +/* The method used is a modified Newton scheme. */ + +/* The parameters represent */ + +/* X -- Independent variable. */ +/* Y -- Solution vector. */ +/* YPRIME -- Derivative of solution vector. */ +/* NEQ -- Number of unknowns. */ +/* RES -- External user-supplied subroutine */ +/* to evaluate the residual. See RES description */ +/* in DDASPK prologue. */ +/* PSOL -- External user-supplied routine to solve */ +/* a linear system using preconditioning. */ +/* See explanation inside DDASPK. */ +/* WT -- Vector of weights for error criterion. */ +/* RPAR,IPAR -- Real and integer arrays used for communication */ +/* between the calling program and external user */ +/* routines. They are not altered within DASPK. */ +/* SAVR -- Work vector for DNSK of length NEQ. */ +/* DELTA -- Work vector for DNSK of length NEQ. */ +/* E -- Error accumulation vector for DNSK of length NEQ. */ +/* WM,IWM -- Real and integer arrays storing */ +/* matrix information such as the matrix */ +/* of partial derivatives, permutation */ +/* vector, and various other information. */ +/* CJ -- Parameter always proportional to 1/H (step size). */ +/* SQRTN -- Square root of NEQ. */ +/* RSQRTN -- reciprical of square root of NEQ. */ +/* EPLIN -- Tolerance for linear system solver. */ +/* EPCON -- Tolerance to test for convergence of the Newton */ +/* iteration. */ +/* S -- Used for error convergence tests. */ +/* In the Newton iteration: S = RATE/(1.D0-RATE), */ +/* where RATE is the estimated rate of convergence */ +/* of the Newton iteration. */ + +/* The closer RATE is to 0., the faster the Newton */ +/* iteration is converging; the closer RATE is to 1., */ +/* the slower the Newton iteration is converging. */ + +/* The calling routine sends the initial value */ +/* of S to the Newton iteration. */ +/* CONFAC -- A residual scale factor to improve convergence. */ +/* TOLNEW -- Tolerance on the norm of Newton correction in */ +/* alternative Newton convergence test. */ +/* MULDEL -- A flag indicating whether or not to multiply */ +/* DELTA by CONFAC. */ +/* 0 ==> do not scale DELTA by CONFAC. */ +/* 1 ==> scale DELTA by CONFAC. */ +/* MAXIT -- Maximum allowed number of Newton iterations. */ +/* IRES -- Error flag returned from RES. See RES description */ +/* in DDASPK prologue. If IRES = -1, then IERNEW */ +/* will be set to 1. */ +/* If IRES < -1, then IERNEW will be set to -1. */ +/* IERSL -- Error flag for linear system solver. */ +/* See IERSL description in subroutine DSLVK. */ +/* If IERSL = 1, then IERNEW will be set to 1. */ +/* If IERSL < 0, then IERNEW will be set to -1. */ +/* IERNEW -- Error flag for Newton iteration. */ +/* 0 ==> Newton iteration converged. */ +/* 1 ==> recoverable error inside Newton iteration. */ +/* -1 ==> unrecoverable error inside Newton iteration. */ +/* ----------------------------------------------------------------------- */ + +/* ***ROUTINES CALLED */ +/* RES, DSLVK, DDWNRM */ + +/* ***END PROLOGUE DNSK */ + + + + +/* Initialize Newton counter M and accumulation vector E. */ + + /* Parameter adjustments */ + --iwm; + --wm; + --e; + --delta; + --savr; + --ipar; + --rpar; + --wt; + --yprime; + --y; + + /* Function Body */ + m = 0; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L100: */ + e[i__] = 0.; + } + +/* Corrector loop. */ + +L300: + ++iwm[19]; + +/* If necessary, multiply residual by convergence factor. */ + + if (*muldel == 1) { + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L320: */ + delta[i__] *= *confac; + } + } + +/* Save residual in SAVR. */ + + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L340: */ + savr[i__] = delta[i__]; + } + +/* Compute a new iterate. Store the correction in DELTA. */ + + dslvk_(neq, &y[1], x, &yprime[1], &savr[1], &delta[1], &wt[1], &wm[1], & + iwm[1], (S_fp)res, ires, (U_fp)psol, iersl, cj, eplin, sqrtn, + rsqrtn, &rhok, &rpar[1], &ipar[1]); + if (*ires != 0 || *iersl != 0) { + goto L380; + } + +/* Update Y, E, and YPRIME. */ + + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + y[i__] -= delta[i__]; + e[i__] -= delta[i__]; +/* L360: */ + yprime[i__] -= *cj * delta[i__]; + } + +/* Test for convergence of the iteration. */ + + delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); + if (m == 0) { + oldnrm = delnrm; + if (delnrm <= *tolnew) { + goto L370; + } + } else { + d__1 = delnrm / oldnrm; + d__2 = 1. / m; + rate = pow_dd(&d__1, &d__2); + if (rate > .9) { + goto L380; + } + *s = rate / (1. - rate); + } + if (*s * delnrm <= *epcon) { + goto L370; + } + +/* The corrector has not yet converged. Update M and test whether */ +/* the maximum number of iterations have been tried. */ + + ++m; + if (m >= *maxit) { + goto L380; + } + +/* Evaluate the residual, and go back to do another iteration. */ + + ++iwm[12]; + (*res)(x, &y[1], &yprime[1], cj, &delta[1], ires, &rpar[1], &ipar[1]); + if (*ires < 0) { + goto L380; + } + goto L300; + +/* The iteration has converged. */ + +L370: + return 0; + +/* The iteration has not converged. Set IERNEW appropriately. */ + +L380: + if (*ires <= -2 || *iersl < 0) { + *iernew = -1; + } else { + *iernew = 1; + } + return 0; + + +/* ------END OF SUBROUTINE DNSK------------------------------------------- */ +} /* dnsk_ */ + +/* Subroutine */ int dslvk_(integer *neq, doublereal *y, doublereal *tn, + doublereal *yprime, doublereal *savr, doublereal *x, doublereal *ewt, + doublereal *wm, integer *iwm, S_fp res, integer *ires, U_fp psol, + integer *iersl, doublereal *cj, doublereal *eplin, doublereal *sqrtn, + doublereal *rsqrtn, doublereal *rhok, doublereal *rpar, integer *ipar) +{ + /* Initialized data */ + + static integer irst = 1; + + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + static integer i__, lq, lr, lv, lz, ldl, nli, nre, kmp, lwk, nps, lwp, + ncfl, lhes, lgmr, maxl, nres, npsl, liwp, iflag; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dcopy_(integer *, doublereal *, integer *, doublereal + *, integer *); + static integer miter, nrmax, nrsts, maxlp1; + extern /* Subroutine */ int dspigm_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer * + , integer *, integer *, doublereal *, doublereal *, S_fp, integer + *, integer *, U_fp, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, doublereal *, integer *); + + +/* ***BEGIN PROLOGUE DSLVK */ +/* ***REFER TO DDASPK */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***REVISION DATE 940928 Removed MNEWT and added RHOK in call list. */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* DSLVK uses a restart algorithm and interfaces to DSPIGM for */ +/* the solution of the linear system arising from a Newton iteration. */ + +/* In addition to variables described elsewhere, */ +/* communication with DSLVK uses the following variables.. */ +/* WM = Real work space containing data for the algorithm */ +/* (Krylov basis vectors, Hessenberg matrix, etc.). */ +/* IWM = Integer work space containing data for the algorithm. */ +/* X = The right-hand side vector on input, and the solution vector */ +/* on output, of length NEQ. */ +/* IRES = Error flag from RES. */ +/* IERSL = Output flag .. */ +/* IERSL = 0 means no trouble occurred (or user RES routine */ +/* returned IRES < 0) */ +/* IERSL = 1 means the iterative method failed to converge */ +/* (DSPIGM returned IFLAG > 0.) */ +/* IERSL = -1 means there was a nonrecoverable error in the */ +/* iterative solver, and an error exit will occur. */ +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* DSCAL, DCOPY, DSPIGM */ + +/* ***END PROLOGUE DSLVK */ + + + + +/* ----------------------------------------------------------------------- */ +/* IRST is set to 1, to indicate restarting is in effect. */ +/* NRMAX is the maximum number of restarts. */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --ipar; + --rpar; + --iwm; + --wm; + --ewt; + --x; + --savr; + --yprime; + --y; + + /* Function Body */ + + liwp = iwm[30]; + nli = iwm[20]; + nps = iwm[21]; + ncfl = iwm[16]; + nre = iwm[12]; + lwp = iwm[29]; + maxl = iwm[24]; + kmp = iwm[25]; + nrmax = iwm[26]; + miter = iwm[23]; + *iersl = 0; + *ires = 0; +/* ----------------------------------------------------------------------- */ +/* Use a restarting strategy to solve the linear system */ +/* P*X = -F. Parse the work vector, and perform initializations. */ +/* Note that zero is the initial guess for X. */ +/* ----------------------------------------------------------------------- */ + maxlp1 = maxl + 1; + lv = 1; + lr = lv + *neq * maxl; + lhes = lr + *neq + 1; + lq = lhes + maxl * maxlp1; + lwk = lq + (maxl << 1); +/* Computing MIN */ + i__1 = 1, i__2 = maxl - kmp; + ldl = lwk + min(i__1,i__2) * *neq; + lz = ldl + *neq; + dscal_(neq, rsqrtn, &ewt[1], &c__1); + dcopy_(neq, &x[1], &c__1, &wm[lr], &c__1); + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L110: */ + x[i__] = 0.; + } +/* ----------------------------------------------------------------------- */ +/* Top of loop for the restart algorithm. Initial pass approximates */ +/* X and sets up a transformed system to perform subsequent restarts */ +/* to update X. NRSTS is initialized to -1, because restarting */ +/* does not occur until after the first pass. */ +/* Update NRSTS; conditionally copy DL to R; call the DSPIGM */ +/* algorithm to solve A*Z = R; updated counters; update X with */ +/* the residual solution. */ +/* Note: if convergence is not achieved after NRMAX restarts, */ +/* then the linear solver is considered to have failed. */ +/* ----------------------------------------------------------------------- */ + nrsts = -1; +L115: + ++nrsts; + if (nrsts > 0) { + dcopy_(neq, &wm[ldl], &c__1, &wm[lr], &c__1); + } + dspigm_(neq, tn, &y[1], &yprime[1], &savr[1], &wm[lr], &ewt[1], &maxl, & + maxlp1, &kmp, eplin, cj, (S_fp)res, ires, &nres, (U_fp)psol, & + npsl, &wm[lz], &wm[lv], &wm[lhes], &wm[lq], &lgmr, &wm[lwp], &iwm[ + liwp], &wm[lwk], &wm[ldl], rhok, &iflag, &irst, &nrsts, &rpar[1], + &ipar[1]); + nli += lgmr; + nps += npsl; + nre += nres; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L120: */ + x[i__] += wm[lz + i__ - 1]; + } + if (iflag == 1 && nrsts < nrmax && *ires == 0) { + goto L115; + } +/* ----------------------------------------------------------------------- */ +/* The restart scheme is finished. Test IRES and IFLAG to see if */ +/* convergence was not achieved, and set flags accordingly. */ +/* ----------------------------------------------------------------------- */ + if (*ires < 0) { + ++ncfl; + } else if (iflag != 0) { + ++ncfl; + if (iflag > 0) { + *iersl = 1; + } + if (iflag < 0) { + *iersl = -1; + } + } +/* ----------------------------------------------------------------------- */ +/* Update IWM with counters, rescale EWT, and return. */ +/* ----------------------------------------------------------------------- */ + iwm[20] = nli; + iwm[21] = nps; + iwm[16] = ncfl; + iwm[12] = nre; + dscal_(neq, sqrtn, &ewt[1], &c__1); + return 0; + +/* ------END OF SUBROUTINE DSLVK------------------------------------------ */ +} /* dslvk_ */ + +/* Subroutine */ int dspigm_(integer *neq, doublereal *tn, doublereal *y, + doublereal *yprime, doublereal *savr, doublereal *r__, doublereal * + wght, integer *maxl, integer *maxlp1, integer *kmp, doublereal *eplin, + doublereal *cj, S_fp res, integer *ires, integer *nre, S_fp psol, + integer *npsl, doublereal *z__, doublereal *v, doublereal *hes, + doublereal *q, integer *lgmr, doublereal *wp, integer *iwp, + doublereal *wk, doublereal *dl, doublereal *rhok, integer *iflag, + integer *irst, integer *nrsts, doublereal *rpar, integer *ipar) +{ + /* System generated locals */ + integer v_dim1, v_offset, hes_dim1, hes_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + static doublereal c__; + static integer i__, j, k; + static doublereal s; + static integer i2, ll, ip1, ier; + static doublereal tem, rho; + static integer llp1, info; + extern /* Subroutine */ int datv_(integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, S_fp, integer *, S_fp, doublereal *, doublereal *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + integer *, integer *, doublereal *, integer *); + static doublereal prod, rnrm; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dhels_(doublereal *, integer *, integer *, doublereal + *, doublereal *), dheqr_(doublereal *, integer *, integer *, + doublereal *, integer *, integer *); + static doublereal dlnrm; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dorth_(doublereal *, doublereal *, + doublereal *, integer *, integer *, integer *, integer *, + doublereal *), daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + static integer maxlm1; + static doublereal snormw; + + +/* ***BEGIN PROLOGUE DSPIGM */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ +/* ***REVISION DATE 940927 Removed MNEWT and added RHOK in call list. */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* This routine solves the linear system A * Z = R using a scaled */ +/* preconditioned version of the generalized minimum residual method. */ +/* An initial guess of Z = 0 is assumed. */ + +/* On entry */ + +/* NEQ = Problem size, passed to PSOL. */ + +/* TN = Current Value of T. */ + +/* Y = Array Containing current dependent variable vector. */ + +/* YPRIME = Array Containing current first derivative of Y. */ + +/* SAVR = Array containing current value of G(T,Y,YPRIME). */ + +/* R = The right hand side of the system A*Z = R. */ +/* R is also used as work space when computing */ +/* the final approximation and will therefore be */ +/* destroyed. */ +/* (R is the same as V(*,MAXL+1) in the call to DSPIGM.) */ + +/* WGHT = The vector of length NEQ containing the nonzero */ +/* elements of the diagonal scaling matrix. */ + +/* MAXL = The maximum allowable order of the matrix H. */ + +/* MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. */ + +/* KMP = The number of previous vectors the new vector, VNEW, */ +/* must be made orthogonal to. (KMP .LE. MAXL.) */ + +/* EPLIN = Tolerance on residuals R-A*Z in weighted rms norm. */ + +/* CJ = Scalar proportional to current value of */ +/* 1/(step size H). */ + +/* WK = Real work array used by routine DATV and PSOL. */ + +/* DL = Real work array used for calculation of the residual */ +/* norm RHO when the method is incomplete (KMP.LT.MAXL) */ +/* and/or when using restarting. */ + +/* WP = Real work array used by preconditioner PSOL. */ + +/* IWP = Integer work array used by preconditioner PSOL. */ + +/* IRST = Method flag indicating if restarting is being */ +/* performed. IRST .GT. 0 means restarting is active, */ +/* while IRST = 0 means restarting is not being used. */ + +/* NRSTS = Counter for the number of restarts on the current */ +/* call to DSPIGM. If NRSTS .GT. 0, then the residual */ +/* R is already scaled, and so scaling of R is not */ +/* necessary. */ + + +/* On Return */ + +/* Z = The final computed approximation to the solution */ +/* of the system A*Z = R. */ + +/* LGMR = The number of iterations performed and */ +/* the current order of the upper Hessenberg */ +/* matrix HES. */ + +/* NRE = The number of calls to RES (i.e. DATV) */ + +/* NPSL = The number of calls to PSOL. */ + +/* V = The neq by (LGMR+1) array containing the LGMR */ +/* orthogonal vectors V(*,1) to V(*,LGMR). */ + +/* HES = The upper triangular factor of the QR decomposition */ +/* of the (LGMR+1) by LGMR upper Hessenberg matrix whose */ +/* entries are the scaled inner-products of A*V(*,I) */ +/* and V(*,K). */ + +/* Q = Real array of length 2*MAXL containing the components */ +/* of the givens rotations used in the QR decomposition */ +/* of HES. It is loaded in DHEQR and used in DHELS. */ + +/* IRES = Error flag from RES. */ + +/* DL = Scaled preconditioned residual, */ +/* (D-inverse)*(P-inverse)*(R-A*Z). Only loaded when */ +/* performing restarts of the Krylov iteration. */ + +/* RHOK = Weighted norm of final preconditioned residual. */ + +/* IFLAG = Integer error flag.. */ +/* 0 Means convergence in LGMR iterations, LGMR.LE.MAXL. */ +/* 1 Means the convergence test did not pass in MAXL */ +/* iterations, but the new residual norm (RHO) is */ +/* .LT. the old residual norm (RNRM), and so Z is */ +/* computed. */ +/* 2 Means the convergence test did not pass in MAXL */ +/* iterations, new residual norm (RHO) .GE. old residual */ +/* norm (RNRM), and the initial guess, Z = 0, is */ +/* returned. */ +/* 3 Means there was a recoverable error in PSOL */ +/* caused by the preconditioner being out of date. */ +/* -1 Means there was an unrecoverable error in PSOL. */ + +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* PSOL, DNRM2, DSCAL, DATV, DORTH, DHEQR, DCOPY, DHELS, DAXPY */ + +/* ***END PROLOGUE DSPIGM */ + + + /* Parameter adjustments */ + v_dim1 = *neq; + v_offset = 1 + v_dim1; + v -= v_offset; + --y; + --yprime; + --savr; + --r__; + --wght; + hes_dim1 = *maxlp1; + hes_offset = 1 + hes_dim1; + hes -= hes_offset; + --z__; + --q; + --wp; + --iwp; + --wk; + --dl; + --rpar; + --ipar; + + /* Function Body */ + ier = 0; + *iflag = 0; + *lgmr = 0; + *npsl = 0; + *nre = 0; +/* ----------------------------------------------------------------------- */ +/* The initial guess for Z is 0. The initial residual is therefore */ +/* the vector R. Initialize Z to 0. */ +/* ----------------------------------------------------------------------- */ + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L10: */ + z__[i__] = 0.; + } +/* ----------------------------------------------------------------------- */ +/* Apply inverse of left preconditioner to vector R if NRSTS .EQ. 0. */ +/* Form V(*,1), the scaled preconditioned right hand side. */ +/* ----------------------------------------------------------------------- */ + if (*nrsts == 0) { + (*psol)(neq, tn, &y[1], &yprime[1], &savr[1], &wk[1], cj, &wght[1], & + wp[1], &iwp[1], &r__[1], eplin, &ier, &rpar[1], &ipar[1]); + *npsl = 1; + if (ier != 0) { + goto L300; + } + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L30: */ + v[i__ + v_dim1] = r__[i__] * wght[i__]; + } + } else { + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L35: */ + v[i__ + v_dim1] = r__[i__]; + } + } +/* ----------------------------------------------------------------------- */ +/* Calculate norm of scaled vector V(*,1) and normalize it */ +/* If, however, the norm of V(*,1) (i.e. the norm of the preconditioned */ +/* residual) is .le. EPLIN, then return with Z=0. */ +/* ----------------------------------------------------------------------- */ + rnrm = dnrm2_(neq, &v[v_offset], &c__1); + if (rnrm <= *eplin) { + *rhok = rnrm; + return 0; + } + tem = 1. / rnrm; + dscal_(neq, &tem, &v[v_dim1 + 1], &c__1); +/* ----------------------------------------------------------------------- */ +/* Zero out the HES array. */ +/* ----------------------------------------------------------------------- */ + i__1 = *maxl; + for (j = 1; j <= i__1; ++j) { + i__2 = *maxlp1; + for (i__ = 1; i__ <= i__2; ++i__) { +/* L60: */ + hes[i__ + j * hes_dim1] = 0.; + } +/* L65: */ + } +/* ----------------------------------------------------------------------- */ +/* Main loop to compute the vectors V(*,2) to V(*,MAXL). */ +/* The running product PROD is needed for the convergence test. */ +/* ----------------------------------------------------------------------- */ + prod = 1.; + i__1 = *maxl; + for (ll = 1; ll <= i__1; ++ll) { + *lgmr = ll; +/* ----------------------------------------------------------------------- */ +/* Call routine DATV to compute VNEW = ABAR*V(LL), where ABAR is */ +/* the matrix A with scaling and inverse preconditioner factors applied. */ +/* Call routine DORTH to orthogonalize the new vector VNEW = V(*,LL+1). */ +/* call routine DHEQR to update the factors of HES. */ +/* ----------------------------------------------------------------------- */ + datv_(neq, &y[1], tn, &yprime[1], &savr[1], &v[ll * v_dim1 + 1], & + wght[1], &z__[1], (S_fp)res, ires, (S_fp)psol, &v[(ll + 1) * + v_dim1 + 1], &wk[1], &wp[1], &iwp[1], cj, eplin, &ier, nre, + npsl, &rpar[1], &ipar[1]); + if (*ires < 0) { + return 0; + } + if (ier != 0) { + goto L300; + } + dorth_(&v[(ll + 1) * v_dim1 + 1], &v[v_offset], &hes[hes_offset], neq, + &ll, maxlp1, kmp, &snormw); + hes[ll + 1 + ll * hes_dim1] = snormw; + dheqr_(&hes[hes_offset], maxlp1, &ll, &q[1], &info, &ll); + if (info == ll) { + goto L120; + } +/* ----------------------------------------------------------------------- */ +/* Update RHO, the estimate of the norm of the residual R - A*ZL. */ +/* If KMP .LT. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not */ +/* necessarily orthogonal for LL .GT. KMP. The vector DL must then */ +/* be computed, and its norm used in the calculation of RHO. */ +/* ----------------------------------------------------------------------- */ + prod *= q[ll * 2]; + rho = (d__1 = prod * rnrm, abs(d__1)); + if (ll > *kmp && *kmp < *maxl) { + if (ll == *kmp + 1) { + dcopy_(neq, &v[v_dim1 + 1], &c__1, &dl[1], &c__1); + i__2 = *kmp; + for (i__ = 1; i__ <= i__2; ++i__) { + ip1 = i__ + 1; + i2 = i__ << 1; + s = q[i2]; + c__ = q[i2 - 1]; + i__3 = *neq; + for (k = 1; k <= i__3; ++k) { +/* L70: */ + dl[k] = s * dl[k] + c__ * v[k + ip1 * v_dim1]; + } +/* L75: */ + } + } + s = q[ll * 2]; + c__ = q[(ll << 1) - 1] / snormw; + llp1 = ll + 1; + i__2 = *neq; + for (k = 1; k <= i__2; ++k) { +/* L80: */ + dl[k] = s * dl[k] + c__ * v[k + llp1 * v_dim1]; + } + dlnrm = dnrm2_(neq, &dl[1], &c__1); + rho *= dlnrm; + } +/* ----------------------------------------------------------------------- */ +/* Test for convergence. If passed, compute approximation ZL. */ +/* If failed and LL .LT. MAXL, then continue iterating. */ +/* ----------------------------------------------------------------------- */ + if (rho <= *eplin) { + goto L200; + } + if (ll == *maxl) { + goto L100; + } +/* ----------------------------------------------------------------------- */ +/* Rescale so that the norm of V(1,LL+1) is one. */ +/* ----------------------------------------------------------------------- */ + tem = 1. / snormw; + dscal_(neq, &tem, &v[(ll + 1) * v_dim1 + 1], &c__1); +/* L90: */ + } +L100: + if (rho < rnrm) { + goto L150; + } +L120: + *iflag = 2; + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L130: */ + z__[i__] = 0.; + } + return 0; +L150: + *iflag = 1; +/* ----------------------------------------------------------------------- */ +/* The tolerance was not met, but the residual norm was reduced. */ +/* If performing restarting (IRST .gt. 0) calculate the residual vector */ +/* RL and store it in the DL array. If the incomplete version is */ +/* being used (KMP .lt. MAXL) then DL has already been calculated. */ +/* ----------------------------------------------------------------------- */ + if (*irst > 0) { + if (*kmp == *maxl) { + +/* Calculate DL from the V(I)'s. */ + + dcopy_(neq, &v[v_dim1 + 1], &c__1, &dl[1], &c__1); + maxlm1 = *maxl - 1; + i__1 = maxlm1; + for (i__ = 1; i__ <= i__1; ++i__) { + ip1 = i__ + 1; + i2 = i__ << 1; + s = q[i2]; + c__ = q[i2 - 1]; + i__2 = *neq; + for (k = 1; k <= i__2; ++k) { +/* L170: */ + dl[k] = s * dl[k] + c__ * v[k + ip1 * v_dim1]; + } +/* L175: */ + } + s = q[*maxl * 2]; + c__ = q[(*maxl << 1) - 1] / snormw; + i__1 = *neq; + for (k = 1; k <= i__1; ++k) { +/* L180: */ + dl[k] = s * dl[k] + c__ * v[k + *maxlp1 * v_dim1]; + } + } + +/* Scale DL by RNRM*PROD to obtain the residual RL. */ + + tem = rnrm * prod; + dscal_(neq, &tem, &dl[1], &c__1); + } +/* ----------------------------------------------------------------------- */ +/* Compute the approximation ZL to the solution. */ +/* Since the vector Z was used as work space, and the initial guess */ +/* of the Newton correction is zero, Z must be reset to zero. */ +/* ----------------------------------------------------------------------- */ +L200: + ll = *lgmr; + llp1 = ll + 1; + i__1 = llp1; + for (k = 1; k <= i__1; ++k) { +/* L210: */ + r__[k] = 0.; + } + r__[1] = rnrm; + dhels_(&hes[hes_offset], maxlp1, &ll, &q[1], &r__[1]); + i__1 = *neq; + for (k = 1; k <= i__1; ++k) { +/* L220: */ + z__[k] = 0.; + } + i__1 = ll; + for (i__ = 1; i__ <= i__1; ++i__) { + daxpy_(neq, &r__[i__], &v[i__ * v_dim1 + 1], &c__1, &z__[1], &c__1); +/* L230: */ + } + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L240: */ + z__[i__] /= wght[i__]; + } +/* Load RHO into RHOK. */ + *rhok = rho; + return 0; +/* ----------------------------------------------------------------------- */ +/* This block handles error returns forced by routine PSOL. */ +/* ----------------------------------------------------------------------- */ +L300: + if (ier < 0) { + *iflag = -1; + } + if (ier > 0) { + *iflag = 3; + } + + return 0; + +/* ------END OF SUBROUTINE DSPIGM----------------------------------------- */ +} /* dspigm_ */ + +/* Subroutine */ int datv_(integer *neq, doublereal *y, doublereal *tn, + doublereal *yprime, doublereal *savr, doublereal *v, doublereal *wght, + doublereal *yptem, S_fp res, integer *ires, S_fp psol, doublereal * + z__, doublereal *vtem, doublereal *wp, integer *iwp, doublereal *cj, + doublereal *eplin, integer *ier, integer *nre, integer *npsl, + doublereal *rpar, integer *ipar) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__; + + +/* ***BEGIN PROLOGUE DATV */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* This routine computes the product */ + +/* Z = (D-inverse)*(P-inverse)*(dF/dY)*(D*V), */ + +/* where F(Y) = G(T, Y, CJ*(Y-A)), CJ is a scalar proportional to 1/H, */ +/* and A involves the past history of Y. The quantity CJ*(Y-A) is */ +/* an approximation to the first derivative of Y and is stored */ +/* in the array YPRIME. Note that dF/dY = dG/dY + CJ*dG/dYPRIME. */ + +/* D is a diagonal scaling matrix, and P is the left preconditioning */ +/* matrix. V is assumed to have L2 norm equal to 1. */ +/* The product is stored in Z and is computed by means of a */ +/* difference quotient, a call to RES, and one call to PSOL. */ + +/* On entry */ + +/* NEQ = Problem size, passed to RES and PSOL. */ + +/* Y = Array containing current dependent variable vector. */ + +/* YPRIME = Array containing current first derivative of y. */ + +/* SAVR = Array containing current value of G(T,Y,YPRIME). */ + +/* V = Real array of length NEQ (can be the same array as Z). */ + +/* WGHT = Array of length NEQ containing scale factors. */ +/* 1/WGHT(I) are the diagonal elements of the matrix D. */ + +/* YPTEM = Work array of length NEQ. */ + +/* VTEM = Work array of length NEQ used to store the */ +/* unscaled version of V. */ + +/* WP = Real work array used by preconditioner PSOL. */ + +/* IWP = Integer work array used by preconditioner PSOL. */ + +/* CJ = Scalar proportional to current value of */ +/* 1/(step size H). */ + + +/* On return */ + +/* Z = Array of length NEQ containing desired scaled */ +/* matrix-vector product. */ + +/* IRES = Error flag from RES. */ + +/* IER = Error flag from PSOL. */ + +/* NRE = The number of calls to RES. */ + +/* NPSL = The number of calls to PSOL. */ + +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* RES, PSOL */ + +/* ***END PROLOGUE DATV */ + + + /* Parameter adjustments */ + --ipar; + --rpar; + --iwp; + --wp; + --vtem; + --z__; + --yptem; + --wght; + --v; + --savr; + --yprime; + --y; + + /* Function Body */ + *ires = 0; +/* ----------------------------------------------------------------------- */ +/* Set VTEM = D * V. */ +/* ----------------------------------------------------------------------- */ + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L10: */ + vtem[i__] = v[i__] / wght[i__]; + } + *ier = 0; +/* ----------------------------------------------------------------------- */ +/* Store Y in Z and increment Z by VTEM. */ +/* Store YPRIME in YPTEM and increment YPTEM by VTEM*CJ. */ +/* ----------------------------------------------------------------------- */ + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { + yptem[i__] = yprime[i__] + vtem[i__] * *cj; +/* L20: */ + z__[i__] = y[i__] + vtem[i__]; + } +/* ----------------------------------------------------------------------- */ +/* Call RES with incremented Y, YPRIME arguments */ +/* stored in Z, YPTEM. VTEM is overwritten with new residual. */ +/* ----------------------------------------------------------------------- */ + (*res)(tn, &z__[1], &yptem[1], cj, &vtem[1], ires, &rpar[1], &ipar[1]); + ++(*nre); + if (*ires < 0) { + return 0; + } +/* ----------------------------------------------------------------------- */ +/* Set Z = (dF/dY) * VBAR using difference quotient. */ +/* (VBAR is old value of VTEM before calling RES) */ +/* ----------------------------------------------------------------------- */ + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L70: */ + z__[i__] = vtem[i__] - savr[i__]; + } +/* ----------------------------------------------------------------------- */ +/* Apply inverse of left preconditioner to Z. */ +/* ----------------------------------------------------------------------- */ + (*psol)(neq, tn, &y[1], &yprime[1], &savr[1], &yptem[1], cj, &wght[1], & + wp[1], &iwp[1], &z__[1], eplin, ier, &rpar[1], &ipar[1]); + ++(*npsl); + if (*ier != 0) { + return 0; + } +/* ----------------------------------------------------------------------- */ +/* Apply D-inverse to Z and return. */ +/* ----------------------------------------------------------------------- */ + i__1 = *neq; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L90: */ + z__[i__] *= wght[i__]; + } + return 0; + +/* ------END OF SUBROUTINE DATV------------------------------------------- */ +} /* datv_ */ + +/* Subroutine */ int dorth_(doublereal *vnew, doublereal *v, doublereal *hes, + integer *n, integer *ll, integer *ldhes, integer *kmp, doublereal * + snormw) +{ + /* System generated locals */ + integer v_dim1, v_offset, hes_dim1, hes_offset, i__1, i__2; + doublereal d__1, d__2, d__3; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static integer i__, i0; + static doublereal arg, tem; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + static doublereal vnrm; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + static doublereal sumdsq; + + +/* ***BEGIN PROLOGUE DORTH */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* This routine orthogonalizes the vector VNEW against the previous */ +/* KMP vectors in the V array. It uses a modified Gram-Schmidt */ +/* orthogonalization procedure with conditional reorthogonalization. */ + +/* On entry */ + +/* VNEW = The vector of length N containing a scaled product */ +/* OF The Jacobian and the vector V(*,LL). */ + +/* V = The N x LL array containing the previous LL */ +/* orthogonal vectors V(*,1) to V(*,LL). */ + +/* HES = An LL x LL upper Hessenberg matrix containing, */ +/* in HES(I,K), K.LT.LL, scaled inner products of */ +/* A*V(*,K) and V(*,I). */ + +/* LDHES = The leading dimension of the HES array. */ + +/* N = The order of the matrix A, and the length of VNEW. */ + +/* LL = The current order of the matrix HES. */ + +/* KMP = The number of previous vectors the new vector VNEW */ +/* must be made orthogonal to (KMP .LE. MAXL). */ + + +/* On return */ + +/* VNEW = The new vector orthogonal to V(*,I0), */ +/* where I0 = MAX(1, LL-KMP+1). */ + +/* HES = Upper Hessenberg matrix with column LL filled in with */ +/* scaled inner products of A*V(*,LL) and V(*,I). */ + +/* SNORMW = L-2 norm of VNEW. */ + +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* DDOT, DNRM2, DAXPY */ + +/* ***END PROLOGUE DORTH */ + + +/* ----------------------------------------------------------------------- */ +/* Get norm of unaltered VNEW for later use. */ +/* ----------------------------------------------------------------------- */ + /* Parameter adjustments */ + --vnew; + v_dim1 = *n; + v_offset = 1 + v_dim1; + v -= v_offset; + hes_dim1 = *ldhes; + hes_offset = 1 + hes_dim1; + hes -= hes_offset; + + /* Function Body */ + vnrm = dnrm2_(n, &vnew[1], &c__1); +/* ----------------------------------------------------------------------- */ +/* Do Modified Gram-Schmidt on VNEW = A*V(LL). */ +/* Scaled inner products give new column of HES. */ +/* Projections of earlier vectors are subtracted from VNEW. */ +/* ----------------------------------------------------------------------- */ +/* Computing MAX */ + i__1 = 1, i__2 = *ll - *kmp + 1; + i0 = max(i__1,i__2); + i__1 = *ll; + for (i__ = i0; i__ <= i__1; ++i__) { + hes[i__ + *ll * hes_dim1] = ddot_(n, &v[i__ * v_dim1 + 1], &c__1, & + vnew[1], &c__1); + tem = -hes[i__ + *ll * hes_dim1]; + daxpy_(n, &tem, &v[i__ * v_dim1 + 1], &c__1, &vnew[1], &c__1); +/* L10: */ + } +/* ----------------------------------------------------------------------- */ +/* Compute SNORMW = norm of VNEW. */ +/* If VNEW is small compared to its input value (in norm), then */ +/* Reorthogonalize VNEW to V(*,1) through V(*,LL). */ +/* Correct if relative correction exceeds 1000*(unit roundoff). */ +/* Finally, correct SNORMW using the dot products involved. */ +/* ----------------------------------------------------------------------- */ + *snormw = dnrm2_(n, &vnew[1], &c__1); + if (vnrm + *snormw * .001 != vnrm) { + return 0; + } + sumdsq = 0.; + i__1 = *ll; + for (i__ = i0; i__ <= i__1; ++i__) { + tem = -ddot_(n, &v[i__ * v_dim1 + 1], &c__1, &vnew[1], &c__1); + if (hes[i__ + *ll * hes_dim1] + tem * .001 == hes[i__ + *ll * + hes_dim1]) { + goto L30; + } + hes[i__ + *ll * hes_dim1] -= tem; + daxpy_(n, &tem, &v[i__ * v_dim1 + 1], &c__1, &vnew[1], &c__1); +/* Computing 2nd power */ + d__1 = tem; + sumdsq += d__1 * d__1; +L30: + ; + } + if (sumdsq == 0.) { + return 0; + } +/* Computing MAX */ +/* Computing 2nd power */ + d__3 = *snormw; + d__1 = 0., d__2 = d__3 * d__3 - sumdsq; + arg = max(d__1,d__2); + *snormw = sqrt(arg); + return 0; + +/* ------END OF SUBROUTINE DORTH------------------------------------------ */ +} /* dorth_ */ + +/* Subroutine */ int dheqr_(doublereal *a, integer *lda, integer *n, + doublereal *q, integer *info, integer *ijob) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static doublereal c__; + static integer i__, j, k; + static doublereal s, t, t1, t2; + static integer iq, km1, kp1, nm1; + + +/* ***BEGIN PROLOGUE DHEQR */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* This routine performs a QR decomposition of an upper */ +/* Hessenberg matrix A. There are two options available: */ + +/* (1) performing a fresh decomposition */ +/* (2) updating the QR factors by adding a row and A */ +/* column to the matrix A. */ + +/* DHEQR decomposes an upper Hessenberg matrix by using Givens */ +/* rotations. */ + +/* On entry */ + +/* A DOUBLE PRECISION(LDA, N) */ +/* The matrix to be decomposed. */ + +/* LDA INTEGER */ +/* The leading dimension of the array A. */ + +/* N INTEGER */ +/* A is an (N+1) by N Hessenberg matrix. */ + +/* IJOB INTEGER */ +/* = 1 Means that a fresh decomposition of the */ +/* matrix A is desired. */ +/* .GE. 2 Means that the current decomposition of A */ +/* will be updated by the addition of a row */ +/* and a column. */ +/* On return */ + +/* A The upper triangular matrix R. */ +/* The factorization can be written Q*A = R, where */ +/* Q is a product of Givens rotations and R is upper */ +/* triangular. */ + +/* Q DOUBLE PRECISION(2*N) */ +/* The factors C and S of each Givens rotation used */ +/* in decomposing A. */ + +/* INFO INTEGER */ +/* = 0 normal value. */ +/* = K If A(K,K) .EQ. 0.0. This is not an error */ +/* condition for this subroutine, but it does */ +/* indicate that DHELS will divide by zero */ +/* if called. */ + +/* Modification of LINPACK. */ +/* Peter Brown, Lawrence Livermore Natl. Lab. */ + +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED (NONE) */ + +/* ***END PROLOGUE DHEQR */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --q; + + /* Function Body */ + if (*ijob > 1) { + goto L70; + } +/* ----------------------------------------------------------------------- */ +/* A new factorization is desired. */ +/* ----------------------------------------------------------------------- */ + +/* QR decomposition without pivoting. */ + + *info = 0; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + km1 = k - 1; + kp1 = k + 1; + +/* Compute Kth column of R. */ +/* First, multiply the Kth column of A by the previous */ +/* K-1 Givens rotations. */ + + if (km1 < 1) { + goto L20; + } + i__2 = km1; + for (j = 1; j <= i__2; ++j) { + i__ = (j - 1 << 1) + 1; + t1 = a[j + k * a_dim1]; + t2 = a[j + 1 + k * a_dim1]; + c__ = q[i__]; + s = q[i__ + 1]; + a[j + k * a_dim1] = c__ * t1 - s * t2; + a[j + 1 + k * a_dim1] = s * t1 + c__ * t2; +/* L10: */ + } + +/* Compute Givens components C and S. */ + +L20: + iq = (km1 << 1) + 1; + t1 = a[k + k * a_dim1]; + t2 = a[kp1 + k * a_dim1]; + if (t2 != 0.) { + goto L30; + } + c__ = 1.; + s = 0.; + goto L50; +L30: + if (abs(t2) < abs(t1)) { + goto L40; + } + t = t1 / t2; + s = -1. / sqrt(t * t + 1.); + c__ = -s * t; + goto L50; +L40: + t = t2 / t1; + c__ = 1. / sqrt(t * t + 1.); + s = -c__ * t; +L50: + q[iq] = c__; + q[iq + 1] = s; + a[k + k * a_dim1] = c__ * t1 - s * t2; + if (a[k + k * a_dim1] == 0.) { + *info = k; + } +/* L60: */ + } + return 0; +/* ----------------------------------------------------------------------- */ +/* The old factorization of A will be updated. A row and a column */ +/* has been added to the matrix A. */ +/* N by N-1 is now the old size of the matrix. */ +/* ----------------------------------------------------------------------- */ +L70: + nm1 = *n - 1; +/* ----------------------------------------------------------------------- */ +/* Multiply the new column by the N previous Givens rotations. */ +/* ----------------------------------------------------------------------- */ + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + i__ = (k - 1 << 1) + 1; + t1 = a[k + *n * a_dim1]; + t2 = a[k + 1 + *n * a_dim1]; + c__ = q[i__]; + s = q[i__ + 1]; + a[k + *n * a_dim1] = c__ * t1 - s * t2; + a[k + 1 + *n * a_dim1] = s * t1 + c__ * t2; +/* L100: */ + } +/* ----------------------------------------------------------------------- */ +/* Complete update of decomposition by forming last Givens rotation, */ +/* and multiplying it times the column vector (A(N,N),A(NP1,N)). */ +/* ----------------------------------------------------------------------- */ + *info = 0; + t1 = a[*n + *n * a_dim1]; + t2 = a[*n + 1 + *n * a_dim1]; + if (t2 != 0.) { + goto L110; + } + c__ = 1.; + s = 0.; + goto L130; +L110: + if (abs(t2) < abs(t1)) { + goto L120; + } + t = t1 / t2; + s = -1. / sqrt(t * t + 1.); + c__ = -s * t; + goto L130; +L120: + t = t2 / t1; + c__ = 1. / sqrt(t * t + 1.); + s = -c__ * t; +L130: + iq = (*n << 1) - 1; + q[iq] = c__; + q[iq + 1] = s; + a[*n + *n * a_dim1] = c__ * t1 - s * t2; + if (a[*n + *n * a_dim1] == 0.) { + *info = *n; + } + return 0; + +/* ------END OF SUBROUTINE DHEQR------------------------------------------ */ +} /* dheqr_ */ + +/* Subroutine */ int dhels_(doublereal *a, integer *lda, integer *n, + doublereal *q, doublereal *b) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + static doublereal c__; + static integer k; + static doublereal s, t, t1, t2; + static integer kb, iq, kp1; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + + +/* ***BEGIN PROLOGUE DHELS */ +/* ***DATE WRITTEN 890101 (YYMMDD) */ +/* ***REVISION DATE 900926 (YYMMDD) */ + + +/* ----------------------------------------------------------------------- */ +/* ***DESCRIPTION */ + +/* This is similar to the LINPACK routine DGESL except that */ +/* A is an upper Hessenberg matrix. */ + +/* DHELS solves the least squares problem */ + +/* MIN (B-A*X,B-A*X) */ + +/* using the factors computed by DHEQR. */ + +/* On entry */ + +/* A DOUBLE PRECISION (LDA, N) */ +/* The output from DHEQR which contains the upper */ +/* triangular factor R in the QR decomposition of A. */ + +/* LDA INTEGER */ +/* The leading dimension of the array A . */ + +/* N INTEGER */ +/* A is originally an (N+1) by N matrix. */ + +/* Q DOUBLE PRECISION(2*N) */ +/* The coefficients of the N givens rotations */ +/* used in the QR factorization of A. */ + +/* B DOUBLE PRECISION(N+1) */ +/* The right hand side vector. */ + + +/* On return */ + +/* B The solution vector X. */ + + +/* Modification of LINPACK. */ +/* Peter Brown, Lawrence Livermore Natl. Lab. */ + +/* ----------------------------------------------------------------------- */ +/* ***ROUTINES CALLED */ +/* DAXPY */ + +/* ***END PROLOGUE DHELS */ + + +/* Minimize (B-A*X,B-A*X). */ +/* First form Q*B. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --q; + --b; + + /* Function Body */ + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + iq = (k - 1 << 1) + 1; + c__ = q[iq]; + s = q[iq + 1]; + t1 = b[k]; + t2 = b[kp1]; + b[k] = c__ * t1 - s * t2; + b[kp1] = s * t1 + c__ * t2; +/* L20: */ + } + +/* Now solve R*X = Q*B. */ + + i__1 = *n; + for (kb = 1; kb <= i__1; ++kb) { + k = *n + 1 - kb; + b[k] /= a[k + k * a_dim1]; + t = -b[k]; + i__2 = k - 1; + daxpy_(&i__2, &t, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1); +/* L40: */ + } + return 0; + +/* ------END OF SUBROUTINE DHELS------------------------------------------ */ +} /* dhels_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/dgbefa.c b/ext/f2c_math/dgbefa.c new file mode 100644 index 000000000..377c589ca --- /dev/null +++ b/ext/f2c_math/dgbefa.c @@ -0,0 +1,253 @@ +/* dgbefa.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__1 = 1; + +/* Subroutine */ int dgbfa_(doublereal *abd, integer *lda, integer *n, + integer *ml, integer *mu, integer *ipvt, integer *info) +{ + /* System generated locals */ + integer abd_dim1, abd_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + static integer i__, j, k, l, m; + static doublereal t; + static integer i0, j0, j1, lm, mm, ju, jz, kp1, nm1; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), daxpy_(integer *, doublereal *, doublereal *, integer + *, doublereal *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + + +/* dgbfa factors a double precision band matrix by elimination. */ + +/* dgbfa is usually called by dgbco, but it can be called */ +/* directly with a saving in time if rcond is not needed. */ + +/* on entry */ + +/* abd double precision(lda, n) */ +/* contains the matrix in band storage. the columns */ +/* of the matrix are stored in the columns of abd and */ +/* the diagonals of the matrix are stored in rows */ +/* ml+1 through 2*ml+mu+1 of abd . */ +/* see the comments below for details. */ + +/* lda integer */ +/* the leading dimension of the array abd . */ +/* lda must be .ge. 2*ml + mu + 1 . */ + +/* n integer */ +/* the order of the original matrix. */ + +/* ml integer */ +/* number of diagonals below the main diagonal. */ +/* 0 .le. ml .lt. n . */ + +/* mu integer */ +/* number of diagonals above the main diagonal. */ +/* 0 .le. mu .lt. n . */ +/* more efficient if ml .le. mu . */ +/* on return */ + +/* abd an upper triangular matrix in band storage and */ +/* the multipliers which were used to obtain it. */ +/* the factorization can be written a = l*u where */ +/* l is a product of permutation and unit lower */ +/* triangular matrices and u is upper triangular. */ + +/* ipvt integer(n) */ +/* an integer vector of pivot indices. */ + +/* info integer */ +/* = 0 normal value. */ +/* = k if u(k,k) .eq. 0.0 . this is not an error */ +/* condition for this subroutine, but it does */ +/* indicate that dgbsl will divide by zero if */ +/* called. use rcond in dgbco for a reliable */ +/* indication of singularity. */ + +/* 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) */ +/* m = ml + mu + 1 */ +/* do 20 j = 1, n */ +/* i1 = max0(1, j-mu) */ +/* i2 = min0(n, j+ml) */ +/* do 10 i = i1, i2 */ +/* k = i - j + m */ +/* abd(k,j) = a(i,j) */ +/* 10 continue */ +/* 20 continue */ + +/* this uses rows ml+1 through 2*ml+mu+1 of abd . */ +/* in addition, the first ml rows in abd are used for */ +/* elements generated during the triangularization. */ +/* the total number of rows needed in abd is 2*ml+mu+1 . */ +/* the ml+mu by ml+mu upper left triangle and the */ +/* ml by ml lower right triangle are not referenced. */ + +/* linpack. this version dated 08/14/78 . */ +/* cleve moler, university of new mexico, argonne national lab. */ + +/* subroutines and functions */ + +/* blas daxpy,dscal,idamax */ +/* fortran max0,min0 */ + +/* internal variables */ + + + + /* Parameter adjustments */ + abd_dim1 = *lda; + abd_offset = 1 + abd_dim1; + abd -= abd_offset; + --ipvt; + + /* Function Body */ + m = *ml + *mu + 1; + *info = 0; + +/* zero initial fill-in columns */ + + j0 = *mu + 2; + j1 = min(*n,m) - 1; + if (j1 < j0) { + goto L30; + } + i__1 = j1; + for (jz = j0; jz <= i__1; ++jz) { + i0 = m + 1 - jz; + i__2 = *ml; + for (i__ = i0; i__ <= i__2; ++i__) { + abd[i__ + jz * abd_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } +L30: + jz = j1; + ju = 0; + +/* gaussian elimination with partial pivoting */ + + nm1 = *n - 1; + if (nm1 < 1) { + goto L130; + } + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + +/* zero next fill-in column */ + + ++jz; + if (jz > *n) { + goto L50; + } + if (*ml < 1) { + goto L50; + } + i__2 = *ml; + for (i__ = 1; i__ <= i__2; ++i__) { + abd[i__ + jz * abd_dim1] = 0.; +/* L40: */ + } +L50: + +/* find l = pivot index */ + +/* Computing MIN */ + i__2 = *ml, i__3 = *n - k; + lm = min(i__2,i__3); + i__2 = lm + 1; + l = idamax_(&i__2, &abd[m + k * abd_dim1], &c__1) + m - 1; + ipvt[k] = l + k - m; + +/* zero pivot implies this column already triangularized */ + + if (abd[l + k * abd_dim1] == 0.) { + goto L100; + } + +/* interchange if necessary */ + + if (l == m) { + goto L60; + } + t = abd[l + k * abd_dim1]; + abd[l + k * abd_dim1] = abd[m + k * abd_dim1]; + abd[m + k * abd_dim1] = t; +L60: + +/* compute multipliers */ + + t = -1. / abd[m + k * abd_dim1]; + dscal_(&lm, &t, &abd[m + 1 + k * abd_dim1], &c__1); + +/* row elimination with column indexing */ + +/* Computing MIN */ +/* Computing MAX */ + i__3 = ju, i__4 = *mu + ipvt[k]; + i__2 = max(i__3,i__4); + ju = min(i__2,*n); + mm = m; + if (ju < kp1) { + goto L90; + } + i__2 = ju; + for (j = kp1; j <= i__2; ++j) { + --l; + --mm; + t = abd[l + j * abd_dim1]; + if (l == mm) { + goto L70; + } + abd[l + j * abd_dim1] = abd[mm + j * abd_dim1]; + abd[mm + j * abd_dim1] = t; +L70: + daxpy_(&lm, &t, &abd[m + 1 + k * abd_dim1], &c__1, &abd[mm + 1 + + j * abd_dim1], &c__1); +/* L80: */ + } +L90: + goto L110; +L100: + *info = k; +L110: +/* L120: */ + ; + } +L130: + ipvt[*n] = *n; + if (abd[m + *n * abd_dim1] == 0.) { + *info = *n; + } + return 0; +} /* dgbfa_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/dgbsl.c b/ext/f2c_math/dgbsl.c new file mode 100644 index 000000000..e6c787475 --- /dev/null +++ b/ext/f2c_math/dgbsl.c @@ -0,0 +1,206 @@ +/* dgbsl.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__1 = 1; + +/* Subroutine */ int dgbsl_(doublereal *abd, integer *lda, integer *n, + integer *ml, integer *mu, integer *ipvt, doublereal *b, integer *job) +{ + /* System generated locals */ + integer abd_dim1, abd_offset, i__1, i__2, i__3; + + /* Local variables */ + static integer k, l, m; + static doublereal t; + static integer kb, la, lb, lm, nm1; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + + +/* dgbsl solves the double precision band system */ +/* a * x = b or trans(a) * x = b */ +/* using the factors computed by dgbco or dgbfa. */ + +/* on entry */ + +/* abd double precision(lda, n) */ +/* the output from dgbco or dgbfa. */ + +/* lda integer */ +/* the leading dimension of the array abd . */ + +/* n integer */ +/* the order of the original matrix. */ + +/* ml integer */ +/* number of diagonals below the main diagonal. */ + +/* mu integer */ +/* number of diagonals above the main diagonal. */ + +/* ipvt integer(n) */ +/* the pivot vector from dgbco or dgbfa. */ + +/* b double precision(n) */ +/* the right hand side vector. */ + +/* job integer */ +/* = 0 to solve a*x = b , */ +/* = nonzero to solve trans(a)*x = b , where */ +/* trans(a) is the transpose. */ + +/* on return */ + +/* b the solution vector x . */ + +/* error condition */ + +/* a division by zero will occur if the input factor contains a */ +/* zero on the diagonal. technically this indicates singularity */ +/* but it is often caused by improper arguments or improper */ +/* setting of lda . it will not occur if the subroutines are */ +/* called correctly and if dgbco has set rcond .gt. 0.0 */ +/* or dgbfa has set info .eq. 0 . */ + +/* to compute inverse(a) * c where c is a matrix */ +/* with p columns */ +/* call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) */ +/* if (rcond is too small) go to ... */ +/* do 10 j = 1, p */ +/* call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) */ +/* 10 continue */ + +/* linpack. this version dated 08/14/78 . */ +/* cleve moler, university of new mexico, argonne national lab. */ + +/* subroutines and functions */ + +/* blas daxpy,ddot */ +/* fortran min0 */ + +/* internal variables */ + + + /* Parameter adjustments */ + abd_dim1 = *lda; + abd_offset = 1 + abd_dim1; + abd -= abd_offset; + --ipvt; + --b; + + /* Function Body */ + m = *mu + *ml + 1; + nm1 = *n - 1; + if (*job != 0) { + goto L50; + } + +/* job = 0 , solve a * x = b */ +/* first solve l*y = b */ + + if (*ml == 0) { + goto L30; + } + if (nm1 < 1) { + goto L30; + } + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { +/* Computing MIN */ + i__2 = *ml, i__3 = *n - k; + lm = min(i__2,i__3); + l = ipvt[k]; + t = b[l]; + if (l == k) { + goto L10; + } + b[l] = b[k]; + b[k] = t; +L10: + daxpy_(&lm, &t, &abd[m + 1 + k * abd_dim1], &c__1, &b[k + 1], &c__1); +/* L20: */ + } +L30: + +/* now solve u*x = y */ + + i__1 = *n; + for (kb = 1; kb <= i__1; ++kb) { + k = *n + 1 - kb; + b[k] /= abd[m + k * abd_dim1]; + lm = min(k,m) - 1; + la = m - lm; + lb = k - lm; + t = -b[k]; + daxpy_(&lm, &t, &abd[la + k * abd_dim1], &c__1, &b[lb], &c__1); +/* L40: */ + } + goto L100; +L50: + +/* job = nonzero, solve trans(a) * x = b */ +/* first solve trans(u)*y = b */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + lm = min(k,m) - 1; + la = m - lm; + lb = k - lm; + t = ddot_(&lm, &abd[la + k * abd_dim1], &c__1, &b[lb], &c__1); + b[k] = (b[k] - t) / abd[m + k * abd_dim1]; +/* L60: */ + } + +/* now solve trans(l)*x = y */ + + if (*ml == 0) { + goto L90; + } + if (nm1 < 1) { + goto L90; + } + i__1 = nm1; + for (kb = 1; kb <= i__1; ++kb) { + k = *n - kb; +/* Computing MIN */ + i__2 = *ml, i__3 = *n - k; + lm = min(i__2,i__3); + b[k] += ddot_(&lm, &abd[m + 1 + k * abd_dim1], &c__1, &b[k + 1], & + c__1); + l = ipvt[k]; + if (l == k) { + goto L70; + } + t = b[l]; + b[l] = b[k]; + b[k] = t; +L70: +/* L80: */ + ; + } +L90: +L100: + return 0; +} /* dgbsl_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/dgefa.c b/ext/f2c_math/dgefa.c new file mode 100644 index 000000000..67457052e --- /dev/null +++ b/ext/f2c_math/dgefa.c @@ -0,0 +1,164 @@ +/* dgefa.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__1 = 1; + +/* Subroutine */ int dgefa_(doublereal *a, integer *lda, integer *n, integer * + ipvt, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + static integer j, k, l; + static doublereal t; + static integer kp1, nm1; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), daxpy_(integer *, doublereal *, doublereal *, integer + *, doublereal *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + + +/* dgefa factors a double precision matrix by gaussian elimination. */ + +/* dgefa is usually called by dgeco, but it can be called */ +/* directly with a saving in time if rcond is not needed. */ +/* (time for dgeco) = (1 + 9/n)*(time for dgefa) . */ + +/* on entry */ + +/* a double precision(lda, n) */ +/* the matrix to be factored. */ + +/* lda integer */ +/* the leading dimension of the array a . */ + +/* n integer */ +/* the order of the matrix a . */ + +/* on return */ + +/* a an upper triangular matrix and the multipliers */ +/* which were used to obtain it. */ +/* the factorization can be written a = l*u where */ +/* l is a product of permutation and unit lower */ +/* triangular matrices and u is upper triangular. */ + +/* ipvt integer(n) */ +/* an integer vector of pivot indices. */ + +/* info integer */ +/* = 0 normal value. */ +/* = k if u(k,k) .eq. 0.0 . this is not an error */ +/* condition for this subroutine, but it does */ +/* indicate that dgesl or dgedi will divide by zero */ +/* if called. use rcond in dgeco for a reliable */ +/* indication of singularity. */ + +/* linpack. this version dated 08/14/78 . */ +/* cleve moler, university of new mexico, argonne national lab. */ + +/* subroutines and functions */ + +/* blas daxpy,dscal,idamax */ + +/* internal variables */ + + + +/* gaussian elimination with partial pivoting */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipvt; + + /* Function Body */ + *info = 0; + nm1 = *n - 1; + if (nm1 < 1) { + goto L70; + } + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + kp1 = k + 1; + +/* find l = pivot index */ + + i__2 = *n - k + 1; + l = idamax_(&i__2, &a[k + k * a_dim1], &c__1) + k - 1; + ipvt[k] = l; + +/* zero pivot implies this column already triangularized */ + + if (a[l + k * a_dim1] == 0.) { + goto L40; + } + +/* interchange if necessary */ + + if (l == k) { + goto L10; + } + t = a[l + k * a_dim1]; + a[l + k * a_dim1] = a[k + k * a_dim1]; + a[k + k * a_dim1] = t; +L10: + +/* compute multipliers */ + + t = -1. / a[k + k * a_dim1]; + i__2 = *n - k; + dscal_(&i__2, &t, &a[k + 1 + k * a_dim1], &c__1); + +/* row elimination with column indexing */ + + i__2 = *n; + for (j = kp1; j <= i__2; ++j) { + t = a[l + j * a_dim1]; + if (l == k) { + goto L20; + } + a[l + j * a_dim1] = a[k + j * a_dim1]; + a[k + j * a_dim1] = t; +L20: + i__3 = *n - k; + daxpy_(&i__3, &t, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1 + j * + a_dim1], &c__1); +/* L30: */ + } + goto L50; +L40: + *info = k; +L50: +/* L60: */ + ; + } +L70: + ipvt[*n] = *n; + if (a[*n + *n * a_dim1] == 0.) { + *info = *n; + } + return 0; +} /* dgefa_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/dgesl.c b/ext/f2c_math/dgesl.c new file mode 100644 index 000000000..56a562734 --- /dev/null +++ b/ext/f2c_math/dgesl.c @@ -0,0 +1,183 @@ +/* dgesl.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__1 = 1; + +/* Subroutine */ int dgesl_(doublereal *a, integer *lda, integer *n, integer * + ipvt, doublereal *b, integer *job) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + static integer k, l; + static doublereal t; + static integer kb, nm1; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + + +/* dgesl solves the double precision system */ +/* a * x = b or trans(a) * x = b */ +/* using the factors computed by dgeco or dgefa. */ + +/* on entry */ + +/* a double precision(lda, n) */ +/* the output from dgeco or dgefa. */ + +/* lda integer */ +/* the leading dimension of the array a . */ + +/* n integer */ +/* the order of the matrix a . */ + +/* ipvt integer(n) */ +/* the pivot vector from dgeco or dgefa. */ + +/* b double precision(n) */ +/* the right hand side vector. */ + +/* job integer */ +/* = 0 to solve a*x = b , */ +/* = nonzero to solve trans(a)*x = b where */ +/* trans(a) is the transpose. */ + +/* on return */ + +/* b the solution vector x . */ + +/* error condition */ + +/* a division by zero will occur if the input factor contains a */ +/* zero on the diagonal. technically this indicates singularity */ +/* but it is often caused by improper arguments or improper */ +/* setting of lda . it will not occur if the subroutines are */ +/* called correctly and if dgeco has set rcond .gt. 0.0 */ +/* or dgefa has set info .eq. 0 . */ + +/* to compute inverse(a) * c where c is a matrix */ +/* with p columns */ +/* call dgeco(a,lda,n,ipvt,rcond,z) */ +/* if (rcond is too small) go to ... */ +/* do 10 j = 1, p */ +/* call dgesl(a,lda,n,ipvt,c(1,j),0) */ +/* 10 continue */ + +/* linpack. this version dated 08/14/78 . */ +/* cleve moler, university of new mexico, argonne national lab. */ + +/* subroutines and functions */ + +/* blas daxpy,ddot */ + +/* internal variables */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipvt; + --b; + + /* Function Body */ + nm1 = *n - 1; + if (*job != 0) { + goto L50; + } + +/* job = 0 , solve a * x = b */ +/* first solve l*y = b */ + + if (nm1 < 1) { + goto L30; + } + i__1 = nm1; + for (k = 1; k <= i__1; ++k) { + l = ipvt[k]; + t = b[l]; + if (l == k) { + goto L10; + } + b[l] = b[k]; + b[k] = t; +L10: + i__2 = *n - k; + daxpy_(&i__2, &t, &a[k + 1 + k * a_dim1], &c__1, &b[k + 1], &c__1); +/* L20: */ + } +L30: + +/* now solve u*x = y */ + + i__1 = *n; + for (kb = 1; kb <= i__1; ++kb) { + k = *n + 1 - kb; + b[k] /= a[k + k * a_dim1]; + t = -b[k]; + i__2 = k - 1; + daxpy_(&i__2, &t, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1); +/* L40: */ + } + goto L100; +L50: + +/* job = nonzero, solve trans(a) * x = b */ +/* first solve trans(u)*y = b */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + i__2 = k - 1; + t = ddot_(&i__2, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1); + b[k] = (b[k] - t) / a[k + k * a_dim1]; +/* L60: */ + } + +/* now solve trans(l)*x = y */ + + if (nm1 < 1) { + goto L90; + } + i__1 = nm1; + for (kb = 1; kb <= i__1; ++kb) { + k = *n - kb; + i__2 = *n - k; + b[k] += ddot_(&i__2, &a[k + 1 + k * a_dim1], &c__1, &b[k + 1], &c__1); + l = ipvt[k]; + if (l == k) { + goto L70; + } + t = b[l]; + b[l] = b[k]; + b[k] = t; +L70: +/* L80: */ + ; + } +L90: +L100: + return 0; +} /* dgesl_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/dp1vlu.c b/ext/f2c_math/dp1vlu.c new file mode 100644 index 000000000..95e906608 --- /dev/null +++ b/ext/f2c_math/dp1vlu.c @@ -0,0 +1,255 @@ +/* dp1vlu.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__1 = 1; +static integer c__8 = 8; +static integer c__2 = 2; +static integer c__5 = 5; + +/* 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]; + + /* 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 i__, n, k1, k2, k3, k4; + static doublereal cc; + static integer ic, kc, in, k1i, lm1, lp1; + static doublereal dif; + static integer k3p1, k4p1, ndo; + static doublereal val; + static integer ilo, iup, ndp1, inp1, k3pn, k4pn, nord; + static char xern1[8], xern2[8]; + static integer maxord; + extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *, + integer *, ftnlen, ftnlen, ftnlen); + + /* Fortran I/O blocks */ + static icilist io___28 = { 0, xern1, 0, "(I8)", 8, 1 }; + static icilist io___30 = { 0, xern2, 0, "(I8)", 8, 1 }; + + +/* ***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: + s_wsfi(&io___28); + do_fio(&c__1, (char *)&(*l), (ftnlen)sizeof(integer)); + e_wsfi(); + s_wsfi(&io___30); + 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_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/dpcoef.c b/ext/f2c_math/dpcoef.c new file mode 100644 index 000000000..d2a28d2a4 --- /dev/null +++ b/ext/f2c_math/dpcoef.c @@ -0,0 +1,127 @@ +/* dpcoef.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* DECK DPCOEF */ +/* Subroutine */ int dpcoef_(integer *l, doublereal *c__, doublereal *tc, + doublereal *a) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__, ll, nr; + static doublereal fac; + static integer new__, llp1, llp2; + static doublereal save; + extern /* Subroutine */ int dp1vlu_(integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *); + +/* ***BEGIN PROLOGUE DPCOEF */ +/* ***PURPOSE Convert the DPOLFT coefficients to Taylor series form. */ +/* ***LIBRARY SLATEC */ +/* ***CATEGORY K1A1A2 */ +/* ***TYPE DOUBLE PRECISION (PCOEF-S, DPCOEF-D) */ +/* ***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT */ +/* ***AUTHOR Shampine, L. F., (SNLA) */ +/* Davenport, S. M., (SNLA) */ +/* ***DESCRIPTION */ + +/* Abstract */ + +/* DPOLFT computes the least squares polynomial fit of degree L as */ +/* a sum of orthogonal polynomials. DPCOEF changes this fit to its */ +/* Taylor expansion about any point C , i.e. writes the polynomial */ +/* as a sum of powers of (X-C). Taking C=0. gives the polynomial */ +/* in powers of X, but a suitable non-zero C often leads to */ +/* polynomials which are better scaled and more accurately evaluated. */ + +/* The parameters for DPCOEF are */ + +/* INPUT -- All TYPE REAL variables are DOUBLE PRECISION */ +/* L - Indicates the degree of polynomial to be changed to */ +/* its Taylor expansion. To obtain the Taylor */ +/* coefficients in reverse order, input L as the */ +/* negative of the degree desired. The absolute value */ +/* of L must be less than or equal to NDEG, the highest */ +/* degree polynomial fitted by DPOLFT . */ +/* C - The point about which the Taylor expansion is to be */ +/* made. */ +/* A - Work and output array containing values from last */ +/* call to DPOLFT . */ + +/* OUTPUT -- All TYPE REAL variables are DOUBLE PRECISION */ +/* TC - Vector containing the first LL+1 Taylor coefficients */ +/* where LL=ABS(L). If L.GT.0 , the coefficients are */ +/* in the usual Taylor series order, i.e. */ +/* P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N */ +/* If L .LT. 0, the coefficients are in reverse order, */ +/* i.e. */ +/* P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) */ + +/* ***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 DP1VLU */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 740601 DATE WRITTEN */ +/* 890531 Changed all specific intrinsics to generic. (WRB) */ +/* 891006 Cosmetic changes to prologue. (WRB) */ +/* 891006 REVISION DATE from Version 3.2 */ +/* 891214 Prologue converted to Version 4.0 format. (BAB) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* ***END PROLOGUE DPCOEF */ + +/* ***FIRST EXECUTABLE STATEMENT DPCOEF */ + /* Parameter adjustments */ + --a; + --tc; + + /* Function Body */ + ll = abs(*l); + llp1 = ll + 1; + dp1vlu_(&ll, &ll, c__, &tc[1], &tc[2], &a[1]); + if (ll < 2) { + goto L2; + } + fac = 1.; + i__1 = llp1; + for (i__ = 3; i__ <= i__1; ++i__) { + fac *= i__ - 1; +/* L1: */ + tc[i__] /= fac; + } +L2: + if (*l >= 0) { + goto L4; + } + nr = llp1 / 2; + llp2 = ll + 2; + i__1 = nr; + for (i__ = 1; i__ <= i__1; ++i__) { + save = tc[i__]; + new__ = llp2 - i__; + tc[i__] = tc[new__]; +/* L3: */ + tc[new__] = save; + } +L4: + return 0; +} /* dpcoef_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/dpolft.c b/ext/f2c_math/dpolft.c new file mode 100644 index 000000000..bf956fa00 --- /dev/null +++ b/ext/f2c_math/dpolft.c @@ -0,0 +1,539 @@ +/* dpolft.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__2 = 2; +static integer c__1 = 1; + +/* DECK DPOLFT */ +/* Subroutine */ int dpolft_(integer *n, doublereal *x, doublereal *y, + doublereal *w, integer *maxdeg, integer *ndeg, doublereal *eps, + doublereal *r__, integer *ierr, doublereal *a) +{ + /* Initialized data */ + + static doublereal co[12] /* was [4][3] */ = { -13.08685,-2.4648165, + -3.3846535,-1.2973162,-3.3381146,-1.7812271,-3.2578406,-1.6589279, + -1.6282703,-1.3152745,-3.2640179,-1.9829776 }; + + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static doublereal f; + static integer i__, j, m, k1, k2, k3, k4, k5; + static doublereal w1, w11, xm, yp; + static integer jp1; + static doublereal den, sig; + static integer k1pj, k2pj, k3pi, k4pi, k5pi, mop1; + static doublereal degf; + static integer nder; + static doublereal sigj; + static integer jpas, ksig; + static doublereal temp, etst, temd1, temd2; + static integer idegf, nfail; + static doublereal fcrit, sigjm1; + extern /* Subroutine */ int dp1vlu_(integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *); + static doublereal sigpas; + extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *, + integer *, ftnlen, ftnlen, ftnlen); + +/* ***BEGIN PROLOGUE DPOLFT */ +/* ***PURPOSE Fit discrete data in a least squares sense by polynomials */ +/* in one variable. */ +/* ***LIBRARY SLATEC */ +/* ***CATEGORY K1A1A2 */ +/* ***TYPE DOUBLE PRECISION (POLFIT-S, DPOLFT-D) */ +/* ***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT */ +/* ***AUTHOR Shampine, L. F., (SNLA) */ +/* Davenport, S. M., (SNLA) */ +/* Huddleston, R. E., (SNLL) */ +/* ***DESCRIPTION */ + +/* Abstract */ + +/* Given a collection of points X(I) and a set of values Y(I) which */ +/* correspond to some function or measurement at each of the X(I), */ +/* subroutine DPOLFT computes the weighted least-squares polynomial */ +/* fits of all degrees up to some degree either specified by the user */ +/* or determined by the routine. The fits thus obtained are in */ +/* orthogonal polynomial form. Subroutine DP1VLU may then be */ +/* called to evaluate the fitted polynomials and any of their */ +/* derivatives at any point. The subroutine DPCOEF may be used to */ +/* express the polynomial fits as powers of (X-C) for any specified */ +/* point C. */ + +/* The parameters for DPOLFT are */ + +/* Input -- All TYPE REAL variables are DOUBLE PRECISION */ +/* N - the number of data points. The arrays X, Y and W */ +/* must be dimensioned at least N (N .GE. 1). */ +/* X - array of values of the independent variable. These */ +/* values may appear in any order and need not all be */ +/* distinct. */ +/* Y - array of corresponding function values. */ +/* W - array of positive values to be used as weights. If */ +/* W(1) is negative, DPOLFT will set all the weights */ +/* to 1.0, which means unweighted least squares error */ +/* will be minimized. To minimize relative error, the */ +/* user should set the weights to: W(I) = 1.0/Y(I)**2, */ +/* I = 1,...,N . */ +/* MAXDEG - maximum degree to be allowed for polynomial fit. */ +/* MAXDEG may be any non-negative integer less than N. */ +/* Note -- MAXDEG cannot be equal to N-1 when a */ +/* statistical test is to be used for degree selection, */ +/* i.e., when input value of EPS is negative. */ +/* EPS - specifies the criterion to be used in determining */ +/* the degree of fit to be computed. */ +/* (1) If EPS is input negative, DPOLFT chooses the */ +/* degree based on a statistical F test of */ +/* significance. One of three possible */ +/* significance levels will be used: .01, .05 or */ +/* .10. If EPS=-1.0 , the routine will */ +/* automatically select one of these levels based */ +/* on the number of data points and the maximum */ +/* degree to be considered. If EPS is input as */ +/* -.01, -.05, or -.10, a significance level of */ +/* .01, .05, or .10, respectively, will be used. */ +/* (2) If EPS is set to 0., DPOLFT computes the */ +/* polynomials of degrees 0 through MAXDEG . */ +/* (3) If EPS is input positive, EPS is the RMS */ +/* error tolerance which must be satisfied by the */ +/* fitted polynomial. DPOLFT will increase the */ +/* degree of fit until this criterion is met or */ +/* until the maximum degree is reached. */ + +/* Output -- All TYPE REAL variables are DOUBLE PRECISION */ +/* NDEG - degree of the highest degree fit computed. */ +/* EPS - RMS error of the polynomial of degree NDEG . */ +/* R - vector of dimension at least NDEG containing values */ +/* of the fit of degree NDEG at each of the X(I) . */ +/* Except when the statistical test is used, these */ +/* values are more accurate than results from subroutine */ +/* DP1VLU normally are. */ +/* IERR - error flag with the following possible values. */ +/* 1 -- indicates normal execution, i.e., either */ +/* (1) the input value of EPS was negative, and the */ +/* computed polynomial fit of degree NDEG */ +/* satisfies the specified F test, or */ +/* (2) the input value of EPS was 0., and the fits of */ +/* all degrees up to MAXDEG are complete, or */ +/* (3) the input value of EPS was positive, and the */ +/* polynomial of degree NDEG satisfies the RMS */ +/* error requirement. */ +/* 2 -- invalid input parameter. At least one of the input */ +/* parameters has an illegal value and must be corrected */ +/* before DPOLFT can proceed. Valid input results */ +/* when the following restrictions are observed */ +/* N .GE. 1 */ +/* 0 .LE. MAXDEG .LE. N-1 for EPS .GE. 0. */ +/* 0 .LE. MAXDEG .LE. N-2 for EPS .LT. 0. */ +/* W(1)=-1.0 or W(I) .GT. 0., I=1,...,N . */ +/* 3 -- cannot satisfy the RMS error requirement with a */ +/* polynomial of degree no greater than MAXDEG . Best */ +/* fit found is of degree MAXDEG . */ +/* 4 -- cannot satisfy the test for significance using */ +/* current value of MAXDEG . Statistically, the */ +/* best fit found is of order NORD . (In this case, */ +/* NDEG will have one of the values: MAXDEG-2, */ +/* MAXDEG-1, or MAXDEG). Using a higher value of */ +/* MAXDEG may result in passing the test. */ +/* A - work and output array having at least 3N+3MAXDEG+3 */ +/* locations */ + +/* Note - DPOLFT calculates all fits of degrees up to and including */ +/* NDEG . Any or all of these fits can be evaluated or */ +/* expressed as powers of (X-C) using DP1VLU and DPCOEF */ +/* after just one call to DPOLFT . */ + +/* ***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 DP1VLU, XERMSG */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 740601 DATE WRITTEN */ +/* 890531 Changed all specific intrinsics to generic. (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) */ +/* 900911 Added variable YP to DOUBLE PRECISION declaration. (WRB) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* 920527 Corrected erroneous statements in DESCRIPTION. (WRB) */ +/* ***END PROLOGUE DPOLFT */ + /* Parameter adjustments */ + --a; + --r__; + --w; + --y; + --x; + + /* Function Body */ +/* ***FIRST EXECUTABLE STATEMENT DPOLFT */ +/* write(*,*) 'DPOLFT n = ',n */ +/* do ii = 1,n */ +/* write(*,*) x(ii), y(ii), w(ii) */ +/* end do */ +/* write(*,*) ' maxdeg, eps = ',maxdeg,eps */ + m = abs(*n); + if (m == 0) { + goto L30; + } + if (*maxdeg < 0) { + goto L30; + } + a[1] = (doublereal) (*maxdeg); + mop1 = *maxdeg + 1; + if (m < mop1) { + goto L30; + } + if (*eps < 0. && m == mop1) { + goto L30; + } + xm = (doublereal) m; + etst = *eps * *eps * xm; + if (w[1] < 0.) { + goto L2; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (w[i__] <= 0.) { + goto L30; + } +/* L1: */ + } + goto L4; +L2: + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L3: */ + w[i__] = 1.; + } +L4: + if (*eps >= 0.) { + goto L8; + } + +/* DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR */ +/* CHOOSING DEGREE OF POLYNOMIAL FIT */ + + if (*eps > -.55) { + goto L5; + } + idegf = m - *maxdeg - 1; + ksig = 1; + if (idegf < 10) { + ksig = 2; + } + if (idegf < 5) { + ksig = 3; + } + goto L8; +L5: + ksig = 1; + if (*eps < -.03) { + ksig = 2; + } + if (*eps < -.07) { + ksig = 3; + } + +/* INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING */ + +L8: + k1 = *maxdeg + 1; + k2 = k1 + *maxdeg; + k3 = k2 + *maxdeg + 2; + k4 = k3 + m; + k5 = k4 + m; + i__1 = k4; + for (i__ = 2; i__ <= i__1; ++i__) { +/* L9: */ + a[i__] = 0.; + } + w11 = 0.; + if (*n < 0) { + goto L11; + } + +/* UNCONSTRAINED CASE */ + + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + a[k4pi] = 1.; +/* L10: */ + w11 += w[i__]; + } + goto L13; + +/* CONSTRAINED CASE */ + +L11: + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; +/* L12: */ +/* Computing 2nd power */ + d__1 = a[k4pi]; + w11 += w[i__] * (d__1 * d__1); + } + +/* COMPUTE FIT OF DEGREE ZERO */ + +L13: + temd1 = 0.; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + temd1 += w[i__] * y[i__] * a[k4pi]; +/* L14: */ + } + temd1 /= w11; + a[k2 + 1] = temd1; + sigj = 0.; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + k5pi = k5 + i__; + temd2 = temd1 * a[k4pi]; + r__[i__] = temd2; + a[k5pi] = temd2 - r__[i__]; +/* L15: */ +/* Computing 2nd power */ + d__1 = y[i__] - r__[i__] - a[k5pi]; + sigj += w[i__] * (d__1 * d__1); + } + j = 0; + +/* SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION */ + + if (*eps < 0.) { + goto L24; + } else if (*eps == 0) { + goto L26; + } else { + goto L27; + } + +/* INCREMENT DEGREE */ + +L16: + ++j; + jp1 = j + 1; + k1pj = k1 + j; + k2pj = k2 + j; + sigjm1 = sigj; + +/* COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 */ + + if (j > 1) { + a[k1pj] = w11 / w1; + } + +/* COMPUTE NEW A COEFFICIENT */ + + temd1 = 0.; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + temd2 = a[k4pi]; + temd1 += x[i__] * w[i__] * temd2 * temd2; +/* L18: */ + } + a[jp1] = temd1 / w11; + +/* EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS */ + + w1 = w11; + w11 = 0.; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k3pi = k3 + i__; + k4pi = k4 + i__; + temp = a[k3pi]; + a[k3pi] = a[k4pi]; + a[k4pi] = (x[i__] - a[jp1]) * a[k3pi] - a[k1pj] * temp; +/* L19: */ +/* Computing 2nd power */ + d__1 = a[k4pi]; + w11 += w[i__] * (d__1 * d__1); + } + +/* GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE */ +/* PRECISION */ + + temd1 = 0.; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + k5pi = k5 + i__; + temd2 = w[i__] * (y[i__] - r__[i__] - a[k5pi]) * a[k4pi]; +/* L20: */ + temd1 += temd2; + } + temd1 /= w11; + a[k2pj + 1] = temd1; + +/* UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND */ +/* ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE */ +/* COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, */ +/* THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST */ +/* SIGNIFICANT BITS ARE IN A(K5PI) . */ + + sigj = 0.; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + k5pi = k5 + i__; + temd2 = r__[i__] + a[k5pi] + temd1 * a[k4pi]; + r__[i__] = temd2; + a[k5pi] = temd2 - r__[i__]; +/* L21: */ +/* Computing 2nd power */ + d__1 = y[i__] - r__[i__] - a[k5pi]; + sigj += w[i__] * (d__1 * d__1); + } + +/* SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE */ +/* MAXDEG HAS BEEN REACHED */ + + if (*eps < 0.) { + goto L23; + } else if (*eps == 0) { + goto L26; + } else { + goto L27; + } + +/* COMPUTE F STATISTICS (INPUT EPS .LT. 0.) */ + +L23: + if (sigj == 0.) { + goto L29; + } + degf = (doublereal) (m - j - 1); + den = (co[(ksig << 2) - 1] * degf + 1.) * degf; + fcrit = ((co[(ksig << 2) - 2] * degf + co[(ksig << 2) - 3]) * degf + co[( + ksig << 2) - 4]) / den; + fcrit *= fcrit; + f = (sigjm1 - sigj) * degf / sigj; + if (f < fcrit) { + goto L25; + } + +/* POLYNOMIAL OF DEGREE J SATISFIES F TEST */ + +L24: + sigpas = sigj; + jpas = j; + nfail = 0; + if (*maxdeg == j) { + goto L32; + } + goto L16; + +/* POLYNOMIAL OF DEGREE J FAILS F TEST. IF THERE HAVE BEEN THREE */ +/* SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. */ + +L25: + ++nfail; + if (nfail >= 3) { + goto L29; + } + if (*maxdeg == j) { + goto L32; + } + goto L16; + +/* RAISE THE DEGREE IF DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT */ +/* EPS = 0.) */ + +L26: + if (*maxdeg == j) { + goto L28; + } + goto L16; + +/* SEE IF RMS ERROR CRITERION IS SATISFIED (INPUT EPS .GT. 0.) */ + +L27: + if (sigj <= etst) { + goto L28; + } + if (*maxdeg == j) { + goto L31; + } + goto L16; + +/* RETURNS */ + +L28: + *ierr = 1; + *ndeg = j; + sig = sigj; + goto L33; +L29: + *ierr = 1; + *ndeg = jpas; + sig = sigpas; + goto L33; +L30: + *ierr = 2; + xermsg_("SLATEC", "DPOLFT", "INVALID INPUT PARAMETER.", &c__2, &c__1, ( + ftnlen)6, (ftnlen)6, (ftnlen)24); + goto L37; +L31: + *ierr = 3; + *ndeg = *maxdeg; + sig = sigj; + goto L33; +L32: + *ierr = 4; + *ndeg = jpas; + sig = sigpas; + +L33: + a[k3] = (doublereal) (*ndeg); + +/* WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT */ +/* ALL THE DATA POINTS IF R DOES NOT ALREADY CONTAIN THESE VALUES */ + + if (*eps >= 0.f || *ndeg == *maxdeg) { + goto L36; + } + nder = 0; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + dp1vlu_(ndeg, &nder, &x[i__], &r__[i__], &yp, &a[1]); +/* L35: */ + } +L36: + *eps = sqrt(sig / xm); +L37: + return 0; +} /* dpolft_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/fdump.c b/ext/f2c_math/fdump.c new file mode 100644 index 000000000..e9fae8c3a --- /dev/null +++ b/ext/f2c_math/fdump.c @@ -0,0 +1,120 @@ +/* fdump.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* DECK FDUMP */ +/* Subroutine */ int fdump_(void) +{ +/* ***BEGIN PROLOGUE FDUMP */ +/* ***PURPOSE Symbolic dump (should be locally written). */ +/* ***LIBRARY SLATEC (XERMSG) */ +/* ***CATEGORY R3 */ +/* ***TYPE ALL (FDUMP-A) */ +/* ***KEYWORDS ERROR, XERMSG */ +/* ***AUTHOR Jones, R. E., (SNLA) */ +/* ***DESCRIPTION */ + +/* ***Note*** Machine Dependent Routine */ +/* FDUMP is intended to be replaced by a locally written */ +/* version which produces a symbolic dump. Failing this, */ +/* it should be replaced by a version which prints the */ +/* subprogram nesting list. Note that this dump must be */ +/* printed on each of up to five files, as indicated by the */ +/* XGETUA routine. See XSETUA and XGETUA for details. */ + +/* Written by Ron Jones, with SLATEC Common Math Library Subcommittee */ + +/* ***REFERENCES (NONE) */ +/* ***ROUTINES CALLED (NONE) */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 790801 DATE WRITTEN */ +/* 861211 REVISION DATE from Version 3.2 */ +/* 891214 Prologue converted to Version 4.0 format. (BAB) */ +/* ***END PROLOGUE FDUMP */ +/* ***FIRST EXECUTABLE STATEMENT FDUMP */ + return 0; +} /* fdump_ */ + +integer isamax_(integer *n, real *sx, integer *incx) +{ + /* System generated locals */ + integer ret_val, i__1; + real r__1; + + /* Local variables */ + static integer i__, ix; + static real smax; + + +/* finds the index of element having max. absolute value. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ + + + /* Parameter adjustments */ + --sx; + + /* Function Body */ + ret_val = 0; + if (*n < 1 || *incx <= 0) { + return ret_val; + } + ret_val = 1; + if (*n == 1) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + ix = 1; + smax = dabs(sx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((r__1 = sx[ix], dabs(r__1)) <= smax) { + goto L5; + } + ret_val = i__; + smax = (r__1 = sx[ix], dabs(r__1)); +L5: + ix += *incx; +/* L10: */ + } + return ret_val; + +/* code for increment equal to 1 */ + +L20: + smax = dabs(sx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((r__1 = sx[i__], dabs(r__1)) <= smax) { + goto L30; + } + ret_val = i__; + smax = (r__1 = sx[i__], dabs(r__1)); +L30: + ; + } + return ret_val; +} /* isamax_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/gmres.h b/ext/f2c_math/gmres.h new file mode 100644 index 000000000..1f6a044d5 --- /dev/null +++ b/ext/f2c_math/gmres.h @@ -0,0 +1,144 @@ +// -*- C++ -*- + +#ifndef GMRES_BLAS_H +#define GMRES_BLAS_H + +// ============================================================================ +// +// GMRES nach Saad, Schultz +// GMRES: a generalized minimal residual algorithm for solving nonsymmetric +// linear systems +// SIAM J Sci Stat Comput 7, 856-869 (1986) +// +// ---------------------------- +// Christian Badura, Mai 1998 +// +// ============================================================================ + + +template< class Matrix > +inline int +gmres( int m, int N, const Matrix &A, const doublereal *b, doublereal *x, doublereal eps ); + + +template< class Matrix > +inline int +gmres( int m, int N, const Matrix &A, const doublereal *b, doublereal *x, doublereal eps, + bool detailed ); + + +// ============================================================================ + +// #include "../../Cantera/src/blas.h" + +#include "cblas.h" +#include "../../Cantera/src/ctlapack.h" +using namespace Cantera; + +template< class Matrix > +inline int +gmres( int m, int n, const Matrix &A, const doublereal *b, doublereal *x, doublereal eps, + bool detailed ) { + if ( n<=0 ) + return -1; + typedef doublereal *doublerealP; + doublereal *V = new doublereal[n*(m+1)]; + doublereal *U = new doublereal[m*(m+1)/2]; + doublereal *r = new doublereal[n]; + doublereal *y = new doublereal[m+1]; + doublereal *c = new doublereal[m]; + doublereal *s = new doublereal[m]; + doublereal **v = new doublerealP[m+1]; + for ( int i=0; i<=m; ++i ) v[i]=V+i*n; + int its=-1; + { + doublereal beta, h, rd, dd, nrm2b; + int j, io, uij, u0j; + nrm2b=dnrm2(n,b,1); + cout << " norm = " << nrm2b << endl; + io=0; + do { // "aussere Iteration + ++io; + //mult(A,x,r); + A.mult(x,r); + daxpy(n,-1.,b,1,r,1); + beta=dnrm2(n,r,1); + dcopy(n,r,1,v[0],1); + dscal(n,1./beta,v[0],1); + + y[0]=beta; + j=0; + uij=0; + do { // innere Iteration j=0,...,m-1 + u0j=uij; + //mult(A,v[j],v[j+1]); + A.mult(v[j],v[j+1]); + + ct_dgemv(ctlapack::ColMajor, ctlapack::Transpose, n, j+1, 1.0, V, n, v[j+1], 1, 0.0, U+u0j, 1); + ct_dgemv(ctlapack::ColMajor, ctlapack::NoTranspose, n, j+1, -1.0, V, n, U+u0j, 1, 1.0, v[j+1], 1); + + //dgemv(Transpose,n,j+1,1.,V,n,v[j+1],1,0.,U+u0j,1); + //dgemv(NoTranspose,n,j+1,-1.,V,n,U+u0j,1,1.,v[j+1],1); + + h=dnrm2(n,v[j+1],1); + + dscal(n,1./h,v[j+1],1); + + for ( int i=0; i=eps*nrm2b ); + { // minimiere bzgl Y + dtpsv(UpperTriangle,NoTranspose,NotUnitTriangular,j,U,y,1); + // korrigiere X + dgemv(NoTranspose,n,j,-1.,V,n,y,1,1.,x,1); + } + } while ( fabs(y[j])>=eps*nrm2b ); + + // R"uckgabe: Zahl der inneren Iterationen + its = m*(io-1)+j; + } + + delete[] V; + delete[] U; + delete[] r; + delete[] y; + delete[] c; + delete[] s; + delete[] v; + return its; +} + + +// ============================================================================ + + +template< class Matrix > +inline int +gmres( int m, int n, const Matrix &A, const doublereal *b, doublereal *x, doublereal eps ){ + return gmres(m,n,A,b,x,eps,false); +} + +// ============================================================================ + + +#endif // GMRES_BLAS_H diff --git a/ext/f2c_math/idamax.c b/ext/f2c_math/idamax.c new file mode 100644 index 000000000..2615da8d4 --- /dev/null +++ b/ext/f2c_math/idamax.c @@ -0,0 +1,87 @@ +/* idamax.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +integer idamax_(integer *n, doublereal *dx, integer *incx) +{ + /* System generated locals */ + integer ret_val, i__1; + doublereal d__1; + + /* Local variables */ + static integer i__, ix; + static doublereal dmax__; + + +/* finds the index of element having max. absolute value. */ +/* jack dongarra, linpack, 3/11/78. */ +/* modified 3/93 to return if incx .le. 0. */ + + + /* Parameter adjustments */ + --dx; + + /* Function Body */ + ret_val = 0; + if (*n < 1 || *incx <= 0) { + return ret_val; + } + ret_val = 1; + if (*n == 1) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* code for increment not equal to 1 */ + + ix = 1; + dmax__ = abs(dx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[ix], abs(d__1)) <= dmax__) { + goto L5; + } + ret_val = i__; + dmax__ = (d__1 = dx[ix], abs(d__1)); +L5: + ix += *incx; +/* L10: */ + } + return ret_val; + +/* code for increment equal to 1 */ + +L20: + dmax__ = abs(dx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if ((d__1 = dx[i__], abs(d__1)) <= dmax__) { + goto L30; + } + ret_val = i__; + dmax__ = (d__1 = dx[i__], abs(d__1)); +L30: + ; + } + return ret_val; +} /* idamax_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/j4save.c b/ext/f2c_math/j4save.c new file mode 100644 index 000000000..828b3a4bd --- /dev/null +++ b/ext/f2c_math/j4save.c @@ -0,0 +1,90 @@ +/* j4save.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* DECK J4SAVE */ +integer j4save_(integer *iwhich, integer *ivalue, logical *iset) +{ + /* Initialized data */ + + static integer iparam[9] = { 0,2,0,10,1,0,0,0,0 }; + + /* System generated locals */ + integer ret_val; + +/* ***BEGIN PROLOGUE J4SAVE */ +/* ***SUBSIDIARY */ +/* ***PURPOSE Save or recall global variables needed by error */ +/* handling routines. */ +/* ***LIBRARY SLATEC (XERROR) */ +/* ***TYPE INTEGER (J4SAVE-I) */ +/* ***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR */ +/* ***AUTHOR Jones, R. E., (SNLA) */ +/* ***DESCRIPTION */ + +/* Abstract */ +/* J4SAVE saves and recalls several global variables needed */ +/* by the library error handling routines. */ + +/* Description of Parameters */ +/* --Input-- */ +/* IWHICH - Index of item desired. */ +/* = 1 Refers to current error number. */ +/* = 2 Refers to current error control flag. */ +/* = 3 Refers to current unit number to which error */ +/* messages are to be sent. (0 means use standard.) */ +/* = 4 Refers to the maximum number of times any */ +/* message is to be printed (as set by XERMAX). */ +/* = 5 Refers to the total number of units to which */ +/* each error message is to be written. */ +/* = 6 Refers to the 2nd unit for error messages */ +/* = 7 Refers to the 3rd unit for error messages */ +/* = 8 Refers to the 4th unit for error messages */ +/* = 9 Refers to the 5th unit for error messages */ +/* IVALUE - The value to be set for the IWHICH-th parameter, */ +/* if ISET is .TRUE. . */ +/* ISET - If ISET=.TRUE., the IWHICH-th parameter will BE */ +/* given the value, IVALUE. If ISET=.FALSE., the */ +/* IWHICH-th parameter will be unchanged, and IVALUE */ +/* is a dummy parameter. */ +/* --Output-- */ +/* The (old) value of the IWHICH-th parameter will be returned */ +/* in the function value, J4SAVE. */ + +/* ***SEE ALSO XERMSG */ +/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ +/* Error-handling Package, SAND82-0800, Sandia */ +/* Laboratories, 1982. */ +/* ***ROUTINES CALLED (NONE) */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 790801 DATE WRITTEN */ +/* 891214 Prologue converted to Version 4.0 format. (BAB) */ +/* 900205 Minor modifications to prologue. (WRB) */ +/* 900402 Added TYPE section. (WRB) */ +/* 910411 Added KEYWORDS section. (WRB) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* ***END PROLOGUE J4SAVE */ +/* ***FIRST EXECUTABLE STATEMENT J4SAVE */ + ret_val = iparam[(0 + (0 + (*iwhich - 1 << 2))) / 4]; + if (*iset) { + iparam[*iwhich - 1] = *ivalue; + } + return ret_val; +} /* j4save_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/mach.cpp b/ext/f2c_math/mach.cpp new file mode 100644 index 000000000..7718be97a --- /dev/null +++ b/ext/f2c_math/mach.cpp @@ -0,0 +1,60 @@ + + /* Standard C source for D1MACH -- remove the * in column 1 */ +#include +#include +#include +#include +#include + +extern "C" { + +double d1mach_(long *i) +{ + switch(*i){ + case 1: return DBL_MIN; + case 2: return DBL_MAX; + case 3: return DBL_EPSILON/FLT_RADIX; + case 4: return DBL_EPSILON; + case 5: return log10((double)FLT_RADIX); + } + fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i); + exit(1); + return 0; /* some compilers demand return values */ +} + +double d1mach(long *i) {return d1mach_(i);} + + +long i1mach_(long *i) +{ + switch(*i){ + case 1: return 5; /* standard input */ + case 2: return 6; /* standard output */ + case 3: return 7; /* standard punch */ + case 4: return 0; /* standard error */ + case 5: return 32; /* bits per integer */ + case 6: return sizeof(int); + case 7: return 2; /* base for integers */ + case 8: return 31; /* digits of integer base */ + case 9: return LONG_MAX; + case 10: return FLT_RADIX; + case 11: return FLT_MANT_DIG; + case 12: return FLT_MIN_EXP; + case 13: return FLT_MAX_EXP; + case 14: return DBL_MANT_DIG; + case 15: return DBL_MIN_EXP; + case 16: return DBL_MAX_EXP; + } + fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i); + exit(1); + return 0; /* some compilers demand return values */ +} + +long i1mach(long *i) { return i1mach_(i); } + +long _i1mach_(long *i) { + return i1mach_(i); +} + +} + diff --git a/ext/f2c_math/mkl_cblas.h b/ext/f2c_math/mkl_cblas.h new file mode 100644 index 000000000..dc5b45a71 --- /dev/null +++ b/ext/f2c_math/mkl_cblas.h @@ -0,0 +1,644 @@ +/* +// INTEL CORPORATION PROPRIETARY INFORMATION +// This software is supplied under the terms of a license agreement or +// nondisclosure agreement with Intel Corporation and may not be copied +// or disclosed except in accordance with the terms of that agreement. +// Copyright 1999, 2000 Intel Corporation. All Rights Reserved. +// +// File : mkl_cblas.h +// Purpose : MKL CBLAS interface +// Author : Shemyakin Andrey +*/ + +#ifndef __MKL_CBLAS_H__ +#define __MKL_CBLAS_H__ +#include + +#ifdef __cplusplus +extern "C" { /* Assume C declarations for C++ */ +#endif /* __cplusplus */ + +/* + * Enumerated and derived types + */ +#define CBLAS_INDEX size_t /* this may vary between platforms */ + +typedef enum {CblasRowMajor=101, CblasColMajor=102} CBLAS_ORDER; +typedef enum {CblasNoTrans=111, CblasTrans=112, CblasConjTrans=113} CBLAS_TRANSPOSE; +typedef enum {CblasUpper=121, CblasLower=122} CBLAS_UPLO; +typedef enum {CblasNonUnit=131, CblasUnit=132} CBLAS_DIAG; +typedef enum {CblasLeft=141, CblasRight=142} CBLAS_SIDE; + +/* + * =========================================================================== + * Prototypes for level 1 BLAS functions (complex are recast as routines) + * =========================================================================== + */ + +float cblas_sdot(const int N, const float *X, const int incX, + const float *Y, const int incY); +float cblas_sdoti(const int N, const float *X, const int *indx, + const float *Y); +double cblas_ddot(const int N, const double *X, const int incX, + const double *Y, const int incY); +double cblas_ddoti(const int N, const double *X, const int *indx, + const double *Y); + +/* + * Functions having prefixes Z and C only + */ +void cblas_cdotu_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotu); +void cblas_cdotui_sub(const int N, const void *X, const int *indx, + const void *Y, void *dotui); +void cblas_cdotc_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotc); +void cblas_cdotci_sub(const int N, const void *X, const int *indx, + const void *Y, void *dotui); + +void cblas_zdotu_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotu); +void cblas_zdotui_sub(const int N, const void *X, const int *indx, + const void *Y, void *dotui); +void cblas_zdotc_sub(const int N, const void *X, const int incX, + const void *Y, const int incY, void *dotc); +void cblas_zdotci_sub(const int N, const void *X, const int *indx, + const void *Y, void *dotui); + + +/* + * Functions having prefixes S D SC DZ + */ +float cblas_snrm2(const int N, const float *X, const int incX); +float cblas_sasum(const int N, const float *X, const int incX); + +double cblas_dnrm2(const int N, const double *X, const int incX); +double cblas_dasum(const int N, const double *X, const int incX); + +float cblas_scnrm2(const int N, const void *X, const int incX); +float cblas_scasum(const int N, const void *X, const int incX); + +double cblas_dznrm2(const int N, const void *X, const int incX); +double cblas_dzasum(const int N, const void *X, const int incX); + + +/* + * Functions having standard 4 prefixes (S D C Z) + */ +CBLAS_INDEX cblas_isamax(const int N, const float *X, const int incX); +CBLAS_INDEX cblas_idamax(const int N, const double *X, const int incX); +CBLAS_INDEX cblas_icamax(const int N, const void *X, const int incX); +CBLAS_INDEX cblas_izamax(const int N, const void *X, const int incX); +CBLAS_INDEX cblas_isamin(const int N, const float *X, const int incX); +CBLAS_INDEX cblas_idamin(const int N, const double *X, const int incX); +CBLAS_INDEX cblas_icamin(const int N, const void *X, const int incX); +CBLAS_INDEX cblas_izamin(const int N, const void *X, const int incX); + +/* + * =========================================================================== + * Prototypes for level 1 BLAS routines + * =========================================================================== + */ + +/* + * Routines with standard 4 prefixes (s, d, c, z) + */ +void cblas_sswap(const int N, float *X, const int incX, + float *Y, const int incY); +void cblas_scopy(const int N, const float *X, const int incX, + float *Y, const int incY); +void cblas_saxpy(const int N, const float alpha, const float *X, + const int incX, float *Y, const int incY); +void cblas_saxpyi(const int N, const float alpha, const float *X, + const int *indx, float *Y); +void cblas_sgthr(const int N, const float *Y, float *X, + const int *indx); +void cblas_sgthrz(const int N, float *Y, float *X, + const int *indx); +void cblas_ssctr(const int N, const float *X, const int *indx, + float *Y); +void cblas_srotg(float *a, float *b, float *c, float *s); + +void cblas_dswap(const int N, double *X, const int incX, + double *Y, const int incY); +void cblas_dcopy(const int N, const double *X, const int incX, + double *Y, const int incY); +void cblas_daxpy(const int N, const double alpha, const double *X, + const int incX, double *Y, const int incY); +void cblas_daxpyi(const int N, const double alpha, const double *X, + const int *indx, double *Y); +void cblas_dgthr(const int N, const double *Y, double *X, + const int *indx); +void cblas_dgthrz(const int N, double *Y, double *X, + const int *indx); +void cblas_dsctr(const int N, const double *X, const int *indx, + double *Y); +void cblas_drotg(double *a, double *b, double *c, double *s); + +void cblas_cswap(const int N, void *X, const int incX, + void *Y, const int incY); +void cblas_ccopy(const int N, const void *X, const int incX, + void *Y, const int incY); +void cblas_caxpy(const int N, const void *alpha, const void *X, + const int incX, void *Y, const int incY); +void cblas_caxpyi(const int N, const void *alpha, const void *X, + const int *indx, void *Y); +void cblas_cgthr(const int N, const void *Y, void *X, + const int *indx); +void cblas_cgthrz(const int N, void *Y, void *X, + const int *indx); +void cblas_csctr(const int N, const void *X, const int *indx, + void *Y); +void cblas_crotg(void *a, const void *b, float *c, void *s); + +void cblas_zswap(const int N, void *X, const int incX, + void *Y, const int incY); +void cblas_zcopy(const int N, const void *X, const int incX, + void *Y, const int incY); +void cblas_zaxpy(const int N, const void *alpha, const void *X, + const int incX, void *Y, const int incY); +void cblas_zaxpyi(const int N, const void *alpha, const void *X, + const int *indx, void *Y); +void cblas_zgthr(const int N, const void *Y, void *X, + const int *indx); +void cblas_zgthrz(const int N, void *Y, void *X, + const int *indx); +void cblas_zsctr(const int N, const void *X, const int *indx, + void *Y); +void cblas_zrotg(void *a, const void *b, double *c, void *s); + +/* + * Routines with S and D prefix only + */ +void cblas_srotmg(float *d1, float *d2, float *b1, const float *b2, float *P); +void cblas_srot(const int N, float *X, const int incX, + float *Y, const int incY, const float c, const float s); +void cblas_sroti(const int N, float *X, const int *indx, + float *Y, const float c, const float s); +void cblas_srotm(const int N, float *X, const int incX, + float *Y, const int incY, const float *P); + +void cblas_drotmg(double *d1, double *d2, double *b1, const double *b2, double *P); +void cblas_drot(const int N, double *X, const int incX, + double *Y, const int incY, const double c, const double s); +void cblas_drotm(const int N, double *X, const int incX, + double *Y, const int incY, const double *P); +void cblas_droti(const int N, double *X, const int *indx, + double *Y, const double c, const double s); + +/* + * Routines with CS and ZD prefix only + */ +void cblas_csrot(const int N, void *X, const int incX, + void *Y, const int incY, const float c, const float s); +void cblas_zdrot(const int N, void *X, const int incX, + void *Y, const int incY, const double c, const double s); + +/* + * Routines with S D C Z CS and ZD prefixes + */ +void cblas_sscal(const int N, const float alpha, float *X, const int incX); +void cblas_dscal(const int N, const double alpha, double *X, const int incX); +void cblas_cscal(const int N, const void *alpha, void *X, const int incX); +void cblas_zscal(const int N, const void *alpha, void *X, const int incX); +void cblas_csscal(const int N, const float alpha, void *X, const int incX); +void cblas_zdscal(const int N, const double alpha, void *X, const int incX); + +/* + * =========================================================================== + * Prototypes for level 2 BLAS + * =========================================================================== + */ + +/* + * Routines with standard 4 prefixes (S, D, C, Z) + */ +void cblas_sgemv(const CBLAS_ORDER order, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const float alpha, const float *A, const int lda, + const float *X, const int incX, const float beta, + float *Y, const int incY); +void cblas_sgbmv(const CBLAS_ORDER order, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const float alpha, + const float *A, const int lda, const float *X, + const int incX, const float beta, float *Y, const int incY); +void cblas_strmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const float *A, const int lda, + float *X, const int incX); +void cblas_stbmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const float *A, const int lda, + float *X, const int incX); +void cblas_stpmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const float *Ap, float *X, const int incX); +void cblas_strsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const float *A, const int lda, float *X, + const int incX); +void cblas_stbsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const float *A, const int lda, + float *X, const int incX); +void cblas_stpsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const float *Ap, float *X, const int incX); + +void cblas_dgemv(const CBLAS_ORDER order, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const double alpha, const double *A, const int lda, + const double *X, const int incX, const double beta, + double *Y, const int incY); +void cblas_dgbmv(const CBLAS_ORDER order, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const double alpha, + const double *A, const int lda, const double *X, + const int incX, const double beta, double *Y, const int incY); +void cblas_dtrmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const double *A, const int lda, + double *X, const int incX); +void cblas_dtbmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const double *A, const int lda, + double *X, const int incX); +void cblas_dtpmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const double *Ap, double *X, const int incX); +void cblas_dtrsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const double *A, const int lda, double *X, + const int incX); +void cblas_dtbsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const double *A, const int lda, + double *X, const int incX); +void cblas_dtpsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const double *Ap, double *X, const int incX); + +void cblas_cgemv(const CBLAS_ORDER order, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY); +void cblas_cgbmv(const CBLAS_ORDER order, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const void *alpha, + const void *A, const int lda, const void *X, + const int incX, const void *beta, void *Y, const int incY); +void cblas_ctrmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *A, const int lda, + void *X, const int incX); +void cblas_ctbmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ctpmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); +void cblas_ctrsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *A, const int lda, void *X, + const int incX); +void cblas_ctbsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ctpsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); + +void cblas_zgemv(const CBLAS_ORDER order, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *X, const int incX, const void *beta, + void *Y, const int incY); +void cblas_zgbmv(const CBLAS_ORDER order, + const CBLAS_TRANSPOSE TransA, const int M, const int N, + const int KL, const int KU, const void *alpha, + const void *A, const int lda, const void *X, + const int incX, const void *beta, void *Y, const int incY); +void cblas_ztrmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *A, const int lda, + void *X, const int incX); +void cblas_ztbmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ztpmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); +void cblas_ztrsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *A, const int lda, void *X, + const int incX); +void cblas_ztbsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const int K, const void *A, const int lda, + void *X, const int incX); +void cblas_ztpsv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE TransA, const CBLAS_DIAG Diag, + const int N, const void *Ap, void *X, const int incX); + + +/* + * Routines with S and D prefixes only + */ +void cblas_ssymv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const float alpha, const float *A, + const int lda, const float *X, const int incX, + const float beta, float *Y, const int incY); +void cblas_ssbmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const int K, const float alpha, const float *A, + const int lda, const float *X, const int incX, + const float beta, float *Y, const int incY); +void cblas_sspmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const float alpha, const float *Ap, + const float *X, const int incX, + const float beta, float *Y, const int incY); +void cblas_sger(const CBLAS_ORDER order, const int M, const int N, + const float alpha, const float *X, const int incX, + const float *Y, const int incY, float *A, const int lda); +void cblas_ssyr(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, float *A, const int lda); +void cblas_sspr(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, float *Ap); +void cblas_ssyr2(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY, float *A, + const int lda); +void cblas_sspr2(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const float alpha, const float *X, + const int incX, const float *Y, const int incY, float *A); + +void cblas_dsymv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const double alpha, const double *A, + const int lda, const double *X, const int incX, + const double beta, double *Y, const int incY); +void cblas_dsbmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const int K, const double alpha, const double *A, + const int lda, const double *X, const int incX, + const double beta, double *Y, const int incY); +void cblas_dspmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const double alpha, const double *Ap, + const double *X, const int incX, + const double beta, double *Y, const int incY); +void cblas_dger(const CBLAS_ORDER order, const int M, const int N, + const double alpha, const double *X, const int incX, + const double *Y, const int incY, double *A, const int lda); +void cblas_dsyr(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, double *A, const int lda); +void cblas_dspr(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, double *Ap); +void cblas_dsyr2(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, const double *Y, const int incY, double *A, + const int lda); +void cblas_dspr2(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const double alpha, const double *X, + const int incX, const double *Y, const int incY, double *A); + + +/* + * Routines with C and Z prefixes only + */ +void cblas_chemv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_chbmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const int K, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_chpmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *Ap, + const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_cgeru(const CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_cgerc(const CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_cher(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const float alpha, const void *X, const int incX, + void *A, const int lda); +void cblas_chpr(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const float alpha, const void *X, + const int incX, void *A); +void cblas_cher2(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_chpr2(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *Ap); + +void cblas_zhemv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_zhbmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const int K, const void *alpha, const void *A, + const int lda, const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_zhpmv(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const void *alpha, const void *Ap, + const void *X, const int incX, + const void *beta, void *Y, const int incY); +void cblas_zgeru(const CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_zgerc(const CBLAS_ORDER order, const int M, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_zher(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const double alpha, const void *X, const int incX, + void *A, const int lda); +void cblas_zhpr(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, + const int N, const double alpha, const void *X, + const int incX, void *A); +void cblas_zher2(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *A, const int lda); +void cblas_zhpr2(const CBLAS_ORDER order, const CBLAS_UPLO Uplo, const int N, + const void *alpha, const void *X, const int incX, + const void *Y, const int incY, void *Ap); + +/* + * =========================================================================== + * Prototypes for level 3 BLAS + * =========================================================================== + */ + +/* + * Routines with standard 4 prefixes (S, D, C, Z) + */ +void cblas_sgemm(const CBLAS_ORDER Order, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const float alpha, const float *A, + const int lda, const float *B, const int ldb, + const float beta, float *C, const int ldc); +void cblas_ssymm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const float alpha, const float *A, const int lda, + const float *B, const int ldb, const float beta, + float *C, const int ldc); +void cblas_ssyrk(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const float *A, const int lda, + const float beta, float *C, const int ldc); +void cblas_ssyr2k(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const float *A, const int lda, + const float *B, const int ldb, const float beta, + float *C, const int ldc); +void cblas_strmm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const float alpha, const float *A, const int lda, + float *B, const int ldb); +void cblas_strsm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const float alpha, const float *A, const int lda, + float *B, const int ldb); + +void cblas_dgemm(const CBLAS_ORDER Order, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const double alpha, const double *A, + const int lda, const double *B, const int ldb, + const double beta, double *C, const int ldc); +void cblas_dsymm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const double alpha, const double *A, const int lda, + const double *B, const int ldb, const double beta, + double *C, const int ldc); +void cblas_dsyrk(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const double *A, const int lda, + const double beta, double *C, const int ldc); +void cblas_dsyr2k(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const double *A, const int lda, + const double *B, const int ldb, const double beta, + double *C, const int ldc); +void cblas_dtrmm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const double alpha, const double *A, const int lda, + double *B, const int ldb); +void cblas_dtrsm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const double alpha, const double *A, const int lda, + double *B, const int ldb); + +void cblas_cgemm(const CBLAS_ORDER Order, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc); +void cblas_csymm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_csyrk(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *beta, void *C, const int ldc); +void cblas_csyr2k(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_ctrmm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); +void cblas_ctrsm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); + +void cblas_zgemm(const CBLAS_ORDER Order, const CBLAS_TRANSPOSE TransA, + const CBLAS_TRANSPOSE TransB, const int M, const int N, + const int K, const void *alpha, const void *A, + const int lda, const void *B, const int ldb, + const void *beta, void *C, const int ldc); +void cblas_zsymm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_zsyrk(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *beta, void *C, const int ldc); +void cblas_zsyr2k(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_ztrmm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); +void cblas_ztrsm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const CBLAS_TRANSPOSE TransA, + const CBLAS_DIAG Diag, const int M, const int N, + const void *alpha, const void *A, const int lda, + void *B, const int ldb); + + +/* + * Routines with prefixes C and Z only + */ +void cblas_chemm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_cherk(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const float alpha, const void *A, const int lda, + const float beta, void *C, const int ldc); +void cblas_cher2k(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const float beta, + void *C, const int ldc); + +void cblas_zhemm(const CBLAS_ORDER Order, const CBLAS_SIDE Side, + const CBLAS_UPLO Uplo, const int M, const int N, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const void *beta, + void *C, const int ldc); +void cblas_zherk(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const double alpha, const void *A, const int lda, + const double beta, void *C, const int ldc); +void cblas_zher2k(const CBLAS_ORDER Order, const CBLAS_UPLO Uplo, + const CBLAS_TRANSPOSE Trans, const int N, const int K, + const void *alpha, const void *A, const int lda, + const void *B, const int ldb, const double beta, + void *C, const int ldc); + + +#ifdef __cplusplus +} +#endif /* __cplusplus */ + +#endif /* __MKL_CBLAS_H__ */ diff --git a/ext/f2c_math/pcoef.c b/ext/f2c_math/pcoef.c new file mode 100644 index 000000000..a27f3b27f --- /dev/null +++ b/ext/f2c_math/pcoef.c @@ -0,0 +1,1006 @@ +/* pcoef.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__1 = 1; + +/* DECK PCOEF */ +/* Subroutine */ int pcoef_(integer *l, real *c__, real *tc, real *a) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__, ll, nr; + static real fac; + static integer new__, llp1, llp2; + static real save; + extern /* Subroutine */ int pvalue_(integer *, integer *, real *, real *, + real *, real *); + +/* ***BEGIN PROLOGUE PCOEF */ +/* ***PURPOSE Convert the POLFIT coefficients to Taylor series form. */ +/* ***LIBRARY SLATEC */ +/* ***CATEGORY K1A1A2 */ +/* ***TYPE SINGLE PRECISION (PCOEF-S, DPCOEF-D) */ +/* ***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT */ +/* ***AUTHOR Shampine, L. F., (SNLA) */ +/* Davenport, S. M., (SNLA) */ +/* ***DESCRIPTION */ + +/* Written BY L. F. Shampine and S. M. Davenport. */ + +/* Abstract */ + +/* POLFIT computes the least squares polynomial fit of degree L as */ +/* a sum of orthogonal polynomials. PCOEF changes this fit to its */ +/* Taylor expansion about any point C , i.e. writes the polynomial */ +/* as a sum of powers of (X-C). Taking C=0. gives the polynomial */ +/* in powers of X, but a suitable non-zero C often leads to */ +/* polynomials which are better scaled and more accurately evaluated. */ + +/* The parameters for PCOEF are */ + +/* INPUT -- */ +/* L - Indicates the degree of polynomial to be changed to */ +/* its Taylor expansion. To obtain the Taylor */ +/* coefficients in reverse order, input L as the */ +/* negative of the degree desired. The absolute value */ +/* of L must be less than or equal to NDEG, the highest */ +/* degree polynomial fitted by POLFIT . */ +/* C - The point about which the Taylor expansion is to be */ +/* made. */ +/* A - Work and output array containing values from last */ +/* call to POLFIT . */ + +/* OUTPUT -- */ +/* TC - Vector containing the first LL+1 Taylor coefficients */ +/* where LL=ABS(L). If L.GT.0 , the coefficients are */ +/* in the usual Taylor series order, i.e. */ +/* P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N */ +/* If L .LT. 0, the coefficients are in reverse order, */ +/* i.e. */ +/* P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) */ + +/* ***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 PVALUE */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 740601 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) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* ***END PROLOGUE PCOEF */ + +/* ***FIRST EXECUTABLE STATEMENT PCOEF */ + /* Parameter adjustments */ + --a; + --tc; + + /* Function Body */ + ll = abs(*l); + llp1 = ll + 1; + pvalue_(&ll, &ll, c__, &tc[1], &tc[2], &a[1]); + if (ll < 2) { + goto L2; + } + fac = 1.f; + i__1 = llp1; + for (i__ = 3; i__ <= i__1; ++i__) { + fac *= i__ - 1; +/* L1: */ + tc[i__] /= fac; + } +L2: + if (*l >= 0) { + goto L4; + } + nr = llp1 / 2; + llp2 = ll + 2; + i__1 = nr; + for (i__ = 1; i__ <= i__1; ++i__) { + save = tc[i__]; + new__ = llp2 - i__; + tc[i__] = tc[new__]; +/* L3: */ + tc[new__] = save; + } +L4: + return 0; +} /* pcoef_ */ + +/* $$$ */ +/* $$$ subroutine dscal(n,da,dx,incx) */ +/* $$$c */ +/* $$$c scales a vector by a constant. */ +/* $$$c uses unrolled loops for increment equal to one. */ +/* $$$c jack dongarra, linpack, 3/11/78. */ +/* $$$c modified 3/93 to return if incx .le. 0. */ +/* $$$c */ +/* $$$ double precision da,dx(1) */ +/* $$$ integer i,incx,m,mp1,n,nincx */ +/* $$$c */ +/* $$$ if( n.le.0 .or. incx.le.0 )return */ +/* $$$ if(incx.eq.1)go to 20 */ +/* $$$c */ +/* $$$c code for increment not equal to 1 */ +/* $$$c */ +/* $$$ nincx = n*incx */ +/* $$$ do 10 i = 1,nincx,incx */ +/* $$$ dx(i) = da*dx(i) */ +/* $$$ 10 continue */ +/* $$$ return */ +/* $$$c */ +/* $$$c code for increment equal to 1 */ +/* $$$c */ +/* $$$c */ +/* $$$c clean-up loop */ +/* $$$c */ +/* $$$ 20 m = mod(n,5) */ +/* $$$ if( m .eq. 0 ) go to 40 */ +/* $$$ do 30 i = 1,m */ +/* $$$ dx(i) = da*dx(i) */ +/* $$$ 30 continue */ +/* $$$ if( n .lt. 5 ) return */ +/* $$$ 40 mp1 = m + 1 */ +/* $$$ do 50 i = mp1,n,5 */ +/* $$$ dx(i) = da*dx(i) */ +/* $$$ dx(i + 1) = da*dx(i + 1) */ +/* $$$ dx(i + 2) = da*dx(i + 2) */ +/* $$$ dx(i + 3) = da*dx(i + 3) */ +/* $$$ dx(i + 4) = da*dx(i + 4) */ +/* $$$ 50 continue */ +/* $$$ return */ +/* $$$ end */ +/* Subroutine */ int dgbco_(doublereal *abd, integer *lda, integer *n, + integer *ml, integer *mu, integer *ipvt, doublereal *rcond, + doublereal *z__) +{ + /* System generated locals */ + integer abd_dim1, abd_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + + /* Builtin functions */ + double d_sign(doublereal *, doublereal *); + + /* Local variables */ + static integer j, k, l, m; + static doublereal s, t; + static integer kb, la; + static doublereal ek; + static integer lm, mm, is, ju; + static doublereal sm, wk; + static integer lz, kp1; + static doublereal wkm; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + static integer info; + extern /* Subroutine */ int dgbfa_(doublereal *, integer *, integer *, + integer *, integer *, integer *, integer *), dscal_(integer *, + doublereal *, doublereal *, integer *); + extern doublereal dasum_(integer *, doublereal *, integer *); + static doublereal anorm; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + static doublereal ynorm; + + +/* dgbco factors a double precision band matrix by gaussian */ +/* elimination and estimates the condition of the matrix. */ + +/* if rcond is not needed, dgbfa is slightly faster. */ +/* to solve a*x = b , follow dgbco by dgbsl. */ +/* to compute inverse(a)*c , follow dgbco by dgbsl. */ +/* to compute determinant(a) , follow dgbco by dgbdi. */ + +/* on entry */ + +/* abd double precision(lda, n) */ +/* contains the matrix in band storage. the columns */ +/* of the matrix are stored in the columns of abd and */ +/* the diagonals of the matrix are stored in rows */ +/* ml+1 through 2*ml+mu+1 of abd . */ +/* see the comments below for details. */ + +/* lda integer */ +/* the leading dimension of the array abd . */ +/* lda must be .ge. 2*ml + mu + 1 . */ + +/* n integer */ +/* the order of the original matrix. */ + +/* ml integer */ +/* number of diagonals below the main diagonal. */ +/* 0 .le. ml .lt. n . */ + +/* mu integer */ +/* number of diagonals above the main diagonal. */ +/* 0 .le. mu .lt. n . */ +/* more efficient if ml .le. mu . */ + +/* on return */ + +/* abd an upper triangular matrix in band storage and */ +/* the multipliers which were used to obtain it. */ +/* the factorization can be written a = l*u where */ +/* l is a product of permutation and unit lower */ +/* triangular matrices and u is upper triangular. */ + +/* ipvt integer(n) */ +/* an integer vector of pivot indices. */ + +/* rcond double precision */ +/* an estimate of the reciprocal condition of a . */ +/* for the system a*x = b , relative perturbations */ +/* in a and b of size epsilon may cause */ +/* relative perturbations in x of size epsilon/rcond . */ +/* if rcond is so small that the logical expression */ +/* 1.0 + rcond .eq. 1.0 */ +/* is true, then a may be singular to working */ +/* precision. in particular, rcond is zero if */ +/* exact singularity is detected or the estimate */ +/* underflows. */ + +/* z double precision(n) */ +/* a work vector whose contents are usually unimportant. */ +/* if a is close to a singular matrix, then z is */ +/* an approximate null vector in the sense that */ +/* norm(a*z) = rcond*norm(a)*norm(z) . */ + +/* 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) */ +/* m = ml + mu + 1 */ +/* do 20 j = 1, n */ +/* i1 = max0(1, j-mu) */ +/* i2 = min0(n, j+ml) */ +/* do 10 i = i1, i2 */ +/* k = i - j + m */ +/* abd(k,j) = a(i,j) */ +/* 10 continue */ +/* 20 continue */ + +/* this uses rows ml+1 through 2*ml+mu+1 of abd . */ +/* in addition, the first ml rows in abd are used for */ +/* elements generated during the triangularization. */ +/* the total number of rows needed in abd is 2*ml+mu+1 . */ +/* the ml+mu by ml+mu upper left triangle and the */ +/* ml by ml lower right triangle are not referenced. */ + +/* 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 abd should contain */ + +/* * * * + + + , * = not used */ +/* * * 13 24 35 46 , + = used for pivoting */ +/* * 12 23 34 45 56 */ +/* 11 22 33 44 55 66 */ +/* 21 32 43 54 65 * */ + +/* linpack. this version dated 08/14/78 . */ +/* cleve moler, university of new mexico, argonne national lab. */ + +/* subroutines and functions */ + +/* linpack dgbfa */ +/* blas daxpy,ddot,dscal,dasum */ +/* fortran dabs,dmax1,max0,min0,dsign */ + +/* internal variables */ + + + +/* compute 1-norm of a */ + + /* Parameter adjustments */ + abd_dim1 = *lda; + abd_offset = 1 + abd_dim1; + abd -= abd_offset; + --ipvt; + --z__; + + /* Function Body */ + anorm = 0.; + l = *ml + 1; + is = l + *mu; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + d__1 = anorm, d__2 = dasum_(&l, &abd[is + j * abd_dim1], &c__1); + anorm = max(d__1,d__2); + if (is > *ml + 1) { + --is; + } + if (j <= *mu) { + ++l; + } + if (j >= *n - *ml) { + --l; + } +/* L10: */ + } + +/* factor */ + + dgbfa_(&abd[abd_offset], lda, n, ml, mu, &ipvt[1], &info); + +/* rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) . */ +/* estimate = norm(z)/norm(y) where a*z = y and trans(a)*y = e . */ +/* trans(a) is the transpose of a . the components of e are */ +/* chosen to cause maximum local growth in the elements of w where */ +/* trans(u)*w = e . the vectors are frequently rescaled to avoid */ +/* overflow. */ + +/* solve trans(u)*w = e */ + + ek = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + z__[j] = 0.; +/* L20: */ + } + m = *ml + *mu + 1; + ju = 0; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (z__[k] != 0.) { + d__1 = -z__[k]; + ek = d_sign(&ek, &d__1); + } + if ((d__1 = ek - z__[k], abs(d__1)) <= (d__2 = abd[m + k * abd_dim1], + abs(d__2))) { + goto L30; + } + s = (d__1 = abd[m + k * abd_dim1], abs(d__1)) / (d__2 = ek - z__[k], + abs(d__2)); + dscal_(n, &s, &z__[1], &c__1); + ek = s * ek; +L30: + wk = ek - z__[k]; + wkm = -ek - z__[k]; + s = abs(wk); + sm = abs(wkm); + if (abd[m + k * abd_dim1] == 0.) { + goto L40; + } + wk /= abd[m + k * abd_dim1]; + wkm /= abd[m + k * abd_dim1]; + goto L50; +L40: + wk = 1.; + wkm = 1.; +L50: + kp1 = k + 1; +/* Computing MIN */ +/* Computing MAX */ + i__3 = ju, i__4 = *mu + ipvt[k]; + i__2 = max(i__3,i__4); + ju = min(i__2,*n); + mm = m; + if (kp1 > ju) { + goto L90; + } + i__2 = ju; + for (j = kp1; j <= i__2; ++j) { + --mm; + sm += (d__1 = z__[j] + wkm * abd[mm + j * abd_dim1], abs(d__1)); + z__[j] += wk * abd[mm + j * abd_dim1]; + s += (d__1 = z__[j], abs(d__1)); +/* L60: */ + } + if (s >= sm) { + goto L80; + } + t = wkm - wk; + wk = wkm; + mm = m; + i__2 = ju; + for (j = kp1; j <= i__2; ++j) { + --mm; + z__[j] += t * abd[mm + j * abd_dim1]; +/* L70: */ + } +L80: +L90: + z__[k] = wk; +/* L100: */ + } + s = 1. / dasum_(n, &z__[1], &c__1); + dscal_(n, &s, &z__[1], &c__1); + +/* solve trans(l)*y = w */ + + i__1 = *n; + for (kb = 1; kb <= i__1; ++kb) { + k = *n + 1 - kb; +/* Computing MIN */ + i__2 = *ml, i__3 = *n - k; + lm = min(i__2,i__3); + if (k < *n) { + z__[k] += ddot_(&lm, &abd[m + 1 + k * abd_dim1], &c__1, &z__[k + + 1], &c__1); + } + if ((d__1 = z__[k], abs(d__1)) <= 1.) { + goto L110; + } + s = 1. / (d__1 = z__[k], abs(d__1)); + dscal_(n, &s, &z__[1], &c__1); +L110: + l = ipvt[k]; + t = z__[l]; + z__[l] = z__[k]; + z__[k] = t; +/* L120: */ + } + s = 1. / dasum_(n, &z__[1], &c__1); + dscal_(n, &s, &z__[1], &c__1); + + ynorm = 1.; + +/* solve l*v = y */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + l = ipvt[k]; + t = z__[l]; + z__[l] = z__[k]; + z__[k] = t; +/* Computing MIN */ + i__2 = *ml, i__3 = *n - k; + lm = min(i__2,i__3); + if (k < *n) { + daxpy_(&lm, &t, &abd[m + 1 + k * abd_dim1], &c__1, &z__[k + 1], & + c__1); + } + if ((d__1 = z__[k], abs(d__1)) <= 1.) { + goto L130; + } + s = 1. / (d__1 = z__[k], abs(d__1)); + dscal_(n, &s, &z__[1], &c__1); + ynorm = s * ynorm; +L130: +/* L140: */ + ; + } + s = 1. / dasum_(n, &z__[1], &c__1); + dscal_(n, &s, &z__[1], &c__1); + ynorm = s * ynorm; + +/* solve u*z = w */ + + i__1 = *n; + for (kb = 1; kb <= i__1; ++kb) { + k = *n + 1 - kb; + if ((d__1 = z__[k], abs(d__1)) <= (d__2 = abd[m + k * abd_dim1], abs( + d__2))) { + goto L150; + } + s = (d__1 = abd[m + k * abd_dim1], abs(d__1)) / (d__2 = z__[k], abs( + d__2)); + dscal_(n, &s, &z__[1], &c__1); + ynorm = s * ynorm; +L150: + if (abd[m + k * abd_dim1] != 0.) { + z__[k] /= abd[m + k * abd_dim1]; + } + if (abd[m + k * abd_dim1] == 0.) { + z__[k] = 1.; + } + lm = min(k,m) - 1; + la = m - lm; + lz = k - lm; + t = -z__[k]; + daxpy_(&lm, &t, &abd[la + k * abd_dim1], &c__1, &z__[lz], &c__1); +/* L160: */ + } +/* make znorm = 1.0 */ + s = 1. / dasum_(n, &z__[1], &c__1); + dscal_(n, &s, &z__[1], &c__1); + ynorm = s * ynorm; + + if (anorm != 0.) { + *rcond = ynorm / anorm; + } + if (anorm == 0.) { + *rcond = 0.; + } + return 0; +} /* dgbco_ */ + +/* Subroutine */ int dgeco_(doublereal *a, integer *lda, integer *n, integer * + ipvt, doublereal *rcond, doublereal *z__) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Builtin functions */ + double d_sign(doublereal *, doublereal *); + + /* Local variables */ + static integer j, k, l; + static doublereal s, t; + static integer kb; + static doublereal ek, sm, wk; + static integer kp1; + static doublereal wkm; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + static integer info; + extern /* Subroutine */ int dgefa_(doublereal *, integer *, integer *, + integer *, integer *), dscal_(integer *, doublereal *, doublereal + *, integer *); + extern doublereal dasum_(integer *, doublereal *, integer *); + static doublereal anorm; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + static doublereal ynorm; + + +/* dgeco factors a double precision matrix by gaussian elimination */ +/* and estimates the condition of the matrix. */ + +/* if rcond is not needed, dgefa is slightly faster. */ +/* to solve a*x = b , follow dgeco by dgesl. */ +/* to compute inverse(a)*c , follow dgeco by dgesl. */ +/* to compute determinant(a) , follow dgeco by dgedi. */ +/* to compute inverse(a) , follow dgeco by dgedi. */ + +/* on entry */ + +/* a double precision(lda, n) */ +/* the matrix to be factored. */ + +/* lda integer */ +/* the leading dimension of the array a . */ + +/* n integer */ +/* the order of the matrix a . */ + +/* on return */ + +/* a an upper triangular matrix and the multipliers */ +/* which were used to obtain it. */ +/* the factorization can be written a = l*u where */ +/* l is a product of permutation and unit lower */ +/* triangular matrices and u is upper triangular. */ + +/* ipvt integer(n) */ +/* an integer vector of pivot indices. */ + +/* rcond double precision */ +/* an estimate of the reciprocal condition of a . */ +/* for the system a*x = b , relative perturbations */ +/* in a and b of size epsilon may cause */ +/* relative perturbations in x of size epsilon/rcond . */ +/* if rcond is so small that the logical expression */ +/* 1.0 + rcond .eq. 1.0 */ +/* is true, then a may be singular to working */ +/* precision. in particular, rcond is zero if */ +/* exact singularity is detected or the estimate */ +/* underflows. */ + +/* z double precision(n) */ +/* a work vector whose contents are usually unimportant. */ +/* if a is close to a singular matrix, then z is */ +/* an approximate null vector in the sense that */ +/* norm(a*z) = rcond*norm(a)*norm(z) . */ + +/* linpack. this version dated 08/14/78 . */ +/* cleve moler, university of new mexico, argonne national lab. */ + +/* subroutines and functions */ + +/* linpack dgefa */ +/* blas daxpy,ddot,dscal,dasum */ +/* fortran dabs,dmax1,dsign */ + +/* internal variables */ + + + +/* compute 1-norm of a */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipvt; + --z__; + + /* Function Body */ + anorm = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + d__1 = anorm, d__2 = dasum_(n, &a[j * a_dim1 + 1], &c__1); + anorm = max(d__1,d__2); +/* L10: */ + } + +/* factor */ + + dgefa_(&a[a_offset], lda, n, &ipvt[1], &info); + +/* rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) . */ +/* estimate = norm(z)/norm(y) where a*z = y and trans(a)*y = e . */ +/* trans(a) is the transpose of a . the components of e are */ +/* chosen to cause maximum local growth in the elements of w where */ +/* trans(u)*w = e . the vectors are frequently rescaled to avoid */ +/* overflow. */ + +/* solve trans(u)*w = e */ + + ek = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + z__[j] = 0.; +/* L20: */ + } + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (z__[k] != 0.) { + d__1 = -z__[k]; + ek = d_sign(&ek, &d__1); + } + if ((d__1 = ek - z__[k], abs(d__1)) <= (d__2 = a[k + k * a_dim1], abs( + d__2))) { + goto L30; + } + s = (d__1 = a[k + k * a_dim1], abs(d__1)) / (d__2 = ek - z__[k], abs( + d__2)); + dscal_(n, &s, &z__[1], &c__1); + ek = s * ek; +L30: + wk = ek - z__[k]; + wkm = -ek - z__[k]; + s = abs(wk); + sm = abs(wkm); + if (a[k + k * a_dim1] == 0.) { + goto L40; + } + wk /= a[k + k * a_dim1]; + wkm /= a[k + k * a_dim1]; + goto L50; +L40: + wk = 1.; + wkm = 1.; +L50: + kp1 = k + 1; + if (kp1 > *n) { + goto L90; + } + i__2 = *n; + for (j = kp1; j <= i__2; ++j) { + sm += (d__1 = z__[j] + wkm * a[k + j * a_dim1], abs(d__1)); + z__[j] += wk * a[k + j * a_dim1]; + s += (d__1 = z__[j], abs(d__1)); +/* L60: */ + } + if (s >= sm) { + goto L80; + } + t = wkm - wk; + wk = wkm; + i__2 = *n; + for (j = kp1; j <= i__2; ++j) { + z__[j] += t * a[k + j * a_dim1]; +/* L70: */ + } +L80: +L90: + z__[k] = wk; +/* L100: */ + } + s = 1. / dasum_(n, &z__[1], &c__1); + dscal_(n, &s, &z__[1], &c__1); + +/* solve trans(l)*y = w */ + + i__1 = *n; + for (kb = 1; kb <= i__1; ++kb) { + k = *n + 1 - kb; + if (k < *n) { + i__2 = *n - k; + z__[k] += ddot_(&i__2, &a[k + 1 + k * a_dim1], &c__1, &z__[k + 1], + &c__1); + } + if ((d__1 = z__[k], abs(d__1)) <= 1.) { + goto L110; + } + s = 1. / (d__1 = z__[k], abs(d__1)); + dscal_(n, &s, &z__[1], &c__1); +L110: + l = ipvt[k]; + t = z__[l]; + z__[l] = z__[k]; + z__[k] = t; +/* L120: */ + } + s = 1. / dasum_(n, &z__[1], &c__1); + dscal_(n, &s, &z__[1], &c__1); + + ynorm = 1.; + +/* solve l*v = y */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + l = ipvt[k]; + t = z__[l]; + z__[l] = z__[k]; + z__[k] = t; + if (k < *n) { + i__2 = *n - k; + daxpy_(&i__2, &t, &a[k + 1 + k * a_dim1], &c__1, &z__[k + 1], & + c__1); + } + if ((d__1 = z__[k], abs(d__1)) <= 1.) { + goto L130; + } + s = 1. / (d__1 = z__[k], abs(d__1)); + dscal_(n, &s, &z__[1], &c__1); + ynorm = s * ynorm; +L130: +/* L140: */ + ; + } + s = 1. / dasum_(n, &z__[1], &c__1); + dscal_(n, &s, &z__[1], &c__1); + ynorm = s * ynorm; + +/* solve u*z = v */ + + i__1 = *n; + for (kb = 1; kb <= i__1; ++kb) { + k = *n + 1 - kb; + if ((d__1 = z__[k], abs(d__1)) <= (d__2 = a[k + k * a_dim1], abs(d__2) + )) { + goto L150; + } + s = (d__1 = a[k + k * a_dim1], abs(d__1)) / (d__2 = z__[k], abs(d__2)) + ; + dscal_(n, &s, &z__[1], &c__1); + ynorm = s * ynorm; +L150: + if (a[k + k * a_dim1] != 0.) { + z__[k] /= a[k + k * a_dim1]; + } + if (a[k + k * a_dim1] == 0.) { + z__[k] = 1.; + } + t = -z__[k]; + i__2 = k - 1; + daxpy_(&i__2, &t, &a[k * a_dim1 + 1], &c__1, &z__[1], &c__1); +/* L160: */ + } +/* make znorm = 1.0 */ + s = 1. / dasum_(n, &z__[1], &c__1); + dscal_(n, &s, &z__[1], &c__1); + ynorm = s * ynorm; + + if (anorm != 0.) { + *rcond = ynorm / anorm; + } + if (anorm == 0.) { + *rcond = 0.; + } + return 0; +} /* dgeco_ */ + +/* Subroutine */ int dgedi_(doublereal *a, integer *lda, integer *n, integer * + ipvt, doublereal *det, doublereal *work, integer *job) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + static integer i__, j, k, l; + static doublereal t; + static integer kb, kp1, nm1; + static doublereal ten; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dswap_(integer *, doublereal *, integer *, doublereal + *, integer *), daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + + +/* dgedi computes the determinant and inverse of a matrix */ +/* using the factors computed by dgeco or dgefa. */ + +/* on entry */ + +/* a double precision(lda, n) */ +/* the output from dgeco or dgefa. */ + +/* lda integer */ +/* the leading dimension of the array a . */ + +/* n integer */ +/* the order of the matrix a . */ + +/* ipvt integer(n) */ +/* the pivot vector from dgeco or dgefa. */ + +/* work double precision(n) */ +/* work vector. contents destroyed. */ + +/* job integer */ +/* = 11 both determinant and inverse. */ +/* = 01 inverse only. */ +/* = 10 determinant only. */ + +/* on return */ + +/* a inverse of original matrix if requested. */ +/* otherwise unchanged. */ + +/* det double precision(2) */ +/* determinant of original matrix if requested. */ +/* otherwise not referenced. */ +/* determinant = det(1) * 10.0**det(2) */ +/* with 1.0 .le. dabs(det(1)) .lt. 10.0 */ +/* or det(1) .eq. 0.0 . */ + +/* error condition */ + +/* a division by zero will occur if the input factor contains */ +/* a zero on the diagonal and the inverse is requested. */ +/* it will not occur if the subroutines are called correctly */ +/* and if dgeco has set rcond .gt. 0.0 or dgefa has set */ +/* info .eq. 0 . */ + +/* linpack. this version dated 08/14/78 . */ +/* cleve moler, university of new mexico, argonne national lab. */ + +/* subroutines and functions */ + +/* blas daxpy,dscal,dswap */ +/* fortran dabs,mod */ + +/* internal variables */ + + + +/* compute determinant */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1; + a -= a_offset; + --ipvt; + --det; + --work; + + /* Function Body */ + if (*job / 10 == 0) { + goto L70; + } + det[1] = 1.; + det[2] = 0.; + ten = 10.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (ipvt[i__] != i__) { + det[1] = -det[1]; + } + det[1] = a[i__ + i__ * a_dim1] * det[1]; +/* ...exit */ + if (det[1] == 0.) { + goto L60; + } +L10: + if (abs(det[1]) >= 1.) { + goto L20; + } + det[1] = ten * det[1]; + det[2] += -1.; + goto L10; +L20: +L30: + if (abs(det[1]) < ten) { + goto L40; + } + det[1] /= ten; + det[2] += 1.; + goto L30; +L40: +/* L50: */ + ; + } +L60: +L70: + +/* compute inverse(u) */ + + if (*job % 10 == 0) { + goto L150; + } + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; + t = -a[k + k * a_dim1]; + i__2 = k - 1; + dscal_(&i__2, &t, &a[k * a_dim1 + 1], &c__1); + kp1 = k + 1; + if (*n < kp1) { + goto L90; + } + i__2 = *n; + for (j = kp1; j <= i__2; ++j) { + t = a[k + j * a_dim1]; + a[k + j * a_dim1] = 0.; + daxpy_(&k, &t, &a[k * a_dim1 + 1], &c__1, &a[j * a_dim1 + 1], & + c__1); +/* L80: */ + } +L90: +/* L100: */ + ; + } + +/* form inverse(u)*inverse(l) */ + + nm1 = *n - 1; + if (nm1 < 1) { + goto L140; + } + i__1 = nm1; + for (kb = 1; kb <= i__1; ++kb) { + k = *n - kb; + kp1 = k + 1; + i__2 = *n; + for (i__ = kp1; i__ <= i__2; ++i__) { + work[i__] = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = 0.; +/* L110: */ + } + i__2 = *n; + for (j = kp1; j <= i__2; ++j) { + t = work[j]; + daxpy_(n, &t, &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); +/* L120: */ + } + l = ipvt[k]; + if (l != k) { + dswap_(n, &a[k * a_dim1 + 1], &c__1, &a[l * a_dim1 + 1], &c__1); + } +/* L130: */ + } +L140: +L150: + return 0; +} /* dgedi_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/polfit.c b/ext/f2c_math/polfit.c new file mode 100644 index 000000000..fe6fb0b18 --- /dev/null +++ b/ext/f2c_math/polfit.c @@ -0,0 +1,533 @@ +/* polfit.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__2 = 2; +static integer c__1 = 1; + +/* DECK POLFIT */ +/* Subroutine */ int polfit_(integer *n, real *x, real *y, real *w, integer * + maxdeg, integer *ndeg, real *eps, real *r__, integer *ierr, real *a) +{ + /* Initialized data */ + + static real co[12] /* was [4][3] */ = { -13.08685f,-2.4648165f, + -3.3846535f,-1.2973162f,-3.3381146f,-1.7812271f,-3.2578406f, + -1.6589279f,-1.6282703f,-1.3152745f,-3.2640179f,-1.9829776f }; + + /* System generated locals */ + integer i__1; + real r__1; + + /* Builtin functions */ + double sqrt(doublereal); + + /* Local variables */ + static real f; + static integer i__, j, m, k1, k2, k3, k4, k5; + static real w1, w11, xm, yp; + static integer jp1; + static real den, sig; + static integer k1pj, k2pj, k4pi, k5pi, k3pi, mop1; + static real degf; + static integer nder; + static real sigj; + static integer ksig, jpas; + static real temp, etst; + static doublereal temd1, temd2; + static integer idegf, nfail; + static real fcrit, sigjm1, sigpas; + extern /* Subroutine */ int pvalue_(integer *, integer *, real *, real *, + real *, real *), xermsg_(char *, char *, char *, integer *, + integer *, ftnlen, ftnlen, ftnlen); + +/* ***BEGIN PROLOGUE POLFIT */ +/* ***PURPOSE Fit discrete data in a least squares sense by polynomials */ +/* in one variable. */ +/* ***LIBRARY SLATEC */ +/* ***CATEGORY K1A1A2 */ +/* ***TYPE SINGLE PRECISION (POLFIT-S, DPOLFT-D) */ +/* ***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT */ +/* ***AUTHOR Shampine, L. F., (SNLA) */ +/* Davenport, S. M., (SNLA) */ +/* Huddleston, R. E., (SNLL) */ +/* ***DESCRIPTION */ + +/* Abstract */ + +/* Given a collection of points X(I) and a set of values Y(I) which */ +/* correspond to some function or measurement at each of the X(I), */ +/* subroutine POLFIT computes the weighted least-squares polynomial */ +/* fits of all degrees up to some degree either specified by the user */ +/* or determined by the routine. The fits thus obtained are in */ +/* orthogonal polynomial form. Subroutine PVALUE may then be */ +/* called to evaluate the fitted polynomials and any of their */ +/* derivatives at any point. The subroutine PCOEF may be used to */ +/* express the polynomial fits as powers of (X-C) for any specified */ +/* point C. */ + +/* The parameters for POLFIT are */ + +/* Input -- */ +/* N - the number of data points. The arrays X, Y and W */ +/* must be dimensioned at least N (N .GE. 1). */ +/* X - array of values of the independent variable. These */ +/* values may appear in any order and need not all be */ +/* distinct. */ +/* Y - array of corresponding function values. */ +/* W - array of positive values to be used as weights. If */ +/* W(1) is negative, POLFIT will set all the weights */ +/* to 1.0, which means unweighted least squares error */ +/* will be minimized. To minimize relative error, the */ +/* user should set the weights to: W(I) = 1.0/Y(I)**2, */ +/* I = 1,...,N . */ +/* MAXDEG - maximum degree to be allowed for polynomial fit. */ +/* MAXDEG may be any non-negative integer less than N. */ +/* Note -- MAXDEG cannot be equal to N-1 when a */ +/* statistical test is to be used for degree selection, */ +/* i.e., when input value of EPS is negative. */ +/* EPS - specifies the criterion to be used in determining */ +/* the degree of fit to be computed. */ +/* (1) If EPS is input negative, POLFIT chooses the */ +/* degree based on a statistical F test of */ +/* significance. One of three possible */ +/* significance levels will be used: .01, .05 or */ +/* .10. If EPS=-1.0 , the routine will */ +/* automatically select one of these levels based */ +/* on the number of data points and the maximum */ +/* degree to be considered. If EPS is input as */ +/* -.01, -.05, or -.10, a significance level of */ +/* .01, .05, or .10, respectively, will be used. */ +/* (2) If EPS is set to 0., POLFIT computes the */ +/* polynomials of degrees 0 through MAXDEG . */ +/* (3) If EPS is input positive, EPS is the RMS */ +/* error tolerance which must be satisfied by the */ +/* fitted polynomial. POLFIT will increase the */ +/* degree of fit until this criterion is met or */ +/* until the maximum degree is reached. */ + +/* Output -- */ +/* NDEG - degree of the highest degree fit computed. */ +/* EPS - RMS error of the polynomial of degree NDEG . */ +/* R - vector of dimension at least NDEG containing values */ +/* of the fit of degree NDEG at each of the X(I) . */ +/* Except when the statistical test is used, these */ +/* values are more accurate than results from subroutine */ +/* PVALUE normally are. */ +/* IERR - error flag with the following possible values. */ +/* 1 -- indicates normal execution, i.e., either */ +/* (1) the input value of EPS was negative, and the */ +/* computed polynomial fit of degree NDEG */ +/* satisfies the specified F test, or */ +/* (2) the input value of EPS was 0., and the fits of */ +/* all degrees up to MAXDEG are complete, or */ +/* (3) the input value of EPS was positive, and the */ +/* polynomial of degree NDEG satisfies the RMS */ +/* error requirement. */ +/* 2 -- invalid input parameter. At least one of the input */ +/* parameters has an illegal value and must be corrected */ +/* before POLFIT can proceed. Valid input results */ +/* when the following restrictions are observed */ +/* N .GE. 1 */ +/* 0 .LE. MAXDEG .LE. N-1 for EPS .GE. 0. */ +/* 0 .LE. MAXDEG .LE. N-2 for EPS .LT. 0. */ +/* W(1)=-1.0 or W(I) .GT. 0., I=1,...,N . */ +/* 3 -- cannot satisfy the RMS error requirement with a */ +/* polynomial of degree no greater than MAXDEG . Best */ +/* fit found is of degree MAXDEG . */ +/* 4 -- cannot satisfy the test for significance using */ +/* current value of MAXDEG . Statistically, the */ +/* best fit found is of order NORD . (In this case, */ +/* NDEG will have one of the values: MAXDEG-2, */ +/* MAXDEG-1, or MAXDEG). Using a higher value of */ +/* MAXDEG may result in passing the test. */ +/* A - work and output array having at least 3N+3MAXDEG+3 */ +/* locations */ + +/* Note - POLFIT calculates all fits of degrees up to and including */ +/* NDEG . Any or all of these fits can be evaluated or */ +/* expressed as powers of (X-C) using PVALUE and PCOEF */ +/* after just one call to POLFIT . */ + +/* ***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 PVALUE, XERMSG */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 740601 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) */ +/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* 920527 Corrected erroneous statements in DESCRIPTION. (WRB) */ +/* ***END PROLOGUE POLFIT */ + /* Parameter adjustments */ + --a; + --r__; + --w; + --y; + --x; + + /* Function Body */ +/* ***FIRST EXECUTABLE STATEMENT POLFIT */ + m = abs(*n); + if (m == 0) { + goto L30; + } + if (*maxdeg < 0) { + goto L30; + } + a[1] = (real) (*maxdeg); + mop1 = *maxdeg + 1; + if (m < mop1) { + goto L30; + } + if (*eps < 0.f && m == mop1) { + goto L30; + } + xm = (real) m; + etst = *eps * *eps * xm; + if (w[1] < 0.f) { + goto L2; + } + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (w[i__] <= 0.f) { + goto L30; + } +/* L1: */ + } + goto L4; +L2: + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* L3: */ + w[i__] = 1.f; + } +L4: + if (*eps >= 0.f) { + goto L8; + } + +/* DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR */ +/* CHOOSING DEGREE OF POLYNOMIAL FIT */ + + if (*eps > -.55f) { + goto L5; + } + idegf = m - *maxdeg - 1; + ksig = 1; + if (idegf < 10) { + ksig = 2; + } + if (idegf < 5) { + ksig = 3; + } + goto L8; +L5: + ksig = 1; + if (*eps < -.03f) { + ksig = 2; + } + if (*eps < -.07f) { + ksig = 3; + } + +/* INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING */ + +L8: + k1 = *maxdeg + 1; + k2 = k1 + *maxdeg; + k3 = k2 + *maxdeg + 2; + k4 = k3 + m; + k5 = k4 + m; + i__1 = k4; + for (i__ = 2; i__ <= i__1; ++i__) { +/* L9: */ + a[i__] = 0.f; + } + w11 = 0.f; + if (*n < 0) { + goto L11; + } + +/* UNCONSTRAINED CASE */ + + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + a[k4pi] = 1.f; +/* L10: */ + w11 += w[i__]; + } + goto L13; + +/* CONSTRAINED CASE */ + +L11: + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; +/* L12: */ +/* Computing 2nd power */ + r__1 = a[k4pi]; + w11 += w[i__] * (r__1 * r__1); + } + +/* COMPUTE FIT OF DEGREE ZERO */ + +L13: + temd1 = 0.; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + temd1 += (doublereal) w[i__] * (doublereal) y[i__] * (doublereal) a[ + k4pi]; +/* L14: */ + } + temd1 /= (doublereal) w11; + a[k2 + 1] = temd1; + sigj = 0.f; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + k5pi = k5 + i__; + temd2 = temd1 * (doublereal) a[k4pi]; + r__[i__] = temd2; + a[k5pi] = temd2 - (doublereal) r__[i__]; +/* L15: */ +/* Computing 2nd power */ + r__1 = y[i__] - r__[i__] - a[k5pi]; + sigj += w[i__] * (r__1 * r__1); + } + j = 0; + +/* SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION */ + + if (*eps < 0.f) { + goto L24; + } else if (*eps == 0) { + goto L26; + } else { + goto L27; + } + +/* INCREMENT DEGREE */ + +L16: + ++j; + jp1 = j + 1; + k1pj = k1 + j; + k2pj = k2 + j; + sigjm1 = sigj; + +/* COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 */ + + if (j > 1) { + a[k1pj] = w11 / w1; + } + +/* COMPUTE NEW A COEFFICIENT */ + + temd1 = 0.; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + temd2 = a[k4pi]; + temd1 += (doublereal) x[i__] * (doublereal) w[i__] * temd2 * temd2; +/* L18: */ + } + a[jp1] = temd1 / (doublereal) w11; + +/* EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS */ + + w1 = w11; + w11 = 0.f; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k3pi = k3 + i__; + k4pi = k4 + i__; + temp = a[k3pi]; + a[k3pi] = a[k4pi]; + a[k4pi] = (x[i__] - a[jp1]) * a[k3pi] - a[k1pj] * temp; +/* L19: */ +/* Computing 2nd power */ + r__1 = a[k4pi]; + w11 += w[i__] * (r__1 * r__1); + } + +/* GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE */ +/* PRECISION */ + + temd1 = 0.; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + k5pi = k5 + i__; + temd2 = (doublereal) w[i__] * (doublereal) (y[i__] - r__[i__] - a[ + k5pi]) * (doublereal) a[k4pi]; +/* L20: */ + temd1 += temd2; + } + temd1 /= (doublereal) w11; + a[k2pj + 1] = temd1; + +/* UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND */ +/* ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE */ +/* COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, */ +/* THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST */ +/* SIGNIFICANT BITS ARE IN A(K5PI) . */ + + sigj = 0.f; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + k4pi = k4 + i__; + k5pi = k5 + i__; + temd2 = (doublereal) r__[i__] + (doublereal) a[k5pi] + temd1 * ( + doublereal) a[k4pi]; + r__[i__] = temd2; + a[k5pi] = temd2 - (doublereal) r__[i__]; +/* L21: */ +/* Computing 2nd power */ + r__1 = y[i__] - r__[i__] - a[k5pi]; + sigj += w[i__] * (r__1 * r__1); + } + +/* SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE */ +/* MAXDEG HAS BEEN REACHED */ + + if (*eps < 0.f) { + goto L23; + } else if (*eps == 0) { + goto L26; + } else { + goto L27; + } + +/* COMPUTE F STATISTICS (INPUT EPS .LT. 0.) */ + +L23: + if (sigj == 0.f) { + goto L29; + } + degf = (real) (m - j - 1); + den = (co[(ksig << 2) - 1] * degf + 1.f) * degf; + fcrit = ((co[(ksig << 2) - 2] * degf + co[(ksig << 2) - 3]) * degf + co[( + ksig << 2) - 4]) / den; + fcrit *= fcrit; + f = (sigjm1 - sigj) * degf / sigj; + if (f < fcrit) { + goto L25; + } + +/* POLYNOMIAL OF DEGREE J SATISFIES F TEST */ + +L24: + sigpas = sigj; + jpas = j; + nfail = 0; + if (*maxdeg == j) { + goto L32; + } + goto L16; + +/* POLYNOMIAL OF DEGREE J FAILS F TEST. IF THERE HAVE BEEN THREE */ +/* SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. */ + +L25: + ++nfail; + if (nfail >= 3) { + goto L29; + } + if (*maxdeg == j) { + goto L32; + } + goto L16; + +/* RAISE THE DEGREE IF DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT */ +/* EPS = 0.) */ + +L26: + if (*maxdeg == j) { + goto L28; + } + goto L16; + +/* SEE IF RMS ERROR CRITERION IS SATISFIED (INPUT EPS .GT. 0.) */ + +L27: + if (sigj <= etst) { + goto L28; + } + if (*maxdeg == j) { + goto L31; + } + goto L16; + +/* RETURNS */ + +L28: + *ierr = 1; + *ndeg = j; + sig = sigj; + goto L33; +L29: + *ierr = 1; + *ndeg = jpas; + sig = sigpas; + goto L33; +L30: + *ierr = 2; + xermsg_("SLATEC", "POLFIT", "INVALID INPUT PARAMETER.", &c__2, &c__1, ( + ftnlen)6, (ftnlen)6, (ftnlen)24); + goto L37; +L31: + *ierr = 3; + *ndeg = *maxdeg; + sig = sigj; + goto L33; +L32: + *ierr = 4; + *ndeg = jpas; + sig = sigpas; + +L33: + a[k3] = (real) (*ndeg); + +/* WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT */ +/* ALL THE DATA POINTS IF R DOES NOT ALREADY CONTAIN THESE VALUES */ + + if (*eps >= 0.f || *ndeg == *maxdeg) { + goto L36; + } + nder = 0; + i__1 = m; + for (i__ = 1; i__ <= i__1; ++i__) { + pvalue_(ndeg, &nder, &x[i__], &r__[i__], &yp, &a[1]); +/* L35: */ + } +L36: + *eps = sqrt(sig / xm); +L37: + return 0; +} /* polfit_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/pvalue.c b/ext/f2c_math/pvalue.c new file mode 100644 index 000000000..033d5f619 --- /dev/null +++ b/ext/f2c_math/pvalue.c @@ -0,0 +1,255 @@ +/* pvalue.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__1 = 1; +static integer c__8 = 8; +static integer c__2 = 2; +static integer c__5 = 5; + +/* DECK PVALUE */ +/* Subroutine */ int pvalue_(integer *l, integer *nder, real *x, real *yfit, + real *yp, real *a) +{ + /* System generated locals */ + address a__1[5]; + integer i__1, i__2, i__3[5]; + char ch__1[150]; + + /* 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 i__, n, k1, k2, k3, k4; + static real cc; + static integer ic, kc, in, k1i, lm1, lp1; + static real dif; + static integer k3p1, k4p1, ndo; + static real val; + static integer ilo, iup, ndp1, inp1, k3pn, k4pn, nord; + static char xern1[8], xern2[8]; + static integer maxord; + extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *, + integer *, ftnlen, ftnlen, ftnlen); + + /* Fortran I/O blocks */ + static icilist io___28 = { 0, xern1, 0, "(I8)", 8, 1 }; + static icilist io___30 = { 0, xern2, 0, "(I8)", 8, 1 }; + + +/* ***BEGIN PROLOGUE PVALUE */ +/* ***PURPOSE Use the coefficients generated by POLFIT 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 SINGLE PRECISION (PVALUE-S, DP1VLU-D) */ +/* ***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION */ +/* ***AUTHOR Shampine, L. F., (SNLA) */ +/* Davenport, S. M., (SNLA) */ +/* ***DESCRIPTION */ + +/* Written by L. F. Shampine and S. M. Davenport. */ + +/* Abstract */ + +/* The subroutine PVALUE uses the coefficients generated by POLFIT */ +/* 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 PVALUE are */ + +/* Input -- */ +/* 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 POLFIT . */ +/* 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 POLFIT . */ + +/* Output -- */ +/* 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) */ +/* 890531 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 PVALUE */ +/* ***FIRST EXECUTABLE STATEMENT PVALUE */ + /* Parameter adjustments */ + --a; + --yp; + + /* Function Body */ + if (*l < 0) { + goto L12; + } + ndo = max(*nder,0); + ndo = min(ndo,*l); + maxord = a[1] + .5f; + k1 = maxord + 1; + k2 = k1 + maxord; + k3 = k2 + maxord + 2; + nord = a[k3] + .5f; + 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.f; + } +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.f; + } + 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: + s_wsfi(&io___28); + do_fio(&c__1, (char *)&(*l), (ftnlen)sizeof(integer)); + e_wsfi(); + s_wsfi(&io___30); + 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 POLFIT -- EXECUTION TERMINATED."; + s_cat(ch__1, a__1, i__3, &c__5, (ftnlen)150); + xermsg_("SLATEC", "PVALUE", ch__1, &c__8, &c__2, (ftnlen)6, (ftnlen)6, ( + ftnlen)150); + return 0; + +L12: + xermsg_("SLATEC", "PVALUE", "INVALID INPUT PARAMETER. ORDER OF POLYNOMI" + "AL EVALUATION REQUESTED IS NEGATIVE -- EXECUTION TERMINATED.", & + c__2, &c__2, (ftnlen)6, (ftnlen)6, (ftnlen)103); + return 0; +} /* pvalue_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/xercnt.c b/ext/f2c_math/xercnt.c new file mode 100644 index 000000000..6c3774de4 --- /dev/null +++ b/ext/f2c_math/xercnt.c @@ -0,0 +1,83 @@ +/* xercnt.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* DECK XERCNT */ +/* Subroutine */ int xercnt_(char *librar, char *subrou, char *messg, integer + *nerr, integer *level, integer *kontrl, ftnlen librar_len, ftnlen + subrou_len, ftnlen messg_len) +{ +/* ***BEGIN PROLOGUE XERCNT */ +/* ***SUBSIDIARY */ +/* ***PURPOSE Allow user control over handling of errors. */ +/* ***LIBRARY SLATEC (XERROR) */ +/* ***CATEGORY R3C */ +/* ***TYPE ALL (XERCNT-A) */ +/* ***KEYWORDS ERROR, XERROR */ +/* ***AUTHOR Jones, R. E., (SNLA) */ +/* ***DESCRIPTION */ + +/* Abstract */ +/* Allows user control over handling of individual errors. */ +/* Just after each message is recorded, but before it is */ +/* processed any further (i.e., before it is printed or */ +/* a decision to abort is made), a call is made to XERCNT. */ +/* If the user has provided his own version of XERCNT, he */ +/* can then override the value of KONTROL used in processing */ +/* this message by redefining its value. */ +/* KONTRL may be set to any value from -2 to 2. */ +/* The meanings for KONTRL are the same as in XSETF, except */ +/* that the value of KONTRL changes only for this message. */ +/* If KONTRL is set to a value outside the range from -2 to 2, */ +/* it will be moved back into that range. */ + +/* Description of Parameters */ + +/* --Input-- */ +/* LIBRAR - the library that the routine is in. */ +/* SUBROU - the subroutine that XERMSG is being called from */ +/* MESSG - the first 20 characters of the error message. */ +/* NERR - same as in the call to XERMSG. */ +/* LEVEL - same as in the call to XERMSG. */ +/* KONTRL - the current value of the control flag as set */ +/* by a call to XSETF. */ + +/* --Output-- */ +/* KONTRL - the new value of KONTRL. If KONTRL is not */ +/* defined, it will remain at its original value. */ +/* This changed value of control affects only */ +/* the current occurrence of the current message. */ + +/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ +/* Error-handling Package, SAND82-0800, Sandia */ +/* Laboratories, 1982. */ +/* ***ROUTINES CALLED (NONE) */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 790801 DATE WRITTEN */ +/* 861211 REVISION DATE from Version 3.2 */ +/* 891214 Prologue converted to Version 4.0 format. (BAB) */ +/* 900206 Routine changed from user-callable to subsidiary. (WRB) */ +/* 900510 Changed calling sequence to include LIBRARY and SUBROUTINE */ +/* names, changed routine name from XERCTL to XERCNT. (RWC) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* ***END PROLOGUE XERCNT */ +/* ***FIRST EXECUTABLE STATEMENT XERCNT */ + return 0; +} /* xercnt_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/xerhlt.c b/ext/f2c_math/xerhlt.c new file mode 100644 index 000000000..e7373a096 --- /dev/null +++ b/ext/f2c_math/xerhlt.c @@ -0,0 +1,78 @@ +/* xerhlt.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__9 = 9; +static integer c__1 = 1; + +/* DECK XERHLT */ +/* Subroutine */ int xerhlt_(char *messg, ftnlen messg_len) +{ + /* Builtin functions */ + integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), + e_wsle(void); + /* Subroutine */ int s_stop(char *, ftnlen); + + /* Fortran I/O blocks */ + static cilist io___1 = { 0, 6, 0, 0, 0 }; + + +/* ***BEGIN PROLOGUE XERHLT */ +/* ***SUBSIDIARY */ +/* ***PURPOSE Abort program execution and print error message. */ +/* ***LIBRARY SLATEC (XERROR) */ +/* ***CATEGORY R3C */ +/* ***TYPE ALL (XERHLT-A) */ +/* ***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR */ +/* ***AUTHOR Jones, R. E., (SNLA) */ +/* ***DESCRIPTION */ + +/* Abstract */ +/* ***Note*** machine dependent routine */ +/* XERHLT aborts the execution of the program. */ +/* The error message causing the abort is given in the calling */ +/* sequence, in case one needs it for printing on a dayfile, */ +/* for example. */ + +/* Description of Parameters */ +/* MESSG is as in XERMSG. */ + +/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ +/* Error-handling Package, SAND82-0800, Sandia */ +/* Laboratories, 1982. */ +/* ***ROUTINES CALLED (NONE) */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 790801 DATE WRITTEN */ +/* 861211 REVISION DATE from Version 3.2 */ +/* 891214 Prologue converted to Version 4.0 format. (BAB) */ +/* 900206 Routine changed from user-callable to subsidiary. (WRB) */ +/* 900510 Changed calling sequence to delete length of character */ +/* and changed routine name from XERABT to XERHLT. (RWC) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* ***END PROLOGUE XERHLT */ +/* ***FIRST EXECUTABLE STATEMENT XERHLT */ + s_wsle(&io___1); + do_lio(&c__9, &c__1, "stopping...", (ftnlen)11); + e_wsle(); + s_stop("", (ftnlen)0); + return 0; +} /* xerhlt_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/xermsg.c b/ext/f2c_math/xermsg.c new file mode 100644 index 000000000..34cdc40ff --- /dev/null +++ b/ext/f2c_math/xermsg.c @@ -0,0 +1,475 @@ +/* xermsg.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__2 = 2; +static integer c__0 = 0; +static logical c_false = FALSE_; +static integer c__4 = 4; +static integer c_n1 = -1; +static integer c__72 = 72; +static integer c__1 = 1; +static logical c_true = TRUE_; + +/* 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]; + + /* 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 */ + static integer i__, lerr; + static char temp[72]; + extern /* Subroutine */ int fdump_(void); + static char xlibr[8]; + static integer ltemp, kount; + static char xsubr[8]; + extern integer j4save_(integer *, integer *, logical *); + static integer llevel, maxmes; + static char lfirst[20]; + extern /* Subroutine */ int xercnt_(char *, char *, char *, integer *, + integer *, integer *, ftnlen, ftnlen, ftnlen); + static integer lkntrl, kdummy; + extern /* Subroutine */ int xerhlt_(char *, ftnlen); + static integer mkntrl; + extern /* Subroutine */ int xersve_(char *, char *, char *, integer *, + integer *, integer *, integer *, ftnlen, ftnlen, ftnlen), xerprn_( + char *, integer *, char *, integer *, ftnlen, ftnlen); + + /* Fortran I/O blocks */ + static icilist io___14 = { 0, temp, 0, "('ERROR NUMBER = ', I8)", 72, 1 }; + + +/* ***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) { + s_wsfi(&io___14); + 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_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/xerprn.c b/ext/f2c_math/xerprn.c new file mode 100644 index 000000000..b0bc973c7 --- /dev/null +++ b/ext/f2c_math/xerprn.c @@ -0,0 +1,316 @@ +/* xerprn.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__4 = 4; +static integer c__1 = 1; + +/* DECK XERPRN */ +/* Subroutine */ int xerprn_(char *prefix, integer *npref, char *messg, + integer *nwrap, ftnlen prefix_len, ftnlen messg_len) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Builtin functions */ + integer i_len(char *, ftnlen); + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void), + i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *, + ftnlen, ftnlen); + + /* Local variables */ + static integer i__, n, iu[5]; + static char cbuff[148]; + static integer lpref, nextc, lwrap, nunit; + extern integer i1mach_(integer *); + static integer lpiece, idelta, lenmsg; + extern /* Subroutine */ int xgetua_(integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___9 = { 0, 0, 0, "(A)", 0 }; + static cilist io___13 = { 0, 0, 0, "(A)", 0 }; + + +/* ***BEGIN PROLOGUE XERPRN */ +/* ***SUBSIDIARY */ +/* ***PURPOSE Print error messages processed by XERMSG. */ +/* ***LIBRARY SLATEC (XERROR) */ +/* ***CATEGORY R3C */ +/* ***TYPE ALL (XERPRN-A) */ +/* ***KEYWORDS ERROR MESSAGES, PRINTING, XERROR */ +/* ***AUTHOR Fong, Kirby, (NMFECC at LLNL) */ +/* ***DESCRIPTION */ + +/* This routine sends one or more lines to each of the (up to five) */ +/* logical units to which error messages are to be sent. This routine */ +/* is called several times by XERMSG, sometimes with a single line to */ +/* print and sometimes with a (potentially very long) message that may */ +/* wrap around into multiple lines. */ + +/* PREFIX Input argument of type CHARACTER. This argument contains */ +/* characters to be put at the beginning of each line before */ +/* the body of the message. No more than 16 characters of */ +/* PREFIX will be used. */ + +/* NPREF Input argument of type INTEGER. This argument is the number */ +/* of characters to use from PREFIX. If it is negative, the */ +/* intrinsic function LEN is used to determine its length. If */ +/* it is zero, PREFIX is not used. If it exceeds 16 or if */ +/* LEN(PREFIX) exceeds 16, only the first 16 characters will be */ +/* used. If NPREF is positive and the length of PREFIX is less */ +/* than NPREF, a copy of PREFIX extended with blanks to length */ +/* NPREF will be used. */ + +/* MESSG Input argument of type CHARACTER. This is the text of a */ +/* message to be printed. If it is a long message, it will be */ +/* broken into pieces for printing on multiple lines. Each line */ +/* will start with the appropriate prefix and be followed by a */ +/* piece of the message. NWRAP is the number of characters per */ +/* piece; that is, after each NWRAP characters, we break and */ +/* start a new line. In addition the characters '$$' embedded */ +/* in MESSG are a sentinel for a new line. The counting of */ +/* characters up to NWRAP starts over for each new line. The */ +/* value of NWRAP typically used by XERMSG is 72 since many */ +/* older error messages in the SLATEC Library are laid out to */ +/* rely on wrap-around every 72 characters. */ + +/* NWRAP Input argument of type INTEGER. This gives the maximum size */ +/* piece into which to break MESSG for printing on multiple */ +/* lines. An embedded '$$' ends a line, and the count restarts */ +/* at the following character. If a line break does not occur */ +/* on a blank (it would split a word) that word is moved to the */ +/* next line. Values of NWRAP less than 16 will be treated as */ +/* 16. Values of NWRAP greater than 132 will be treated as 132. */ +/* The actual line length will be NPREF + NWRAP after NPREF has */ +/* been adjusted to fall between 0 and 16 and NWRAP has been */ +/* adjusted to fall between 16 and 132. */ + +/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ +/* Error-handling Package, SAND82-0800, Sandia */ +/* Laboratories, 1982. */ +/* ***ROUTINES CALLED I1MACH, XGETUA */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 880621 DATE WRITTEN */ +/* 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF */ +/* JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK */ +/* THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE */ +/* SLASH CHARACTER IN FORMAT STATEMENTS. */ +/* 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO */ +/* STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK */ +/* LINES TO BE PRINTED. */ +/* 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF */ +/* CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. */ +/* 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. */ +/* 891214 Prologue converted to Version 4.0 format. (WRB) */ +/* 900510 Added code to break messages between words. (RWC) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* ***END PROLOGUE XERPRN */ +/* ***FIRST EXECUTABLE STATEMENT XERPRN */ + xgetua_(iu, &nunit); + +/* A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD */ +/* ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD */ +/* ERROR MESSAGE UNIT. */ + + n = i1mach_(&c__4); + i__1 = nunit; + for (i__ = 1; i__ <= i__1; ++i__) { + if (iu[i__ - 1] == 0) { + iu[i__ - 1] = n; + } +/* L10: */ + } + +/* LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE */ +/* BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING */ +/* THE REST OF THIS ROUTINE. */ + + if (*npref < 0) { + lpref = i_len(prefix, prefix_len); + } else { + lpref = *npref; + } + lpref = min(16,lpref); + if (lpref != 0) { + s_copy(cbuff, prefix, lpref, prefix_len); + } + +/* LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE */ +/* TIME FROM MESSG TO PRINT ON ONE LINE. */ + +/* Computing MAX */ + i__1 = 16, i__2 = min(132,*nwrap); + lwrap = max(i__1,i__2); + +/* SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. */ + + lenmsg = i_len(messg, messg_len); + n = lenmsg; + i__1 = n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*(unsigned char *)&messg[lenmsg - 1] != ' ') { + goto L30; + } + --lenmsg; +/* L20: */ + } +L30: + +/* IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. */ + + if (lenmsg == 0) { + i__1 = lpref; + s_copy(cbuff + i__1, " ", lpref + 1 - i__1, (ftnlen)1); + i__1 = nunit; + for (i__ = 1; i__ <= i__1; ++i__) { + io___9.ciunit = iu[i__ - 1]; + s_wsfe(&io___9); + do_fio(&c__1, cbuff, lpref + 1); + e_wsfe(); +/* L40: */ + } + return 0; + } + +/* SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING */ +/* STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. */ +/* WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. */ +/* WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. */ + +/* WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE */ +/* INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE */ +/* OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH */ +/* OF THE SECOND ARGUMENT. */ + +/* THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE */ +/* FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER */ +/* OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT */ +/* POSITION NEXTC. */ + +/* LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE */ +/* REMAINDER OF THE CHARACTER STRING. LPIECE */ +/* SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, */ +/* WHICHEVER IS LESS. */ + +/* LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: */ +/* NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE */ +/* PRINT NOTHING TO AVOID PRODUCING UNNECESSARY */ +/* BLANK LINES. THIS TAKES CARE OF THE SITUATION */ +/* WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF */ +/* EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE */ +/* SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC */ +/* SHOULD BE INCREMENTED BY 2. */ + +/* LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. */ + +/* ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 */ +/* RESET LPIECE = LPIECE-1. NOTE THAT THIS */ +/* PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. */ +/* LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY */ +/* AT THE END OF A LINE. */ + + nextc = 1; +L50: + lpiece = i_indx(messg + (nextc - 1), "$$", lenmsg - (nextc - 1), (ftnlen) + 2); + if (lpiece == 0) { + +/* THERE WAS NO NEW LINE SENTINEL FOUND. */ + + idelta = 0; +/* Computing MIN */ + i__1 = lwrap, i__2 = lenmsg + 1 - nextc; + lpiece = min(i__1,i__2); + if (lpiece < lenmsg + 1 - nextc) { + for (i__ = lpiece + 1; i__ >= 2; --i__) { + i__1 = nextc + i__ - 2; + if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, (ftnlen) + 1) == 0) { + lpiece = i__ - 1; + idelta = 1; + goto L54; + } +/* L52: */ + } + } +L54: + i__1 = lpref; + s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, + nextc + lpiece - 1 - (nextc - 1)); + nextc = nextc + lpiece + idelta; + } else if (lpiece == 1) { + +/* WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). */ +/* DON'T PRINT A BLANK LINE. */ + + nextc += 2; + goto L50; + } else if (lpiece > lwrap + 1) { + +/* LPIECE SHOULD BE SET DOWN TO LWRAP. */ + + idelta = 0; + lpiece = lwrap; + for (i__ = lpiece + 1; i__ >= 2; --i__) { + i__1 = nextc + i__ - 2; + if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, (ftnlen)1) == + 0) { + lpiece = i__ - 1; + idelta = 1; + goto L58; + } +/* L56: */ + } +L58: + i__1 = lpref; + s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, + nextc + lpiece - 1 - (nextc - 1)); + nextc = nextc + lpiece + idelta; + } else { + +/* IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. */ +/* WE SHOULD DECREMENT LPIECE BY ONE. */ + + --lpiece; + i__1 = lpref; + s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, + nextc + lpiece - 1 - (nextc - 1)); + nextc = nextc + lpiece + 2; + } + +/* PRINT */ + + i__1 = nunit; + for (i__ = 1; i__ <= i__1; ++i__) { + io___13.ciunit = iu[i__ - 1]; + s_wsfe(&io___13); + do_fio(&c__1, cbuff, lpref + lpiece); + e_wsfe(); +/* L60: */ + } + + if (nextc <= lenmsg) { + goto L50; + } + return 0; +} /* xerprn_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/xersve.c b/ext/f2c_math/xersve.c new file mode 100644 index 000000000..7b54dcc5a --- /dev/null +++ b/ext/f2c_math/xersve.c @@ -0,0 +1,239 @@ +/* xersve.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__4 = 4; +static integer c__1 = 1; + +/* DECK XERSVE */ +/* Subroutine */ int xersve_(char *librar, char *subrou, char *messg, integer + *kflag, integer *nerr, integer *level, integer *icount, ftnlen + librar_len, ftnlen subrou_len, ftnlen messg_len) +{ + /* Initialized data */ + + static integer kountx = 0; + static integer nmsg = 0; + + /* Format strings */ + static char fmt_9000[] = "(\0020 ERROR MESSAGE SUMMARY\002/\002" + " LIBRARY SUBROUTINE MESSAGE START NERR\002,\002 " + " LEVEL COUNT\002)"; + static char fmt_9010[] = "(1x,a,3x,a,3x,a,3i10)"; + static char fmt_9020[] = "(\0020OTHER ERRORS NOT INDIVIDUALLY TABULATED " + "= \002,i10)"; + static char fmt_9030[] = "(1x)"; + + /* System generated locals */ + integer i__1, i__2; + + /* Builtin functions */ + integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen); + /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); + integer s_cmp(char *, char *, ftnlen, ftnlen); + + /* Local variables */ + static integer i__; + static char lib[8], mes[20], sub[8]; + static integer lun[5], iunit, kunit, nunit, kount[10]; + extern integer i1mach_(integer *); + static char libtab[8*10], mestab[20*10]; + static integer nertab[10], levtab[10]; + static char subtab[8*10]; + extern /* Subroutine */ int xgetua_(integer *, integer *); + + /* Fortran I/O blocks */ + static cilist io___7 = { 0, 0, 0, fmt_9000, 0 }; + static cilist io___9 = { 0, 0, 0, fmt_9010, 0 }; + static cilist io___16 = { 0, 0, 0, fmt_9020, 0 }; + static cilist io___17 = { 0, 0, 0, fmt_9030, 0 }; + + +/* ***BEGIN PROLOGUE XERSVE */ +/* ***SUBSIDIARY */ +/* ***PURPOSE Record that an error has occurred. */ +/* ***LIBRARY SLATEC (XERROR) */ +/* ***CATEGORY R3 */ +/* ***TYPE ALL (XERSVE-A) */ +/* ***KEYWORDS ERROR, XERROR */ +/* ***AUTHOR Jones, R. E., (SNLA) */ +/* ***DESCRIPTION */ + +/* *Usage: */ + +/* INTEGER KFLAG, NERR, LEVEL, ICOUNT */ +/* CHARACTER * (len) LIBRAR, SUBROU, MESSG */ + +/* CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) */ + +/* *Arguments: */ + +/* LIBRAR :IN is the library that the message is from. */ +/* SUBROU :IN is the subroutine that the message is from. */ +/* MESSG :IN is the message to be saved. */ +/* KFLAG :IN indicates the action to be performed. */ +/* when KFLAG > 0, the message in MESSG is saved. */ +/* when KFLAG=0 the tables will be dumped and */ +/* cleared. */ +/* when KFLAG < 0, the tables will be dumped and */ +/* not cleared. */ +/* NERR :IN is the error number. */ +/* LEVEL :IN is the error severity. */ +/* ICOUNT :OUT the number of times this message has been seen, */ +/* or zero if the table has overflowed and does not */ +/* contain this message specifically. When KFLAG=0, */ +/* ICOUNT will not be altered. */ + +/* *Description: */ + +/* Record that this error occurred and possibly dump and clear the */ +/* tables. */ + +/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ +/* Error-handling Package, SAND82-0800, Sandia */ +/* Laboratories, 1982. */ +/* ***ROUTINES CALLED I1MACH, XGETUA */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 800319 DATE WRITTEN */ +/* 861211 REVISION DATE from Version 3.2 */ +/* 891214 Prologue converted to Version 4.0 format. (BAB) */ +/* 900413 Routine modified to remove reference to KFLAG. (WRB) */ +/* 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling */ +/* sequence, use IF-THEN-ELSE, make number of saved entries */ +/* easily changeable, changed routine name from XERSAV to */ +/* XERSVE. (RWC) */ +/* 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* ***END PROLOGUE XERSVE */ +/* ***FIRST EXECUTABLE STATEMENT XERSVE */ + + if (*kflag <= 0) { + +/* Dump the table. */ + + if (nmsg == 0) { + return 0; + } + +/* Print to each unit. */ + + xgetua_(lun, &nunit); + i__1 = nunit; + for (kunit = 1; kunit <= i__1; ++kunit) { + iunit = lun[kunit - 1]; + if (iunit == 0) { + iunit = i1mach_(&c__4); + } + +/* Print the table header. */ + + io___7.ciunit = iunit; + s_wsfe(&io___7); + e_wsfe(); + +/* Print body of table. */ + + i__2 = nmsg; + for (i__ = 1; i__ <= i__2; ++i__) { + io___9.ciunit = iunit; + s_wsfe(&io___9); + do_fio(&c__1, libtab + (i__ - 1 << 3), (ftnlen)8); + do_fio(&c__1, subtab + (i__ - 1 << 3), (ftnlen)8); + do_fio(&c__1, mestab + (i__ - 1) * 20, (ftnlen)20); + do_fio(&c__1, (char *)&nertab[i__ - 1], (ftnlen)sizeof( + integer)); + do_fio(&c__1, (char *)&levtab[i__ - 1], (ftnlen)sizeof( + integer)); + do_fio(&c__1, (char *)&kount[i__ - 1], (ftnlen)sizeof(integer) + ); + e_wsfe(); +/* L10: */ + } + +/* Print number of other errors. */ + + if (kountx != 0) { + io___16.ciunit = iunit; + s_wsfe(&io___16); + do_fio(&c__1, (char *)&kountx, (ftnlen)sizeof(integer)); + e_wsfe(); + } + io___17.ciunit = iunit; + s_wsfe(&io___17); + e_wsfe(); +/* L20: */ + } + +/* Clear the error tables. */ + + if (*kflag == 0) { + nmsg = 0; + kountx = 0; + } + } else { + +/* PROCESS A MESSAGE... */ +/* SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, */ +/* OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. */ + + s_copy(lib, librar, (ftnlen)8, librar_len); + s_copy(sub, subrou, (ftnlen)8, subrou_len); + s_copy(mes, messg, (ftnlen)20, messg_len); + i__1 = nmsg; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s_cmp(lib, libtab + (i__ - 1 << 3), (ftnlen)8, (ftnlen)8) == + 0 && s_cmp(sub, subtab + (i__ - 1 << 3), (ftnlen)8, ( + ftnlen)8) == 0 && s_cmp(mes, mestab + (i__ - 1) * 20, ( + ftnlen)20, (ftnlen)20) == 0 && *nerr == nertab[i__ - 1] && + *level == levtab[i__ - 1]) { + ++kount[i__ - 1]; + *icount = kount[i__ - 1]; + return 0; + } +/* L30: */ + } + + if (nmsg < 10) { + +/* Empty slot found for new message. */ + + ++nmsg; + s_copy(libtab + (i__ - 1 << 3), lib, (ftnlen)8, (ftnlen)8); + s_copy(subtab + (i__ - 1 << 3), sub, (ftnlen)8, (ftnlen)8); + s_copy(mestab + (i__ - 1) * 20, mes, (ftnlen)20, (ftnlen)20); + nertab[i__ - 1] = *nerr; + levtab[i__ - 1] = *level; + kount[i__ - 1] = 1; + *icount = 1; + } else { + +/* Table is full. */ + + ++kountx; + *icount = 0; + } + } + return 0; + +/* Formats. */ + +} /* xersve_ */ + +#ifdef _cpluscplus +} +#endif diff --git a/ext/f2c_math/xgetua.c b/ext/f2c_math/xgetua.c new file mode 100644 index 000000000..4c2bf1282 --- /dev/null +++ b/ext/f2c_math/xgetua.c @@ -0,0 +1,93 @@ +/* xgetua.f -- translated by f2c (version 20031025). + You must link the resulting object file with libf2c: + on Microsoft Windows system, link with libf2c.lib; + on Linux or Unix systems, link with .../path/to/libf2c.a -lm + or, if you install libf2c.a in a standard place, with -lf2c -lm + -- in that order, at the end of the command line, as in + cc *.o -lf2c -lm + Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., + + http://www.netlib.org/f2c/libf2c.zip +*/ + +#ifdef _cpluscplus +extern "C" { +#endif +#include "f2c.h" + +/* Table of constant values */ + +static integer c__5 = 5; +static integer c__0 = 0; +static logical c_false = FALSE_; + +/* DECK XGETUA */ +/* Subroutine */ int xgetua_(integer *iunita, integer *n) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + static integer i__, index; + extern integer j4save_(integer *, integer *, logical *); + +/* ***BEGIN PROLOGUE XGETUA */ +/* ***PURPOSE Return unit number(s) to which error messages are being */ +/* sent. */ +/* ***LIBRARY SLATEC (XERROR) */ +/* ***CATEGORY R3C */ +/* ***TYPE ALL (XGETUA-A) */ +/* ***KEYWORDS ERROR, XERROR */ +/* ***AUTHOR Jones, R. E., (SNLA) */ +/* ***DESCRIPTION */ + +/* Abstract */ +/* XGETUA may be called to determine the unit number or numbers */ +/* to which error messages are being sent. */ +/* These unit numbers may have been set by a call to XSETUN, */ +/* or a call to XSETUA, or may be a default value. */ + +/* Description of Parameters */ +/* --Output-- */ +/* IUNIT - an array of one to five unit numbers, depending */ +/* on the value of N. A value of zero refers to the */ +/* default unit, as defined by the I1MACH machine */ +/* constant routine. Only IUNIT(1),...,IUNIT(N) are */ +/* defined by XGETUA. The values of IUNIT(N+1),..., */ +/* IUNIT(5) are not defined (for N .LT. 5) or altered */ +/* in any way by XGETUA. */ +/* N - the number of units to which copies of the */ +/* error messages are being sent. N will be in the */ +/* range from 1 to 5. */ + +/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ +/* Error-handling Package, SAND82-0800, Sandia */ +/* Laboratories, 1982. */ +/* ***ROUTINES CALLED J4SAVE */ +/* ***REVISION HISTORY (YYMMDD) */ +/* 790801 DATE WRITTEN */ +/* 861211 REVISION DATE from Version 3.2 */ +/* 891214 Prologue converted to Version 4.0 format. (BAB) */ +/* 920501 Reformatted the REFERENCES section. (WRB) */ +/* ***END PROLOGUE XGETUA */ +/* ***FIRST EXECUTABLE STATEMENT XGETUA */ + /* Parameter adjustments */ + --iunita; + + /* Function Body */ + *n = j4save_(&c__5, &c__0, &c_false); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + index = i__ + 4; + if (i__ == 1) { + index = 3; + } + iunita[i__] = j4save_(&index, &c__0, &c_false); +/* L30: */ + } + return 0; +} /* xgetua_ */ + +#ifdef _cpluscplus +} +#endif