From 704336024cb941295e577af5927aee2197c25997 Mon Sep 17 00:00:00 2001 From: Nicholas Malaya Date: Sat, 4 Feb 2012 00:37:06 +0000 Subject: [PATCH] [cantera]: removing math dir --- Cantera/ext/math/Makefile.am | 24 - Cantera/ext/math/cblas.h | 646 ---- Cantera/ext/math/daux.f | 257 -- Cantera/ext/math/ddaspk.f | 6612 -------------------------------- Cantera/ext/math/dgbefa.f | 174 - Cantera/ext/math/dgbfa.f | 174 - Cantera/ext/math/dgbsl.f | 135 - Cantera/ext/math/dgefa.f | 104 - Cantera/ext/math/dgesl.f | 117 - Cantera/ext/math/dp1vlu.f | 151 - Cantera/ext/math/dpcoef.f | 78 - Cantera/ext/math/dpolft.f | 364 -- Cantera/ext/math/fdump.f | 72 - Cantera/ext/math/gmres.h | 144 - Cantera/ext/math/idamax.f | 39 - Cantera/ext/math/j4save.f | 65 - Cantera/ext/math/mach.cpp | 60 - Cantera/ext/math/mkl_cblas.h | 644 ---- Cantera/ext/math/pcoef.f | 712 ---- Cantera/ext/math/polfit.f | 289 -- Cantera/ext/math/printstring.c | 15 - Cantera/ext/math/pvalue.f | 150 - Cantera/ext/math/xercnt.f | 60 - Cantera/ext/math/xerhlt.f | 40 - Cantera/ext/math/xermsg.f | 364 -- Cantera/ext/math/xerprn.f | 230 -- Cantera/ext/math/xersve.f | 155 - Cantera/ext/math/xgetua.f | 51 - 28 files changed, 11926 deletions(-) delete mode 100644 Cantera/ext/math/Makefile.am delete mode 100755 Cantera/ext/math/cblas.h delete mode 100755 Cantera/ext/math/daux.f delete mode 100755 Cantera/ext/math/ddaspk.f delete mode 100644 Cantera/ext/math/dgbefa.f delete mode 100644 Cantera/ext/math/dgbfa.f delete mode 100644 Cantera/ext/math/dgbsl.f delete mode 100644 Cantera/ext/math/dgefa.f delete mode 100644 Cantera/ext/math/dgesl.f delete mode 100644 Cantera/ext/math/dp1vlu.f delete mode 100644 Cantera/ext/math/dpcoef.f delete mode 100644 Cantera/ext/math/dpolft.f delete mode 100644 Cantera/ext/math/fdump.f delete mode 100755 Cantera/ext/math/gmres.h delete mode 100755 Cantera/ext/math/idamax.f delete mode 100644 Cantera/ext/math/j4save.f delete mode 100755 Cantera/ext/math/mach.cpp delete mode 100755 Cantera/ext/math/mkl_cblas.h delete mode 100644 Cantera/ext/math/pcoef.f delete mode 100644 Cantera/ext/math/polfit.f delete mode 100644 Cantera/ext/math/printstring.c delete mode 100644 Cantera/ext/math/pvalue.f delete mode 100644 Cantera/ext/math/xercnt.f delete mode 100644 Cantera/ext/math/xerhlt.f delete mode 100755 Cantera/ext/math/xermsg.f delete mode 100644 Cantera/ext/math/xerprn.f delete mode 100644 Cantera/ext/math/xersve.f delete mode 100644 Cantera/ext/math/xgetua.f diff --git a/Cantera/ext/math/Makefile.am b/Cantera/ext/math/Makefile.am deleted file mode 100644 index 1139d010c..000000000 --- a/Cantera/ext/math/Makefile.am +++ /dev/null @@ -1,24 +0,0 @@ -cc_sources = mach.cpp printstring.c - -fc_sources = ddaspk.f dgbfa.f dgbsl.f \ - dgefa.f dgesl.f dp1vlu.f dpcoef.f \ - dpolft.f fdump.f j4save.f pcoef.f \ - polfit.f pvalue.f xercnt.f xerhlt.f \ - xermsg.f xerprn.f xersve.f xgetua.f - -AM_CPPFLAGS = -AM_CXXFLAGS = $(AM_CPPFLAGS) -AM_FCFLAGS = $(AM_CPPFLAGS) - -lib_LTLIBRARIES = $(top_builddir)/build/lib/libctmath.la -library_includedir = $(top_builddir)/build/include -library_include_HEADERS = $(h_sources) - -#----------------------- -# Cantera Converters C/C++ library -#----------------------- - -__top_builddir__build_lib_libctmath_la_LDFLAGS = $(all_libraries) -release $(GENERIC_RELEASE) -__top_builddir__build_lib_libctmath_la_SOURCES = $(fc_sources) $(cc_sources) - -CLEANFILES = *.o diff --git a/Cantera/ext/math/cblas.h b/Cantera/ext/math/cblas.h deleted file mode 100755 index 204698e97..000000000 --- a/Cantera/ext/math/cblas.h +++ /dev/null @@ -1,646 +0,0 @@ -// -*- 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/Cantera/ext/math/daux.f b/Cantera/ext/math/daux.f deleted file mode 100755 index f7bf84927..000000000 --- a/Cantera/ext/math/daux.f +++ /dev/null @@ -1,257 +0,0 @@ -c DOUBLE PRECISION FUNCTION D1MACH (IDUM) -c INTEGER IDUM -cC----------------------------------------------------------------------- -cC THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE -cC PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER -cC U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). -cC----------------------------------------------------------------------- -c DOUBLE PRECISION U, COMP -c U = 1.0D0 -c 10 U = U*0.5D0 -c COMP = 1.0D0 + U -c IF (COMP .NE. 1.0D0) GO TO 10 -c D1MACH = U*2.0D0 -c RETURN -cC----------------------- END OF FUNCTION D1MACH ------------------------ -c END - -*DECK XERRWD - SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) -C***BEGIN PROLOGUE XERRWD -C***SUBSIDIARY -C***PURPOSE Write error message with values. -C***LIBRARY MATHLIB -C***CATEGORY R3C -C***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, -C as given here, constitute a simplified version of the SLATEC error -C handling package. -C -C All arguments are input arguments. -C -C MSG = The message (character array). -C NMES = The length of MSG (number of characters). -C NERR = The error number (not used). -C LEVEL = The error level.. -C 0 or 1 means recoverable (control returns to caller). -C 2 means fatal (run is aborted--see note below). -C NI = Number of integers (0, 1, or 2) to be printed with message. -C I1,I2 = Integers to be printed, depending on NI. -C NR = Number of reals (0, 1, or 2) to be printed with message. -C R1,R2 = Reals to be printed, depending on NR. -C -C Note.. this routine is machine-dependent and specialized for use -C in limited context, in the following ways.. -C 1. The argument MSG is assumed to be of type CHARACTER, and -C the message is printed with a format of (1X,A). -C 2. The message is assumed to take only one line. -C Multi-line messages are generated by repeated calls. -C 3. If LEVEL = 2, control passes to the statement STOP -C to abort the run. This statement may be machine-dependent. -C 4. R1 and R2 are assumed to be in double precision and are printed -C in D21.13 format. -C -C***ROUTINES CALLED IXSAV -C***REVISION HISTORY (YYMMDD) -C 920831 DATE WRITTEN -C 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) -C 930329 Modified prologue to SLATEC format. (FNF) -C 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) -C 930922 Minor cosmetic change. (FNF) -C***END PROLOGUE XERRWD -C -C*Internal Notes: -C -C For a different default logical unit number, IXSAV (or a subsidiary -C routine that it calls) will need to be modified. -C For a different run-abort command, change the statement following -C statement 100 at the end. -C----------------------------------------------------------------------- -C Subroutines called by XERRWD.. None -C Function routine called by XERRWD.. IXSAV -C----------------------------------------------------------------------- -C**End -C -C Declare arguments. -C - DOUBLE PRECISION R1, R2 - INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR - CHARACTER*(*) MSG -C -C Declare local variables. -C - INTEGER LUNIT, IXSAV, MESFLG -C -C Get logical unit number and message print flag. -C -C***FIRST EXECUTABLE STATEMENT XERRWD - LUNIT = IXSAV (1, 0, .FALSE.) - MESFLG = IXSAV (2, 0, .FALSE.) - IF (MESFLG .EQ. 0) GO TO 100 -C -C Write the message. -C - WRITE (LUNIT,10) MSG - 10 FORMAT(1X,A) - IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 - 20 FORMAT(6X,'In above message, I1 =',I10) - IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 - 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) - IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 - 40 FORMAT(6X,'In above message, R1 =',D21.13) - IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 - 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) -C -C Abort the run if LEVEL = 2. -C - 100 IF (LEVEL .NE. 2) RETURN - STOP -C----------------------- End of Subroutine XERRWD ---------------------- - END -*DECK XSETF - SUBROUTINE XSETF (MFLAG) -C***BEGIN PROLOGUE XSETF -C***PURPOSE Reset the error print control flag. -C***LIBRARY MATHLIB -C***CATEGORY R3A -C***TYPE ALL (XSETF-A) -C***KEYWORDS ERROR CONTROL -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C XSETF sets the error print control flag to MFLAG: -C MFLAG=1 means print all messages (the default). -C MFLAG=0 means no printing. -C -C***SEE ALSO XERMSG, XERRWD, XERRWV -C***REFERENCES (NONE) -C***ROUTINES CALLED IXSAV -C***REVISION HISTORY (YYMMDD) -C 921118 DATE WRITTEN -C 930329 Added SLATEC format prologue. (FNF) -C 930407 Corrected SEE ALSO section. (FNF) -C 930922 Made user-callable, and other cosmetic changes. (FNF) -C***END PROLOGUE XSETF -C -C Subroutines called by XSETF.. None -C Function routine called by XSETF.. IXSAV -C----------------------------------------------------------------------- -C**End - INTEGER MFLAG, JUNK, IXSAV -C -C***FIRST EXECUTABLE STATEMENT XSETF - IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = IXSAV (2,MFLAG,.TRUE.) - RETURN -C----------------------- End of Subroutine XSETF ----------------------- - END -*DECK XSETUN - SUBROUTINE XSETUN (LUN) -C***BEGIN PROLOGUE XSETUN -C***PURPOSE Reset the logical unit number for error messages. -C***LIBRARY MATHLIB -C***CATEGORY R3B -C***TYPE ALL (XSETUN-A) -C***KEYWORDS ERROR CONTROL -C***DESCRIPTION -C -C XSETUN sets the logical unit number for error messages to LUN. -C -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***SEE ALSO XERMSG, XERRWD, XERRWV -C***REFERENCES (NONE) -C***ROUTINES CALLED IXSAV -C***REVISION HISTORY (YYMMDD) -C 921118 DATE WRITTEN -C 930329 Added SLATEC format prologue. (FNF) -C 930407 Corrected SEE ALSO section. (FNF) -C 930922 Made user-callable, and other cosmetic changes. (FNF) -C***END PROLOGUE XSETUN -C -C Subroutines called by XSETUN.. None -C Function routine called by XSETUN.. IXSAV -C----------------------------------------------------------------------- -C**End - INTEGER LUN, JUNK, IXSAV -C -C***FIRST EXECUTABLE STATEMENT XSETUN - IF (LUN .GT. 0) JUNK = IXSAV (1,LUN,.TRUE.) - RETURN -C----------------------- End of Subroutine XSETUN ---------------------- - END -*DECK IXSAV - INTEGER FUNCTION IXSAV (IPAR, IVALUE, ISET) -C***BEGIN PROLOGUE IXSAV -C***SUBSIDIARY -C***PURPOSE Save and recall error message control parameters. -C***LIBRARY MATHLIB -C***CATEGORY R3C -C***TYPE ALL (IXSAV-A) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C IXSAV saves and recalls one of two error message parameters: -C LUNIT, the logical unit number to which messages are printed, and -C MESFLG, the message print flag. -C This is a modification of the SLATEC library routine J4SAVE. -C -C Saved local variables.. -C LUNIT = Logical unit number for messages. -C LUNDEF = Default logical unit number, data-loaded to 6 below -C (may be machine-dependent). -C MESFLG = Print control flag.. -C 1 means print all messages (the default). -C 0 means no printing. -C -C On input.. -C IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). -C IVALUE = The value to be set for the parameter, if ISET = .TRUE. -C ISET = Logical flag to indicate whether to read or write. -C If ISET = .TRUE., the parameter will be given -C the value IVALUE. If ISET = .FALSE., the parameter -C will be unchanged, and IVALUE is a dummy argument. -C -C On return.. -C IXSAV = The (old) value of the parameter. -C -C***SEE ALSO XERMSG, XERRWD, XERRWV -C***ROUTINES CALLED NONE -C***REVISION HISTORY (YYMMDD) -C 921118 DATE WRITTEN -C 930329 Modified prologue to SLATEC format. (FNF) -C 941025 Minor modification re default unit number. (ACH) -C***END PROLOGUE IXSAV -C -C**End - LOGICAL ISET - INTEGER IPAR, IVALUE -C----------------------------------------------------------------------- - INTEGER LUNIT, LUNDEF, MESFLG -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this routine. -C----------------------------------------------------------------------- -c SAVE LUNIT, LUNDEF, MESFLG -c dgg mod 2/2007 - lunit = -1 - lundef = 6 - mesflg = 1 -c DATA LUNIT/-1/, LUNDEF/6/, MESFLG/1/ -C -C***FIRST EXECUTABLE STATEMENT IXSAV - IF (IPAR .EQ. 1) THEN - IF (LUNIT .EQ. -1) LUNIT = LUNDEF - IXSAV = LUNIT - IF (ISET) LUNIT = IVALUE - ENDIF -C - IF (IPAR .EQ. 2) THEN - IXSAV = MESFLG - IF (ISET) MESFLG = IVALUE - ENDIF -C - RETURN -C----------------------- End of Function IXSAV ------------------------- - END diff --git a/Cantera/ext/math/ddaspk.f b/Cantera/ext/math/ddaspk.f deleted file mode 100755 index d7bd0be2f..000000000 --- a/Cantera/ext/math/ddaspk.f +++ /dev/null @@ -1,6612 +0,0 @@ - SUBROUTINE DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, - * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) -C -C***BEGIN PROLOGUE DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 910624 (Added HMAX test at 525 in main driver.) -C***REVISION DATE 920929 (CJ in RES call, RES counter fix.) -C***REVISION DATE 921215 (Warnings on poor iteration performance) -C***REVISION DATE 921216 (NRMAX as optional input) -C***REVISION DATE 930315 (Name change: DDINI to DDINIT) -C***REVISION DATE 940822 (Replaced initial condition calculation) -C***REVISION DATE 941101 (Added linesearch in I.C. calculations) -C***REVISION DATE 941220 (Misc. corrections throughout) -C***REVISION DATE 950125 (Added DINVWT routine) -C***REVISION DATE 950714 (Misc. corrections throughout) -C***REVISION DATE 950802 (Default NRMAX = 5, based on tests.) -C***REVISION DATE 950808 (Optional error test added.) -C***REVISION DATE 950814 (Added I.C. constraints and INFO(14)) -C***REVISION DATE 950828 (Various minor corrections.) -C***REVISION DATE 951006 (Corrected WT scaling in DFNRMK.) -C***REVISION DATE 951030 (Corrected history update at end of DDASTP.) -C***REVISION DATE 960129 (Corrected RL bug in DLINSD, DLINSK.) -C***REVISION DATE 960301 (Added NONNEG to SAVE statement.) -C***REVISION DATE 000512 (Removed copyright notices.) -C***REVISION DATE 000622 (Corrected LWM value using NCPHI.) -C***REVISION DATE 000628 (Corrected I.C. stopping tests when index = 0.) -C***REVISION DATE 000628 (Fixed alpha test in I.C. calc., Krylov case.) -C***REVISION DATE 000628 (Improved restart in I.C. calc., Krylov case.) -C***REVISION DATE 000628 (Minor corrections throughout.) -C***REVISION DATE 000711 (Fixed Newton convergence test in DNSD, DNSK.) -C***REVISION DATE 000712 (Fixed tests on TN - TOUT below 420 and 440.) -C***CATEGORY NO. I1A2 -C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, -C IMPLICIT DIFFERENTIAL SYSTEMS, KRYLOV ITERATION -C***AUTHORS Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh, and -C Clement W. Ulrich -C Center for Computational Sciences & Engineering, L-316 -C Lawrence Livermore National Laboratory -C P.O. Box 808, -C Livermore, CA 94551 -C***PURPOSE This code solves a system of differential/algebraic -C equations of the form -C G(t,y,y') = 0 , -C using a combination of Backward Differentiation Formula -C (BDF) methods and a choice of two linear system solution -C methods: direct (dense or band) or Krylov (iterative). -C This version is in double precision. -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C *Usage: -C -C IMPLICIT DOUBLE PRECISION(A-H,O-Z) -C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR(*) -C DOUBLE PRECISION T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), -C RWORK(LRW), RPAR(*) -C EXTERNAL RES, JAC, PSOL -C -C CALL DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, -C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) -C -C Quantities which may be altered by the code are: -C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, IDID, RWORK(*), IWORK(*) -C -C -C *Arguments: -C -C RES:EXT This is the name of a subroutine which you -C provide to define the residual function G(t,y,y') -C of the differential/algebraic system. -C -C NEQ:IN This is the number of equations in the system. -C -C T:INOUT This is the current value of the independent -C variable. -C -C Y(*):INOUT This array contains the solution components at T. -C -C YPRIME(*):INOUT This array contains the derivatives of the solution -C components at T. -C -C TOUT:IN This is a point at which a solution is desired. -C -C INFO(N):IN This is an integer array used to communicate details -C of how the solution is to be carried out, such as -C tolerance type, matrix structure, step size and -C order limits, and choice of nonlinear system method. -C N must be at least 20. -C -C RTOL,ATOL:INOUT These quantities represent absolute and relative -C error tolerances (on local error) which you provide -C to indicate how accurately you wish the solution to -C be computed. You may choose them to be both scalars -C or else both arrays of length NEQ. -C -C IDID:OUT This integer scalar is an indicator reporting what -C the code did. You must monitor this variable to -C decide what action to take next. -C -C RWORK:WORK A real work array of length LRW which provides the -C code with needed storage space. -C -C LRW:IN The length of RWORK. -C -C IWORK:WORK An integer work array of length LIW which provides -C the code with needed storage space. -C -C LIW:IN The length of IWORK. -C -C RPAR,IPAR:IN These are real and integer parameter arrays which -C you can use for communication between your calling -C program and the RES, JAC, and PSOL subroutines. -C -C JAC:EXT This is the name of a subroutine which you may -C provide (optionally) for calculating Jacobian -C (partial derivative) data involved in solving linear -C systems within DDASPK. -C -C PSOL:EXT This is the name of a subroutine which you must -C provide for solving linear systems if you selected -C a Krylov method. The purpose of PSOL is to solve -C linear systems involving a left preconditioner P. -C -C *Overview -C -C The DDASPK solver uses the backward differentiation formulas of -C orders one through five to solve a system of the form G(t,y,y') = 0 -C for y = Y and y' = YPRIME. Values for Y and YPRIME at the initial -C time must be given as input. These values should be consistent, -C that is, if T, Y, YPRIME are the given initial values, they should -C satisfy G(T,Y,YPRIME) = 0. However, if consistent values are not -C known, in many cases you can have DDASPK solve for them -- see INFO(11). -C (This and other options are described in more detail below.) -C -C Normally, DDASPK solves the system from T to TOUT. It is easy to -C continue the solution to get results at additional TOUT. This is -C the interval mode of operation. Intermediate results can also be -C obtained easily by specifying INFO(3). -C -C On each step taken by DDASPK, a sequence of nonlinear algebraic -C systems arises. These are solved by one of two types of -C methods: -C * a Newton iteration with a direct method for the linear -C systems involved (INFO(12) = 0), or -C * a Newton iteration with a preconditioned Krylov iterative -C method for the linear systems involved (INFO(12) = 1). -C -C The direct method choices are dense and band matrix solvers, -C with either a user-supplied or an internal difference quotient -C Jacobian matrix, as specified by INFO(5) and INFO(6). -C In the band case, INFO(6) = 1, you must supply half-bandwidths -C in IWORK(1) and IWORK(2). -C -C The Krylov method is the Generalized Minimum Residual (GMRES) -C method, in either complete or incomplete form, and with -C scaling and preconditioning. The method is implemented -C in an algorithm called SPIGMR. Certain options in the Krylov -C method case are specified by INFO(13) and INFO(15). -C -C If the Krylov method is chosen, you may supply a pair of routines, -C JAC and PSOL, to apply preconditioning to the linear system. -C If the system is A*x = b, the matrix is A = dG/dY + CJ*dG/dYPRIME -C (of order NEQ). This system can then be preconditioned in the form -C (P-inverse)*A*x = (P-inverse)*b, with left preconditioner P. -C (DDASPK does not allow right preconditioning.) -C Then the Krylov method is applied to this altered, but equivalent, -C linear system, hopefully with much better performance than without -C preconditioning. (In addition, a diagonal scaling matrix based on -C the tolerances is also introduced into the altered system.) -C -C The JAC routine evaluates any data needed for solving systems -C with coefficient matrix P, and PSOL carries out that solution. -C In any case, in order to improve convergence, you should try to -C make P approximate the matrix A as much as possible, while keeping -C the system P*x = b reasonably easy and inexpensive to solve for x, -C given a vector b. -C -C -C *Description -C -C------INPUT - WHAT TO DO ON THE FIRST CALL TO DDASPK------------------- -C -C -C The first call of the code is defined to be the start of each new -C problem. Read through the descriptions of all the following items, -C provide sufficient storage space for designated arrays, set -C appropriate variables for the initialization of the problem, and -C give information about how you want the problem to be solved. -C -C -C RES -- Provide a subroutine of the form -C -C SUBROUTINE RES (T, Y, YPRIME, CJ, DELTA, IRES, RPAR, IPAR) -C -C to define the system of differential/algebraic -C equations which is to be solved. For the given values -C of T, Y and YPRIME, the subroutine should return -C the residual of the differential/algebraic system -C DELTA = G(T,Y,YPRIME) -C DELTA is a vector of length NEQ which is output from RES. -C -C Subroutine RES must not alter T, Y, YPRIME, or CJ. -C You must declare the name RES in an EXTERNAL -C statement in your program that calls DDASPK. -C You must dimension Y, YPRIME, and DELTA in RES. -C -C The input argument CJ can be ignored, or used to rescale -C constraint equations in the system (see Ref. 2, p. 145). -C Note: In this respect, DDASPK is not downward-compatible -C with DDASSL, which does not have the RES argument CJ. -C -C IRES is an integer flag which is always equal to zero -C on input. Subroutine RES should alter IRES only if it -C encounters an illegal value of Y or a stop condition. -C Set IRES = -1 if an input value is illegal, and DDASPK -C will try to solve the problem without getting IRES = -1. -C If IRES = -2, DDASPK will return control to the calling -C program with IDID = -11. -C -C RPAR and IPAR are real and integer parameter arrays which -C you can use for communication between your calling program -C and subroutine RES. They are not altered by DDASPK. If you -C do not need RPAR or IPAR, ignore these parameters by treat- -C ing them as dummy arguments. If you do choose to use them, -C dimension them in your calling program and in RES as arrays -C of appropriate length. -C -C NEQ -- Set it to the number of equations in the system (NEQ .GE. 1). -C -C T -- Set it to the initial point of the integration. (T must be -C a variable.) -C -C Y(*) -- Set this array to the initial values of the NEQ solution -C components at the initial point. You must dimension Y of -C length at least NEQ in your calling program. -C -C YPRIME(*) -- Set this array to the initial values of the NEQ first -C derivatives of the solution components at the initial -C point. You must dimension YPRIME at least NEQ in your -C calling program. -C -C TOUT - Set it to the first point at which a solution is desired. -C You cannot take TOUT = T. Integration either forward in T -C (TOUT .GT. T) or backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using step -C sizes which are automatically selected so as to achieve the -C desired accuracy. If you wish, the code will return with the -C solution and its derivative at intermediate steps (the -C intermediate-output mode) so that you can monitor them, -C but you still must provide TOUT in accord with the basic -C aim of the code. -C -C The first step taken by the code is a critical one because -C it must reflect how fast the solution changes near the -C initial point. The code automatically selects an initial -C step size which is practically always suitable for the -C problem. By using the fact that the code will not step past -C TOUT in the first step, you could, if necessary, restrict the -C length of the initial step. -C -C For some problems it may not be permissible to integrate -C past a point TSTOP, because a discontinuity occurs there -C or the solution or its derivative is not defined beyond -C TSTOP. When you have declared a TSTOP point (see INFO(4) -C and RWORK(1)), you have told the code not to integrate past -C TSTOP. In this case any tout beyond TSTOP is invalid input. -C -C INFO(*) - Use the INFO array to give the code more details about -C how you want your problem solved. This array should be -C dimensioned of length 20, though DDASPK uses only the -C first 15 entries. You must respond to all of the following -C items, which are arranged as questions. The simplest use -C of DDASPK corresponds to setting all entries of INFO to 0. -C -C INFO(1) - This parameter enables the code to initialize itself. -C You must set it to indicate the start of every new -C problem. -C -C **** Is this the first call for this problem ... -C yes - set INFO(1) = 0 -C no - not applicable here. -C See below for continuation calls. **** -C -C INFO(2) - How much accuracy you want of your solution -C is specified by the error tolerances RTOL and ATOL. -C The simplest use is to take them both to be scalars. -C To obtain more flexibility, they can both be arrays. -C The code must be told your choice. -C -C **** Are both error tolerances RTOL, ATOL scalars ... -C yes - set INFO(2) = 0 -C and input scalars for both RTOL and ATOL -C no - set INFO(2) = 1 -C and input arrays for both RTOL and ATOL **** -C -C INFO(3) - The code integrates from T in the direction of TOUT -C by steps. If you wish, it will return the computed -C solution and derivative at the next intermediate step -C (the intermediate-output mode) or TOUT, whichever comes -C first. This is a good way to proceed if you want to -C see the behavior of the solution. If you must have -C solutions at a great many specific TOUT points, this -C code will compute them efficiently. -C -C **** Do you want the solution only at -C TOUT (and not at the next intermediate step) ... -C yes - set INFO(3) = 0 -C no - set INFO(3) = 1 **** -C -C INFO(4) - To handle solutions at a great many specific -C values TOUT efficiently, this code may integrate past -C TOUT and interpolate to obtain the result at TOUT. -C Sometimes it is not possible to integrate beyond some -C point TSTOP because the equation changes there or it is -C not defined past TSTOP. Then you must tell the code -C this stop condition. -C -C **** Can the integration be carried out without any -C restrictions on the independent variable T ... -C yes - set INFO(4) = 0 -C no - set INFO(4) = 1 -C and define the stopping point TSTOP by -C setting RWORK(1) = TSTOP **** -C -C INFO(5) - used only when INFO(12) = 0 (direct methods). -C To solve differential/algebraic systems you may wish -C to use a matrix of partial derivatives of the -C system of differential equations. If you do not -C provide a subroutine to evaluate it analytically (see -C description of the item JAC in the call list), it will -C be approximated by numerical differencing in this code. -C Although it is less trouble for you to have the code -C compute partial derivatives by numerical differencing, -C the solution will be more reliable if you provide the -C derivatives via JAC. Usually numerical differencing is -C more costly than evaluating derivatives in JAC, but -C sometimes it is not - this depends on your problem. -C -C **** Do you want the code to evaluate the partial deriv- -C atives automatically by numerical differences ... -C yes - set INFO(5) = 0 -C no - set INFO(5) = 1 -C and provide subroutine JAC for evaluating the -C matrix of partial derivatives **** -C -C INFO(6) - used only when INFO(12) = 0 (direct methods). -C DDASPK will perform much better if the matrix of -C partial derivatives, dG/dY + CJ*dG/dYPRIME (here CJ is -C a scalar determined by DDASPK), is banded and the code -C is told this. In this case, the storage needed will be -C greatly reduced, numerical differencing will be performed -C much cheaper, and a number of important algorithms will -C execute much faster. The differential equation is said -C to have half-bandwidths ML (lower) and MU (upper) if -C equation i involves only unknowns Y(j) with -C i-ML .le. j .le. i+MU . -C For all i=1,2,...,NEQ. Thus, ML and MU are the widths -C of the lower and upper parts of the band, respectively, -C with the main diagonal being excluded. If you do not -C indicate that the equation has a banded matrix of partial -C derivatives the code works with a full matrix of NEQ**2 -C elements (stored in the conventional way). Computations -C with banded matrices cost less time and storage than with -C full matrices if 2*ML+MU .lt. NEQ. If you tell the -C code that the matrix of partial derivatives has a banded -C structure and you want to provide subroutine JAC to -C compute the partial derivatives, then you must be careful -C to store the elements of the matrix in the special form -C indicated in the description of JAC. -C -C **** Do you want to solve the problem using a full (dense) -C matrix (and not a special banded structure) ... -C yes - set INFO(6) = 0 -C no - set INFO(6) = 1 -C and provide the lower (ML) and upper (MU) -C bandwidths by setting -C IWORK(1)=ML -C IWORK(2)=MU **** -C -C INFO(7) - You can specify a maximum (absolute value of) -C stepsize, so that the code will avoid passing over very -C large regions. -C -C **** Do you want the code to decide on its own the maximum -C stepsize ... -C yes - set INFO(7) = 0 -C no - set INFO(7) = 1 -C and define HMAX by setting -C RWORK(2) = HMAX **** -C -C INFO(8) - Differential/algebraic problems may occasionally -C suffer from severe scaling difficulties on the first -C step. If you know a great deal about the scaling of -C your problem, you can help to alleviate this problem -C by specifying an initial stepsize H0. -C -C **** Do you want the code to define its own initial -C stepsize ... -C yes - set INFO(8) = 0 -C no - set INFO(8) = 1 -C and define H0 by setting -C RWORK(3) = H0 **** -C -C INFO(9) - If storage is a severe problem, you can save some -C storage by restricting the maximum method order MAXORD. -C The default value is 5. For each order decrease below 5, -C the code requires NEQ fewer locations, but it is likely -C to be slower. In any case, you must have -C 1 .le. MAXORD .le. 5. -C **** Do you want the maximum order to default to 5 ... -C yes - set INFO(9) = 0 -C no - set INFO(9) = 1 -C and define MAXORD by setting -C IWORK(3) = MAXORD **** -C -C INFO(10) - If you know that certain components of the -C solutions to your equations are always nonnegative -C (or nonpositive), it may help to set this -C parameter. There are three options that are -C available: -C 1. To have constraint checking only in the initial -C condition calculation. -C 2. To enforce nonnegativity in Y during the integration. -C 3. To enforce both options 1 and 2. -C -C When selecting option 2 or 3, it is probably best to try the -C code without using this option first, and only use -C this option if that does not work very well. -C -C **** Do you want the code to solve the problem without -C invoking any special inequality constraints ... -C yes - set INFO(10) = 0 -C no - set INFO(10) = 1 to have option 1 enforced -C no - set INFO(10) = 2 to have option 2 enforced -C no - set INFO(10) = 3 to have option 3 enforced **** -C -C If you have specified INFO(10) = 1 or 3, then you -C will also need to identify how each component of Y -C in the initial condition calculation is constrained. -C You must set: -C IWORK(40+I) = +1 if Y(I) must be .GE. 0, -C IWORK(40+I) = +2 if Y(I) must be .GT. 0, -C IWORK(40+I) = -1 if Y(I) must be .LE. 0, while -C IWORK(40+I) = -2 if Y(I) must be .LT. 0, while -C IWORK(40+I) = 0 if Y(I) is not constrained. -C -C INFO(11) - DDASPK normally requires the initial T, Y, and -C YPRIME to be consistent. That is, you must have -C G(T,Y,YPRIME) = 0 at the initial T. If you do not know -C the initial conditions precisely, in some cases -C DDASPK may be able to compute it. -C -C Denoting the differential variables in Y by Y_d -C and the algebraic variables by Y_a, DDASPK can solve -C one of two initialization problems: -C 1. Given Y_d, calculate Y_a and Y'_d, or -C 2. Given Y', calculate Y. -C In either case, initial values for the given -C components are input, and initial guesses for -C the unknown components must also be provided as input. -C -C **** Are the initial T, Y, YPRIME consistent ... -C -C yes - set INFO(11) = 0 -C no - set INFO(11) = 1 to calculate option 1 above, -C or set INFO(11) = 2 to calculate option 2 **** -C -C If you have specified INFO(11) = 1, then you -C will also need to identify which are the -C differential and which are the algebraic -C components (algebraic components are components -C whose derivatives do not appear explicitly -C in the function G(T,Y,YPRIME)). You must set: -C IWORK(LID+I) = +1 if Y(I) is a differential variable -C IWORK(LID+I) = -1 if Y(I) is an algebraic variable, -C where LID = 40 if INFO(10) = 0 or 2 and LID = 40+NEQ -C if INFO(10) = 1 or 3. -C -C INFO(12) - Except for the addition of the RES argument CJ, -C DDASPK by default is downward-compatible with DDASSL, -C which uses only direct (dense or band) methods to solve -C the linear systems involved. You must set INFO(12) to -C indicate whether you want the direct methods or the -C Krylov iterative method. -C **** Do you want DDASPK to use standard direct methods -C (dense or band) or the Krylov (iterative) method ... -C direct methods - set INFO(12) = 0. -C Krylov method - set INFO(12) = 1, -C and check the settings of INFO(13) and INFO(15). -C -C INFO(13) - used when INFO(12) = 1 (Krylov methods). -C DDASPK uses scalars MAXL, KMP, NRMAX, and EPLI for the -C iterative solution of linear systems. INFO(13) allows -C you to override the default values of these parameters. -C These parameters and their defaults are as follows: -C MAXL = maximum number of iterations in the SPIGMR -C algorithm (MAXL .le. NEQ). The default is -C MAXL = MIN(5,NEQ). -C KMP = number of vectors on which orthogonalization is -C done in the SPIGMR algorithm. The default is -C KMP = MAXL, which corresponds to complete GMRES -C iteration, as opposed to the incomplete form. -C NRMAX = maximum number of restarts of the SPIGMR -C algorithm per nonlinear iteration. The default is -C NRMAX = 5. -C EPLI = convergence test constant in SPIGMR algorithm. -C The default is EPLI = 0.05. -C Note that the length of RWORK depends on both MAXL -C and KMP. See the definition of LRW below. -C **** Are MAXL, KMP, and EPLI to be given their -C default values ... -C yes - set INFO(13) = 0 -C no - set INFO(13) = 1, -C and set all of the following: -C IWORK(24) = MAXL (1 .le. MAXL .le. NEQ) -C IWORK(25) = KMP (1 .le. KMP .le. MAXL) -C IWORK(26) = NRMAX (NRMAX .ge. 0) -C RWORK(10) = EPLI (0 .lt. EPLI .lt. 1.0) **** -C -C INFO(14) - used with INFO(11) > 0 (initial condition -C calculation is requested). In this case, you may -C request control to be returned to the calling program -C immediately after the initial condition calculation, -C before proceeding to the integration of the system -C (e.g. to examine the computed Y and YPRIME). -C If this is done, and if the initialization succeeded -C (IDID = 4), you should reset INFO(11) to 0 for the -C next call, to prevent the solver from repeating the -C initialization (and to avoid an infinite loop). -C **** Do you want to proceed to the integration after -C the initial condition calculation is done ... -C yes - set INFO(14) = 0 -C no - set INFO(14) = 1 **** -C -C INFO(15) - used when INFO(12) = 1 (Krylov methods). -C When using preconditioning in the Krylov method, -C you must supply a subroutine, PSOL, which solves the -C associated linear systems using P. -C The usage of DDASPK is simpler if PSOL can carry out -C the solution without any prior calculation of data. -C However, if some partial derivative data is to be -C calculated in advance and used repeatedly in PSOL, -C then you must supply a JAC routine to do this, -C and set INFO(15) to indicate that JAC is to be called -C for this purpose. For example, P might be an -C approximation to a part of the matrix A which can be -C calculated and LU-factored for repeated solutions of -C the preconditioner system. The arrays WP and IWP -C (described under JAC and PSOL) can be used to -C communicate data between JAC and PSOL. -C **** Does PSOL operate with no prior preparation ... -C yes - set INFO(15) = 0 (no JAC routine) -C no - set INFO(15) = 1 -C and supply a JAC routine to evaluate and -C preprocess any required Jacobian data. **** -C -C INFO(16) - option to exclude algebraic variables from -C the error test. -C **** Do you wish to control errors locally on -C all the variables... -C yes - set INFO(16) = 0 -C no - set INFO(16) = 1 -C If you have specified INFO(16) = 1, then you -C will also need to identify which are the -C differential and which are the algebraic -C components (algebraic components are components -C whose derivatives do not appear explicitly -C in the function G(T,Y,YPRIME)). You must set: -C IWORK(LID+I) = +1 if Y(I) is a differential -C variable, and -C IWORK(LID+I) = -1 if Y(I) is an algebraic -C variable, -C where LID = 40 if INFO(10) = 0 or 2 and -C LID = 40 + NEQ if INFO(10) = 1 or 3. -C -C INFO(17) - used when INFO(11) > 0 (DDASPK is to do an -C initial condition calculation). -C DDASPK uses several heuristic control quantities in the -C initial condition calculation. They have default values, -C but can also be set by the user using INFO(17). -C These parameters and their defaults are as follows: -C MXNIT = maximum number of Newton iterations -C per Jacobian or preconditioner evaluation. -C The default is: -C MXNIT = 5 in the direct case (INFO(12) = 0), and -C MXNIT = 15 in the Krylov case (INFO(12) = 1). -C MXNJ = maximum number of Jacobian or preconditioner -C evaluations. The default is: -C MXNJ = 6 in the direct case (INFO(12) = 0), and -C MXNJ = 2 in the Krylov case (INFO(12) = 1). -C MXNH = maximum number of values of the artificial -C stepsize parameter H to be tried if INFO(11) = 1. -C The default is MXNH = 5. -C NOTE: the maximum number of Newton iterations -C allowed in all is MXNIT*MXNJ*MXNH if INFO(11) = 1, -C and MXNIT*MXNJ if INFO(11) = 2. -C LSOFF = flag to turn off the linesearch algorithm -C (LSOFF = 0 means linesearch is on, LSOFF = 1 means -C it is turned off). The default is LSOFF = 0. -C STPTOL = minimum scaled step in linesearch algorithm. -C The default is STPTOL = (unit roundoff)**(2/3). -C EPINIT = swing factor in the Newton iteration convergence -C test. The test is applied to the residual vector, -C premultiplied by the approximate Jacobian (in the -C direct case) or the preconditioner (in the Krylov -C case). For convergence, the weighted RMS norm of -C this vector (scaled by the error weights) must be -C less than EPINIT*EPCON, where EPCON = .33 is the -C analogous test constant used in the time steps. -C The default is EPINIT = .01. -C **** Are the initial condition heuristic controls to be -C given their default values... -C yes - set INFO(17) = 0 -C no - set INFO(17) = 1, -C and set all of the following: -C IWORK(32) = MXNIT (.GT. 0) -C IWORK(33) = MXNJ (.GT. 0) -C IWORK(34) = MXNH (.GT. 0) -C IWORK(35) = LSOFF ( = 0 or 1) -C RWORK(14) = STPTOL (.GT. 0.0) -C RWORK(15) = EPINIT (.GT. 0.0) **** -C -C INFO(18) - option to get extra printing in initial condition -C calculation. -C **** Do you wish to have extra printing... -C no - set INFO(18) = 0 -C yes - set INFO(18) = 1 for minimal printing, or -C set INFO(18) = 2 for full printing. -C If you have specified INFO(18) .ge. 1, data -C will be printed with the error handler routines. -C To print to a non-default unit number L, include -C the line CALL XSETUN(L) in your program. **** -C -C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you -C want the solution to be computed. They must be defined -C as variables because the code may change them. -C you have two choices -- -C Both RTOL and ATOL are scalars (INFO(2) = 0), or -C both RTOL and ATOL are vectors (INFO(2) = 1). -C In either case all components must be non-negative. -C -C The tolerances are used by the code in a local error -C test at each step which requires roughly that -C abs(local error in Y(i)) .le. EWT(i) , -C where EWT(i) = RTOL*abs(Y(i)) + ATOL is an error weight -C quantity, for each vector component. -C (More specifically, a root-mean-square norm is used to -C measure the size of vectors, and the error test uses the -C magnitude of the solution at the beginning of the step.) -C -C The true (global) error is the difference between the -C true solution of the initial value problem and the -C computed approximation. Practically all present day -C codes, including this one, control the local error at -C each step and do not even attempt to control the global -C error directly. -C -C Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. -C This code will usually, but not always, deliver a more -C accurate solution if you reduce the tolerances and -C integrate again. By comparing two such solutions you -C can get a fairly reliable idea of the true error in the -C solution at the larger tolerances. -C -C Setting ATOL = 0. results in a pure relative error test -C on that component. Setting RTOL = 0. results in a pure -C absolute error test on that component. A mixed test -C with non-zero RTOL and ATOL corresponds roughly to a -C relative error test when the solution component is -C much bigger than ATOL and to an absolute error test -C when the solution component is smaller than the -C threshold ATOL. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It -C will advise you if you ask for too much accuracy and -C inform you as to the maximum accuracy it believes -C possible. -C -C RWORK(*) -- a real work array, which should be dimensioned in your -C calling program with a length equal to the value of -C LRW (or greater). -C -C LRW -- Set it to the declared length of the RWORK array. The -C minimum length depends on the options you have selected, -C given by a base value plus additional storage as described -C below. -C -C If INFO(12) = 0 (standard direct method), the base value is -C base = 50 + max(MAXORD+4,7)*NEQ. -C The default value is MAXORD = 5 (see INFO(9)). With the -C default MAXORD, base = 50 + 9*NEQ. -C Additional storage must be added to the base value for -C any or all of the following options: -C if INFO(6) = 0 (dense matrix), add NEQ**2 -C if INFO(6) = 1 (banded matrix), then -C if INFO(5) = 0, add (2*ML+MU+1)*NEQ + 2*(NEQ/(ML+MU+1)+1), -C if INFO(5) = 1, add (2*ML+MU+1)*NEQ, -C if INFO(16) = 1, add NEQ. -C -C If INFO(12) = 1 (Krylov method), the base value is -C base = 50 + (MAXORD+5)*NEQ + (MAXL+3+MIN0(1,MAXL-KMP))*NEQ + -C + (MAXL+3)*MAXL + 1 + LENWP. -C See PSOL for description of LENWP. The default values are: -C MAXORD = 5 (see INFO(9)), MAXL = min(5,NEQ) and KMP = MAXL -C (see INFO(13)). -C With the default values for MAXORD, MAXL and KMP, -C base = 91 + 18*NEQ + LENWP. -C Additional storage must be added to the base value for -C any or all of the following options: -C if INFO(16) = 1, add NEQ. -C -C -C IWORK(*) -- an integer work array, which should be dimensioned in -C your calling program with a length equal to the value -C of LIW (or greater). -C -C LIW -- Set it to the declared length of the IWORK array. The -C minimum length depends on the options you have selected, -C given by a base value plus additional storage as described -C below. -C -C If INFO(12) = 0 (standard direct method), the base value is -C base = 40 + NEQ. -C IF INFO(10) = 1 or 3, add NEQ to the base value. -C If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value. -C -C If INFO(12) = 1 (Krylov method), the base value is -C base = 40 + LENIWP. -C See PSOL for description of LENIWP. -C IF INFO(10) = 1 or 3, add NEQ to the base value. -C If INFO(11) = 1 or INFO(16) = 1, add NEQ to the base value. -C -C -C RPAR, IPAR -- These are arrays of double precision and integer type, -C respectively, which are available for you to use -C for communication between your program that calls -C DDASPK and the RES subroutine (and the JAC and PSOL -C subroutines). They are not altered by DDASPK. -C If you do not need RPAR or IPAR, ignore these -C parameters by treating them as dummy arguments. -C If you do choose to use them, dimension them in -C your calling program and in RES (and in JAC and PSOL) -C as arrays of appropriate length. -C -C JAC -- This is the name of a routine that you may supply -C (optionally) that relates to the Jacobian matrix of the -C nonlinear system that the code must solve at each T step. -C The role of JAC (and its call sequence) depends on whether -C a direct (INFO(12) = 0) or Krylov (INFO(12) = 1) method -C is selected. -C -C **** INFO(12) = 0 (direct methods): -C If you are letting the code generate partial derivatives -C numerically (INFO(5) = 0), then JAC can be absent -C (or perhaps a dummy routine to satisfy the loader). -C Otherwise you must supply a JAC routine to compute -C the matrix A = dG/dY + CJ*dG/dYPRIME. It must have -C the form -C -C SUBROUTINE JAC (T, Y, YPRIME, PD, CJ, RPAR, IPAR) -C -C The JAC routine must dimension Y, YPRIME, and PD (and RPAR -C and IPAR if used). CJ is a scalar which is input to JAC. -C For the given values of T, Y, and YPRIME, the JAC routine -C must evaluate the nonzero elements of the matrix A, and -C store these values in the array PD. The elements of PD are -C set to zero before each call to JAC, so that only nonzero -C elements need to be defined. -C The way you store the elements into the PD array depends -C on the structure of the matrix indicated by INFO(6). -C *** INFO(6) = 0 (full or dense matrix) *** -C Give PD a first dimension of NEQ. When you evaluate the -C nonzero partial derivatives of equation i (i.e. of G(i)) -C with respect to component j (of Y and YPRIME), you must -C store the element in PD according to -C PD(i,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). -C *** INFO(6) = 1 (banded matrix with half-bandwidths ML, MU -C as described under INFO(6)) *** -C Give PD a first dimension of 2*ML+MU+1. When you -C evaluate the nonzero partial derivatives of equation i -C (i.e. of G(i)) with respect to component j (of Y and -C YPRIME), you must store the element in PD according to -C IROW = i - j + ML + MU + 1 -C PD(IROW,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). -C -C **** INFO(12) = 1 (Krylov method): -C If you are not calculating Jacobian data in advance for use -C in PSOL (INFO(15) = 0), JAC can be absent (or perhaps a -C dummy routine to satisfy the loader). Otherwise, you may -C supply a JAC routine to compute and preprocess any parts of -C of the Jacobian matrix A = dG/dY + CJ*dG/dYPRIME that are -C involved in the preconditioner matrix P. -C It is to have the form -C -C SUBROUTINE JAC (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR, -C WK, H, CJ, WP, IWP, IER, RPAR, IPAR) -C -C The JAC routine must dimension Y, YPRIME, REWT, SAVR, WK, -C and (if used) WP, IWP, RPAR, and IPAR. -C The Y, YPRIME, and SAVR arrays contain the current values -C of Y, YPRIME, and the residual G, respectively. -C The array WK is work space of length NEQ. -C H is the step size. CJ is a scalar, input to JAC, that is -C normally proportional to 1/H. REWT is an array of -C reciprocal error weights, 1/EWT(i), where EWT(i) is -C RTOL*abs(Y(i)) + ATOL (unless you supplied routine DDAWTS -C instead), for use in JAC if needed. For example, if JAC -C computes difference quotient approximations to partial -C derivatives, the REWT array may be useful in setting the -C increments used. The JAC routine should do any -C factorization operations called for, in preparation for -C solving linear systems in PSOL. The matrix P should -C be an approximation to the Jacobian, -C A = dG/dY + CJ*dG/dYPRIME. -C -C WP and IWP are real and integer work arrays which you may -C use for communication between your JAC routine and your -C PSOL routine. These may be used to store elements of the -C preconditioner P, or related matrix data (such as factored -C forms). They are not altered by DDASPK. -C If you do not need WP or IWP, ignore these parameters by -C treating them as dummy arguments. If you do use them, -C dimension them appropriately in your JAC and PSOL routines. -C See the PSOL description for instructions on setting -C the lengths of WP and IWP. -C -C On return, JAC should set the error flag IER as follows.. -C IER = 0 if JAC was successful, -C IER .ne. 0 if JAC was unsuccessful (e.g. if Y or YPRIME -C was illegal, or a singular matrix is found). -C (If IER .ne. 0, a smaller stepsize will be tried.) -C IER = 0 on entry to JAC, so need be reset only on a failure. -C If RES is used within JAC, then a nonzero value of IRES will -C override any nonzero value of IER (see the RES description). -C -C Regardless of the method type, subroutine JAC must not -C alter T, Y(*), YPRIME(*), H, CJ, or REWT(*). -C You must declare the name JAC in an EXTERNAL statement in -C your program that calls DDASPK. -C -C PSOL -- This is the name of a routine you must supply if you have -C selected a Krylov method (INFO(12) = 1) with preconditioning. -C In the direct case (INFO(12) = 0), PSOL can be absent -C (a dummy routine may have to be supplied to satisfy the -C loader). Otherwise, you must provide a PSOL routine to -C solve linear systems arising from preconditioning. -C When supplied with INFO(12) = 1, the PSOL routine is to -C have the form -C -C SUBROUTINE PSOL (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT, -C WP, IWP, B, EPLIN, IER, RPAR, IPAR) -C -C The PSOL routine must solve linear systems of the form -C P*x = b where P is the left preconditioner matrix. -C -C The right-hand side vector b is in the B array on input, and -C PSOL must return the solution vector x in B. -C The Y, YPRIME, and SAVR arrays contain the current values -C of Y, YPRIME, and the residual G, respectively. -C -C Work space required by JAC and/or PSOL, and space for data to -C be communicated from JAC to PSOL is made available in the form -C of arrays WP and IWP, which are parts of the RWORK and IWORK -C arrays, respectively. The lengths of these real and integer -C work spaces WP and IWP must be supplied in LENWP and LENIWP, -C respectively, as follows.. -C IWORK(27) = LENWP = length of real work space WP -C IWORK(28) = LENIWP = length of integer work space IWP. -C -C WK is a work array of length NEQ for use by PSOL. -C CJ is a scalar, input to PSOL, that is normally proportional -C to 1/H (H = stepsize). If the old value of CJ -C (at the time of the last JAC call) is needed, it must have -C been saved by JAC in WP. -C -C WGHT is an array of weights, to be used if PSOL uses an -C iterative method and performs a convergence test. (In terms -C of the argument REWT to JAC, WGHT is REWT/sqrt(NEQ).) -C If PSOL uses an iterative method, it should use EPLIN -C (a heuristic parameter) as the bound on the weighted norm of -C the residual for the computed solution. Specifically, the -C residual vector R should satisfy -C SQRT (SUM ( (R(i)*WGHT(i))**2 ) ) .le. EPLIN -C -C PSOL must not alter NEQ, T, Y, YPRIME, SAVR, CJ, WGHT, EPLIN. -C -C On return, PSOL should set the error flag IER as follows.. -C IER = 0 if PSOL was successful, -C IER .lt. 0 if an unrecoverable error occurred, meaning -C control will be passed to the calling routine, -C IER .gt. 0 if a recoverable error occurred, meaning that -C the step will be retried with the same step size -C but with a call to JAC to update necessary data, -C unless the Jacobian data is current, in which case -C the step will be retried with a smaller step size. -C IER = 0 on entry to PSOL so need be reset only on a failure. -C -C You must declare the name PSOL in an EXTERNAL statement in -C your program that calls DDASPK. -C -C -C OPTIONALLY REPLACEABLE SUBROUTINE: -C -C DDASPK uses a weighted root-mean-square norm to measure the -C size of various error vectors. The weights used in this norm -C are set in the following subroutine: -C -C SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, EWT, RPAR, IPAR) -C DIMENSION RTOL(*), ATOL(*), Y(*), EWT(*), RPAR(*), IPAR(*) -C -C A DDAWTS routine has been included with DDASPK which sets the -C weights according to -C EWT(I) = RTOL*ABS(Y(I)) + ATOL -C in the case of scalar tolerances (IWT = 0) or -C EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I) -C in the case of array tolerances (IWT = 1). (IWT is INFO(2).) -C In some special cases, it may be appropriate for you to define -C your own error weights by writing a subroutine DDAWTS to be -C called instead of the version supplied. However, this should -C be attempted only after careful thought and consideration. -C If you supply this routine, you may use the tolerances and Y -C as appropriate, but do not overwrite these variables. You -C may also use RPAR and IPAR to communicate data as appropriate. -C ***Note: Aside from the values of the weights, the choice of -C norm used in DDASPK (weighted root-mean-square) is not subject -C to replacement by the user. In this respect, DDASPK is not -C downward-compatible with the original DDASSL solver (in which -C the norm routine was optionally user-replaceable). -C -C -C------OUTPUT - AFTER ANY RETURN FROM DDASPK---------------------------- -C -C The principal aim of the code is to return a computed solution at -C T = TOUT, although it is also possible to obtain intermediate -C results along the way. To find out whether the code achieved its -C goal or if the integration process was interrupted before the task -C was completed, you must check the IDID parameter. -C -C -C T -- The output value of T is the point to which the solution -C was successfully advanced. -C -C Y(*) -- contains the computed solution approximation at T. -C -C YPRIME(*) -- contains the computed derivative approximation at T. -C -C IDID -- reports what the code did, described as follows: -C -C *** TASK COMPLETED *** -C Reported by positive values of IDID -C -C IDID = 1 -- a step was successfully taken in the -C intermediate-output mode. The code has not -C yet reached TOUT. -C -C IDID = 2 -- the integration to TSTOP was successfully -C completed (T = TSTOP) by stepping exactly to TSTOP. -C -C IDID = 3 -- the integration to TOUT was successfully -C completed (T = TOUT) by stepping past TOUT. -C Y(*) and YPRIME(*) are obtained by interpolation. -C -C IDID = 4 -- the initial condition calculation, with -C INFO(11) > 0, was successful, and INFO(14) = 1. -C No integration steps were taken, and the solution -C is not considered to have been started. -C -C *** TASK INTERRUPTED *** -C Reported by negative values of IDID -C -C IDID = -1 -- a large amount of work has been expended -C (about 500 steps). -C -C IDID = -2 -- the error tolerances are too stringent. -C -C IDID = -3 -- the local error test cannot be satisfied -C because you specified a zero component in ATOL -C and the corresponding computed solution component -C is zero. Thus, a pure relative error test is -C impossible for this component. -C -C IDID = -5 -- there were repeated failures in the evaluation -C or processing of the preconditioner (in JAC). -C -C IDID = -6 -- DDASPK had repeated error test failures on the -C last attempted step. -C -C IDID = -7 -- the nonlinear system solver in the time integration -C could not converge. -C -C IDID = -8 -- the matrix of partial derivatives appears -C to be singular (direct method). -C -C IDID = -9 -- the nonlinear system solver in the time integration -C failed to achieve convergence, and there were repeated -C error test failures in this step. -C -C IDID =-10 -- the nonlinear system solver in the time integration -C failed to achieve convergence because IRES was equal -C to -1. -C -C IDID =-11 -- IRES = -2 was encountered and control is -C being returned to the calling program. -C -C IDID =-12 -- DDASPK failed to compute the initial Y, YPRIME. -C -C IDID =-13 -- unrecoverable error encountered inside user's -C PSOL routine, and control is being returned to -C the calling program. -C -C IDID =-14 -- the Krylov linear system solver could not -C achieve convergence. -C -C IDID =-15,..,-32 -- Not applicable for this code. -C -C *** TASK TERMINATED *** -C reported by the value of IDID=-33 -C -C IDID = -33 -- the code has encountered trouble from which -C it cannot recover. A message is printed -C explaining the trouble and control is returned -C to the calling program. For example, this occurs -C when invalid input is detected. -C -C RTOL, ATOL -- these quantities remain unchanged except when -C IDID = -2. In this case, the error tolerances have been -C increased by the code to values which are estimated to -C be appropriate for continuing the integration. However, -C the reported solution at T was obtained using the input -C values of RTOL and ATOL. -C -C RWORK, IWORK -- contain information which is usually of no interest -C to the user but necessary for subsequent calls. -C However, you may be interested in the performance data -C listed below. These quantities are accessed in RWORK -C and IWORK but have internal mnemonic names, as follows.. -C -C RWORK(3)--contains H, the step size h to be attempted -C on the next step. -C -C RWORK(4)--contains TN, the current value of the -C independent variable, i.e. the farthest point -C integration has reached. This will differ -C from T if interpolation has been performed -C (IDID = 3). -C -C RWORK(7)--contains HOLD, the stepsize used on the last -C successful step. If INFO(11) = INFO(14) = 1, -C this contains the value of H used in the -C initial condition calculation. -C -C IWORK(7)--contains K, the order of the method to be -C attempted on the next step. -C -C IWORK(8)--contains KOLD, the order of the method used -C on the last step. -C -C IWORK(11)--contains NST, the number of steps (in T) -C taken so far. -C -C IWORK(12)--contains NRE, the number of calls to RES -C so far. -C -C IWORK(13)--contains NJE, the number of calls to JAC so -C far (Jacobian or preconditioner evaluations). -C -C IWORK(14)--contains NETF, the total number of error test -C failures so far. -C -C IWORK(15)--contains NCFN, the total number of nonlinear -C convergence failures so far (includes counts -C of singular iteration matrix or singular -C preconditioners). -C -C IWORK(16)--contains NCFL, the number of convergence -C failures of the linear iteration so far. -C -C IWORK(17)--contains LENIW, the length of IWORK actually -C required. This is defined on normal returns -C and on an illegal input return for -C insufficient storage. -C -C IWORK(18)--contains LENRW, the length of RWORK actually -C required. This is defined on normal returns -C and on an illegal input return for -C insufficient storage. -C -C IWORK(19)--contains NNI, the total number of nonlinear -C iterations so far (each of which calls a -C linear solver). -C -C IWORK(20)--contains NLI, the total number of linear -C (Krylov) iterations so far. -C -C IWORK(21)--contains NPS, the number of PSOL calls so -C far, for preconditioning solve operations or -C for solutions with the user-supplied method. -C -C Note: The various counters in IWORK do not include -C counts during a call made with INFO(11) > 0 and -C INFO(14) = 1. -C -C -C------INPUT - WHAT TO DO TO CONTINUE THE INTEGRATION ----------------- -C (CALLS AFTER THE FIRST) -C -C This code is organized so that subsequent calls to continue the -C integration involve little (if any) additional effort on your -C part. You must monitor the IDID parameter in order to determine -C what to do next. -C -C Recalling that the principal task of the code is to integrate -C from T to TOUT (the interval mode), usually all you will need -C to do is specify a new TOUT upon reaching the current TOUT. -C -C Do not alter any quantity not specifically permitted below. In -C particular do not alter NEQ, T, Y(*), YPRIME(*), RWORK(*), -C IWORK(*), or the differential equation in subroutine RES. Any -C such alteration constitutes a new problem and must be treated -C as such, i.e. you must start afresh. -C -C You cannot change from array to scalar error control or vice -C versa (INFO(2)), but you can change the size of the entries of -C RTOL or ATOL. Increasing a tolerance makes the equation easier -C to integrate. Decreasing a tolerance will make the equation -C harder to integrate and should generally be avoided. -C -C You can switch from the intermediate-output mode to the -C interval mode (INFO(3)) or vice versa at any time. -C -C If it has been necessary to prevent the integration from going -C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the -C code will not integrate to any TOUT beyond the currently -C specified TSTOP. Once TSTOP has been reached, you must change -C the value of TSTOP or set INFO(4) = 0. You may change INFO(4) -C or TSTOP at any time but you must supply the value of TSTOP in -C RWORK(1) whenever you set INFO(4) = 1. -C -C Do not change INFO(5), INFO(6), INFO(12-17) or their associated -C IWORK/RWORK locations unless you are going to restart the code. -C -C *** FOLLOWING A COMPLETED TASK *** -C -C If.. -C IDID = 1, call the code again to continue the integration -C another step in the direction of TOUT. -C -C IDID = 2 or 3, define a new TOUT and call the code again. -C TOUT must be different from T. You cannot change -C the direction of integration without restarting. -C -C IDID = 4, reset INFO(11) = 0 and call the code again to begin -C the integration. (If you leave INFO(11) > 0 and -C INFO(14) = 1, you may generate an infinite loop.) -C In this situation, the next call to DASPK is -C considered to be the first call for the problem, -C in that all initializations are done. -C -C *** FOLLOWING AN INTERRUPTED TASK *** -C -C To show the code that you realize the task was interrupted and -C that you want to continue, you must take appropriate action and -C set INFO(1) = 1. -C -C If.. -C IDID = -1, the code has taken about 500 steps. If you want to -C continue, set INFO(1) = 1 and call the code again. -C An additional 500 steps will be allowed. -C -C -C IDID = -2, the error tolerances RTOL, ATOL have been increased -C to values the code estimates appropriate for -C continuing. You may want to change them yourself. -C If you are sure you want to continue with relaxed -C error tolerances, set INFO(1) = 1 and call the code -C again. -C -C IDID = -3, a solution component is zero and you set the -C corresponding component of ATOL to zero. If you -C are sure you want to continue, you must first alter -C the error criterion to use positive values of ATOL -C for those components corresponding to zero solution -C components, then set INFO(1) = 1 and call the code -C again. -C -C IDID = -4 --- cannot occur with this code. -C -C IDID = -5, your JAC routine failed with the Krylov method. Check -C for errors in JAC and restart the integration. -C -C IDID = -6, repeated error test failures occurred on the last -C attempted step in DDASPK. A singularity in the -C solution may be present. If you are absolutely -C certain you want to continue, you should restart -C the integration. (Provide initial values of Y and -C YPRIME which are consistent.) -C -C IDID = -7, repeated convergence test failures occurred on the last -C attempted step in DDASPK. An inaccurate or ill- -C conditioned Jacobian or preconditioner may be the -C problem. If you are absolutely certain you want -C to continue, you should restart the integration. -C -C -C IDID = -8, the matrix of partial derivatives is singular, with -C the use of direct methods. Some of your equations -C may be redundant. DDASPK cannot solve the problem -C as stated. It is possible that the redundant -C equations could be removed, and then DDASPK could -C solve the problem. It is also possible that a -C solution to your problem either does not exist -C or is not unique. -C -C IDID = -9, DDASPK had multiple convergence test failures, preceded -C by multiple error test failures, on the last -C attempted step. It is possible that your problem is -C ill-posed and cannot be solved using this code. Or, -C there may be a discontinuity or a singularity in the -C solution. If you are absolutely certain you want to -C continue, you should restart the integration. -C -C IDID = -10, DDASPK had multiple convergence test failures -C because IRES was equal to -1. If you are -C absolutely certain you want to continue, you -C should restart the integration. -C -C IDID = -11, there was an unrecoverable error (IRES = -2) from RES -C inside the nonlinear system solver. Determine the -C cause before trying again. -C -C IDID = -12, DDASPK failed to compute the initial Y and YPRIME -C vectors. This could happen because the initial -C approximation to Y or YPRIME was not very good, or -C because no consistent values of these vectors exist. -C The problem could also be caused by an inaccurate or -C singular iteration matrix, or a poor preconditioner. -C -C IDID = -13, there was an unrecoverable error encountered inside -C your PSOL routine. Determine the cause before -C trying again. -C -C IDID = -14, the Krylov linear system solver failed to achieve -C convergence. This may be due to ill-conditioning -C in the iteration matrix, or a singularity in the -C preconditioner (if one is being used). -C Another possibility is that there is a better -C choice of Krylov parameters (see INFO(13)). -C Possibly the failure is caused by redundant equations -C in the system, or by inconsistent equations. -C In that case, reformulate the system to make it -C consistent and non-redundant. -C -C IDID = -15,..,-32 --- Cannot occur with this code. -C -C *** FOLLOWING A TERMINATED TASK *** -C -C If IDID = -33, you cannot continue the solution of this problem. -C An attempt to do so will result in your run being -C terminated. -C -C --------------------------------------------------------------------- -C -C***REFERENCES -C 1. L. R. Petzold, A Description of DASSL: A Differential/Algebraic -C System Solver, in Scientific Computing, R. S. Stepleman et al. -C (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. -C 2. K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical -C Solution of Initial-Value Problems in Differential-Algebraic -C Equations, Elsevier, New York, 1989. -C 3. P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods -C in Stiff ODE Systems, J. Applied Mathematics and Computation, -C 31 (1989), pp. 40-91. -C 4. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov -C Methods in the Solution of Large-Scale Differential-Algebraic -C Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. -C 5. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent -C Initial Condition Calculation for Differential-Algebraic -C Systems, SIAM J. Sci. Comp. 19 (1998), pp. 1495-1512. -C -C***ROUTINES CALLED -C -C The following are all the subordinate routines used by DDASPK. -C -C DDASIC computes consistent initial conditions. -C DYYPNW updates Y and YPRIME in linesearch for initial condition -C calculation. -C DDSTP carries out one step of the integration. -C DCNSTR/DCNST0 check the current solution for constraint violations. -C DDAWTS sets error weight quantities. -C DINVWT tests and inverts the error weights. -C DDATRP performs interpolation to get an output solution. -C DDWNRM computes the weighted root-mean-square norm of a vector. -C D1MACH provides the unit roundoff of the computer. -C XERRWD/XSETF/XSETUN/IXSAV is a package to handle error messages. -C DDASID nonlinear equation driver to initialize Y and YPRIME using -C direct linear system solver methods. Interfaces to Newton -C solver (direct case). -C DNSID solves the nonlinear system for unknown initial values by -C modified Newton iteration and direct linear system methods. -C DLINSD carries out linesearch algorithm for initial condition -C calculation (direct case). -C DFNRMD calculates weighted norm of preconditioned residual in -C initial condition calculation (direct case). -C DNEDD nonlinear equation driver for direct linear system solver -C methods. Interfaces to Newton solver (direct case). -C DMATD assembles the iteration matrix (direct case). -C DNSD solves the associated nonlinear system by modified -C Newton iteration and direct linear system methods. -C DSLVD interfaces to linear system solver (direct case). -C DDASIK nonlinear equation driver to initialize Y and YPRIME using -C Krylov iterative linear system methods. Interfaces to -C Newton solver (Krylov case). -C DNSIK solves the nonlinear system for unknown initial values by -C Newton iteration and Krylov iterative linear system methods. -C DLINSK carries out linesearch algorithm for initial condition -C calculation (Krylov case). -C DFNRMK calculates weighted norm of preconditioned residual in -C initial condition calculation (Krylov case). -C DNEDK nonlinear equation driver for iterative linear system solver -C methods. Interfaces to Newton solver (Krylov case). -C DNSK solves the associated nonlinear system by Inexact Newton -C iteration and (linear) Krylov iteration. -C DSLVK interfaces to linear system solver (Krylov case). -C DSPIGM solves a linear system by SPIGMR algorithm. -C DATV computes matrix-vector product in Krylov algorithm. -C DORTH performs orthogonalization of Krylov basis vectors. -C DHEQR performs QR factorization of Hessenberg matrix. -C DHELS finds least-squares solution of Hessenberg linear system. -C DGEFA, DGESL, DGBFA, DGBSL are LINPACK routines for solving -C linear systems (dense or band direct methods). -C DAXPY, DCOPY, DDOT, DNRM2, DSCAL are Basic Linear Algebra (BLAS) -C routines. -C -C The routines called directly by DDASPK are: -C DCNST0, DDAWTS, DINVWT, D1MACH, DDWNRM, DDASIC, DDATRP, DDSTP, -C XERRWD -C -C***END PROLOGUE DDASPK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL DONE, LAVL, LCFN, LCFL, LWARN - DIMENSION Y(*),YPRIME(*) - DIMENSION INFO(20) - DIMENSION RWORK(LRW),IWORK(LIW) - DIMENSION RTOL(*),ATOL(*) - DIMENSION RPAR(*),IPAR(*) - CHARACTER MSG*80 - EXTERNAL RES, JAC, PSOL, DDASID, DDASIK, DNEDD, DNEDK -C -C Set pointers into IWORK. -C - PARAMETER (LML=1, LMU=2, LMTYPE=4, - * LIWM=1, LMXORD=3, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, - * LNS=9, LNSTL=10, LNST=11, LNRE=12, LNJE=13, LETF=14, LNCFN=15, - * LNCFL=16, LNIW=17, LNRW=18, LNNI=19, LNLI=20, LNPS=21, - * LNPD=22, LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26, LLNWP=27, - * LLNIWP=28, LLOCWP=29, LLCIWP=30, LKPRIN=31, - * LMXNIT=32, LMXNJ=33, LMXNH=34, LLSOFF=35, LICNS=41) -C -C Set pointers into RWORK. -C - PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, LCJ=5, LCJOLD=6, - * LHOLD=7, LS=8, LROUND=9, LEPLI=10, LSQRN=11, LRSQRN=12, - * LEPCON=13, LSTOL=14, LEPIN=15, - * LALPHA=21, LBETA=27, LGAMMA=33, LPSI=39, LSIGMA=45, LDELTA=51) -C - SAVE LID, LENID, NONNEG, NCPHI -C -C -C***FIRST EXECUTABLE STATEMENT DDASPK -C -C - IF(INFO(1).NE.0) GO TO 100 -C -C----------------------------------------------------------------------- -C This block is executed for the initial call only. -C It contains checking of inputs and initializations. -C----------------------------------------------------------------------- -C -C First check INFO array to make sure all elements of INFO -C Are within the proper range. (INFO(1) is checked later, because -C it must be tested on every call.) ITEMP holds the location -C within INFO which may be out of range. -C - DO 10 I=2,9 - ITEMP = I - IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 - 10 CONTINUE - ITEMP = 10 - IF(INFO(10).LT.0 .OR. INFO(10).GT.3) GO TO 701 - ITEMP = 11 - IF(INFO(11).LT.0 .OR. INFO(11).GT.2) GO TO 701 - DO 15 I=12,17 - ITEMP = I - IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 - 15 CONTINUE - ITEMP = 18 - IF(INFO(18).LT.0 .OR. INFO(18).GT.2) GO TO 701 - -C -C Check NEQ to see if it is positive. -C - IF (NEQ .LE. 0) GO TO 702 -C -C Check and compute maximum order. -C - MXORD=5 - IF (INFO(9) .NE. 0) THEN - MXORD=IWORK(LMXORD) - IF (MXORD .LT. 1 .OR. MXORD .GT. 5) GO TO 703 - ENDIF - IWORK(LMXORD)=MXORD -C -C Set and/or check inputs for constraint checking (INFO(10) .NE. 0). -C Set values for ICNFLG, NONNEG, and pointer LID. -C - ICNFLG = 0 - NONNEG = 0 - LID = LICNS - IF (INFO(10) .EQ. 0) GO TO 20 - IF (INFO(10) .EQ. 1) THEN - ICNFLG = 1 - NONNEG = 0 - LID = LICNS + NEQ - ELSEIF (INFO(10) .EQ. 2) THEN - ICNFLG = 0 - NONNEG = 1 - ELSE - ICNFLG = 1 - NONNEG = 1 - LID = LICNS + NEQ - ENDIF -C - 20 CONTINUE -C -C Set and/or check inputs for Krylov solver (INFO(12) .NE. 0). -C If indicated, set default values for MAXL, KMP, NRMAX, and EPLI. -C Otherwise, verify inputs required for iterative solver. -C - IF (INFO(12) .EQ. 0) GO TO 25 -C - IWORK(LMITER) = INFO(12) - IF (INFO(13) .EQ. 0) THEN - IWORK(LMAXL) = MIN(5,NEQ) - IWORK(LKMP) = IWORK(LMAXL) - IWORK(LNRMAX) = 5 - RWORK(LEPLI) = 0.05D0 - ELSE - IF(IWORK(LMAXL) .LT. 1 .OR. IWORK(LMAXL) .GT. NEQ) GO TO 720 - IF(IWORK(LKMP) .LT. 1 .OR. IWORK(LKMP) .GT. IWORK(LMAXL)) - 1 GO TO 721 - IF(IWORK(LNRMAX) .LT. 0) GO TO 722 - IF(RWORK(LEPLI).LE.0.0D0 .OR. RWORK(LEPLI).GE.1.0D0)GO TO 723 - ENDIF -C - 25 CONTINUE -C -C Set and/or check controls for the initial condition calculation -C (INFO(11) .GT. 0). If indicated, set default values. -C Otherwise, verify inputs required for iterative solver. -C - IF (INFO(11) .EQ. 0) GO TO 30 - IF (INFO(17) .EQ. 0) THEN - IWORK(LMXNIT) = 5 - IF (INFO(12) .GT. 0) IWORK(LMXNIT) = 15 - IWORK(LMXNJ) = 6 - IF (INFO(12) .GT. 0) IWORK(LMXNJ) = 2 - IWORK(LMXNH) = 5 - IWORK(LLSOFF) = 0 - RWORK(LEPIN) = 0.01D0 - ELSE - IF (IWORK(LMXNIT) .LE. 0) GO TO 725 - IF (IWORK(LMXNJ) .LE. 0) GO TO 725 - IF (IWORK(LMXNH) .LE. 0) GO TO 725 - LSOFF = IWORK(LLSOFF) - IF (LSOFF .LT. 0 .OR. LSOFF .GT. 1) GO TO 725 - IF (RWORK(LEPIN) .LE. 0.0D0) GO TO 725 - ENDIF -C - 30 CONTINUE -C -C Below is the computation and checking of the work array lengths -C LENIW and LENRW, using direct methods (INFO(12) = 0) or -C the Krylov methods (INFO(12) = 1). -C - LENIC = 0 - IF (INFO(10) .EQ. 1 .OR. INFO(10) .EQ. 3) LENIC = NEQ - LENID = 0 - IF (INFO(11) .EQ. 1 .OR. INFO(16) .EQ. 1) LENID = NEQ - IF (INFO(12) .EQ. 0) THEN -C -C Compute MTYPE, etc. Check ML and MU. -C - NCPHI = MAX(MXORD + 1, 4) - IF(INFO(6).EQ.0) THEN - LENPD = NEQ**2 - LENRW = 50 + (NCPHI+3)*NEQ + LENPD - IF(INFO(5).EQ.0) THEN - IWORK(LMTYPE)=2 - ELSE - IWORK(LMTYPE)=1 - ENDIF - ELSE - IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 - IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 - LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ - IF(INFO(5).EQ.0) THEN - IWORK(LMTYPE)=5 - MBAND=IWORK(LML)+IWORK(LMU)+1 - MSAVE=(NEQ/MBAND)+1 - LENRW = 50 + (NCPHI+3)*NEQ + LENPD + 2*MSAVE - ELSE - IWORK(LMTYPE)=4 - LENRW = 50 + (NCPHI+3)*NEQ + LENPD - ENDIF - ENDIF -C -C Compute LENIW, LENWP, LENIWP. -C - LENIW = 40 + LENIC + LENID + NEQ - LENWP = 0 - LENIWP = 0 -C - ELSE IF (INFO(12) .EQ. 1) THEN - NCPHI = MXORD + 1 - MAXL = IWORK(LMAXL) - LENWP = IWORK(LLNWP) - LENIWP = IWORK(LLNIWP) - LENPD = (MAXL+3+MIN0(1,MAXL-IWORK(LKMP)))*NEQ - 1 + (MAXL+3)*MAXL + 1 + LENWP - LENRW = 50 + (MXORD+5)*NEQ + LENPD - LENIW = 40 + LENIC + LENID + LENIWP -C - ENDIF - IF(INFO(16) .NE. 0) LENRW = LENRW + NEQ -C -C Check lengths of RWORK and IWORK. -C - IWORK(LNIW)=LENIW - IWORK(LNRW)=LENRW - IWORK(LNPD)=LENPD - IWORK(LLOCWP) = LENPD-LENWP+1 - IF(LRW.LT.LENRW)GO TO 704 - IF(LIW.LT.LENIW)GO TO 705 -C -C Check ICNSTR for legality. -C - IF (LENIC .GT. 0) THEN - DO 40 I = 1,NEQ - ICI = IWORK(LICNS-1+I) - IF (ICI .LT. -2 .OR. ICI .GT. 2) GO TO 726 - 40 CONTINUE - ENDIF -C -C Check Y for consistency with constraints. -C - IF (LENIC .GT. 0) THEN - CALL DCNST0(NEQ,Y,IWORK(LICNS),IRET) - IF (IRET .NE. 0) GO TO 727 - ENDIF -C -C Check ID for legality and set INDEX = 0 or 1. -C - INDEX = 1 - IF (LENID .GT. 0) THEN - INDEX = 0 - DO 50 I = 1,NEQ - IDI = IWORK(LID-1+I) - IF (IDI .NE. 1 .AND. IDI .NE. -1) GO TO 724 - IF (IDI .EQ. -1) INDEX = 1 - 50 CONTINUE - ENDIF -C -C Check to see that TOUT is different from T. -C - IF(TOUT .EQ. T)GO TO 719 -C -C Check HMAX. -C - IF(INFO(7) .NE. 0) THEN - HMAX = RWORK(LHMAX) - IF (HMAX .LE. 0.0D0) GO TO 710 - ENDIF -C -C Initialize counters and other flags. -C - IWORK(LNST)=0 - IWORK(LNRE)=0 - IWORK(LNJE)=0 - IWORK(LETF)=0 - IWORK(LNCFN)=0 - IWORK(LNNI)=0 - IWORK(LNLI)=0 - IWORK(LNPS)=0 - IWORK(LNCFL)=0 - IWORK(LKPRIN)=INFO(18) - IDID=1 - GO TO 200 -C -C----------------------------------------------------------------------- -C This block is for continuation calls only. -C Here we check INFO(1), and if the last step was interrupted, -C we check whether appropriate action was taken. -C----------------------------------------------------------------------- -C -100 CONTINUE - IF(INFO(1).EQ.1)GO TO 110 - ITEMP = 1 - IF(INFO(1).NE.-1)GO TO 701 -C -C If we are here, the last step was interrupted by an error -C condition from DDSTP, and appropriate action was not taken. -C This is a fatal error. -C - MSG = 'DASPK-- THE LAST STEP TERMINATED WITH A NEGATIVE' - CALL XERRWD(MSG,49,201,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- VALUE (=I1) OF IDID AND NO APPROPRIATE' - CALL XERRWD(MSG,47,202,0,1,IDID,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- ACTION WAS TAKEN. RUN TERMINATED' - CALL XERRWD(MSG,41,203,1,0,0,0,0,0.0D0,0.0D0) - RETURN -110 CONTINUE -C -C----------------------------------------------------------------------- -C This block is executed on all calls. -C -C Counters are saved for later checks of performance. -C Then the error tolerance parameters are checked, and the -C work array pointers are set. -C----------------------------------------------------------------------- -C -200 CONTINUE -C -C Save counters for use later. -C - IWORK(LNSTL)=IWORK(LNST) - NLI0 = IWORK(LNLI) - NNI0 = IWORK(LNNI) - NCFN0 = IWORK(LNCFN) - NCFL0 = IWORK(LNCFL) - NWARN = 0 -C -C Check RTOL and ATOL. -C - NZFLG = 0 - RTOLI = RTOL(1) - ATOLI = ATOL(1) - DO 210 I=1,NEQ - IF (INFO(2) .EQ. 1) RTOLI = RTOL(I) - IF (INFO(2) .EQ. 1) ATOLI = ATOL(I) - IF (RTOLI .GT. 0.0D0 .OR. ATOLI .GT. 0.0D0) NZFLG = 1 - IF (RTOLI .LT. 0.0D0) GO TO 706 - IF (ATOLI .LT. 0.0D0) GO TO 707 -210 CONTINUE - IF (NZFLG .EQ. 0) GO TO 708 -C -C Set pointers to RWORK and IWORK segments. -C For direct methods, SAVR is not used. -C - IWORK(LLCIWP) = LID + LENID - LSAVR = LDELTA - IF (INFO(12) .NE. 0) LSAVR = LDELTA + NEQ - LE = LSAVR + NEQ - LWT = LE + NEQ - LVT = LWT - IF (INFO(16) .NE. 0) LVT = LWT + NEQ - LPHI = LVT + NEQ - LWM = LPHI + NCPHI*NEQ - IF (INFO(1) .EQ. 1) GO TO 400 -C -C----------------------------------------------------------------------- -C This block is executed on the initial call only. -C Set the initial step size, the error weight vector, and PHI. -C Compute unknown initial components of Y and YPRIME, if requested. -C----------------------------------------------------------------------- -C -300 CONTINUE - TN=T - IDID=1 -C -C Set error weight array WT and altered weight array VT. -C - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) GO TO 713 - IF (INFO(16) .NE. 0) THEN - DO 305 I = 1, NEQ - 305 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) - ENDIF -C -C Compute unit roundoff and HMIN. -C - UROUND = D1MACH(4) - RWORK(LROUND) = UROUND - HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) -C -C Set/check STPTOL control for initial condition calculation. -C - IF (INFO(11) .NE. 0) THEN - IF( INFO(17) .EQ. 0) THEN - RWORK(LSTOL) = UROUND**.6667D0 - ELSE - IF (RWORK(LSTOL) .LE. 0.0D0) GO TO 725 - ENDIF - ENDIF -C -C Compute EPCON and square root of NEQ and its reciprocal, used -C inside iterative solver. -C - RWORK(LEPCON) = 0.33D0 - FLOATN = NEQ - RWORK(LSQRN) = SQRT(FLOATN) - RWORK(LRSQRN) = 1.D0/RWORK(LSQRN) -C -C Check initial interval to see that it is long enough. -C - TDIST = ABS(TOUT - T) - IF(TDIST .LT. HMIN) GO TO 714 -C -C Check H0, if this was input. -C - IF (INFO(8) .EQ. 0) GO TO 310 - H0 = RWORK(LH) - IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 711 - IF (H0 .EQ. 0.0D0) GO TO 712 - GO TO 320 -310 CONTINUE -C -C Compute initial stepsize, to be used by either -C DDSTP or DDASIC, depending on INFO(11). -C - H0 = 0.001D0*TDIST - YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) - IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM - H0 = SIGN(H0,TOUT-T) -C -C Adjust H0 if necessary to meet HMAX bound. -C -320 IF (INFO(7) .EQ. 0) GO TO 330 - RH = ABS(H0)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H0 = H0/RH -C -C Check against TSTOP, if applicable. -C -330 IF (INFO(4) .EQ. 0) GO TO 340 - TSTOP = RWORK(LTSTOP) - write(*,*) 'tstop = ',tstop - IF ((TSTOP - T)*H0 .LT. 0.0D0) GO TO 715 - IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T - IF ((TSTOP - TOUT)*H0 .LT. 0.0D0) GO TO 709 -C -340 IF (INFO(11) .EQ. 0) GO TO 370 -C -C Compute unknown components of initial Y and YPRIME, depending -C on INFO(11) and INFO(12). INFO(12) represents the nonlinear -C solver type (direct/Krylov). Pass the name of the specific -C nonlinear solver, depending on INFO(12). The location of the work -C arrays SAVR, YIC, YPIC, PWK also differ in the two cases. -C For use in stopping tests, pass TSCALE = TDIST if INDEX = 0. -C - NWT = 1 - EPCONI = RWORK(LEPIN)*RWORK(LEPCON) - TSCALE = 0.0D0 - IF (INDEX .EQ. 0) TSCALE = TDIST -350 IF (INFO(12) .EQ. 0) THEN - LYIC = LPHI + 2*NEQ - LYPIC = LYIC + NEQ - LPWK = LYPIC - CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), - * RES,JAC,PSOL,H0,TSCALE,RWORK(LWT),NWT,IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), - * RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASID) - ELSE IF (INFO(12) .EQ. 1) THEN - LYIC = LWM - LYPIC = LYIC + NEQ - LPWK = LYPIC + NEQ - CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), - * RES,JAC,PSOL,H0,TSCALE,RWORK(LWT),NWT,IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), - * RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASIK) - ENDIF -C - IF (IDID .LT. 0) GO TO 600 -C -C DDASIC was successful. If this was the first call to DDASIC, -C update the WT array (with the current Y) and call it again. -C - IF (NWT .EQ. 2) GO TO 355 - NWT = 2 - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) GO TO 713 - GO TO 350 -C -C If INFO(14) = 1, return now with IDID = 4. -C -355 IF (INFO(14) .EQ. 1) THEN - IDID = 4 - H = H0 - IF (INFO(11) .EQ. 1) RWORK(LHOLD) = H0 - GO TO 590 - ENDIF -C -C Update the WT and VT arrays one more time, with the new Y. -C - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) GO TO 713 - IF (INFO(16) .NE. 0) THEN - DO 357 I = 1, NEQ - 357 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) - ENDIF -C -C Reset the initial stepsize to be used by DDSTP. -C Use H0, if this was input. Otherwise, recompute H0, -C and adjust it if necessary to meet HMAX bound. -C - IF (INFO(8) .NE. 0) THEN - H0 = RWORK(LH) - GO TO 360 - ENDIF -C - H0 = 0.001D0*TDIST - YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) - IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM - H0 = SIGN(H0,TOUT-T) -C -360 IF (INFO(7) .NE. 0) THEN - RH = ABS(H0)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H0 = H0/RH - ENDIF -C -C Check against TSTOP, if applicable. -C - IF (INFO(4) .NE. 0) THEN - TSTOP = RWORK(LTSTOP) - write(*,*) 'tstop = ',tstop - IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T - ENDIF -C -C Load H and RWORK(LH) with H0. -C -370 H = H0 - RWORK(LH) = H -C -C Load Y and H*YPRIME into PHI(*,1) and PHI(*,2). -C - ITEMP = LPHI + NEQ - DO 380 I = 1,NEQ - RWORK(LPHI + I - 1) = Y(I) -380 RWORK(ITEMP + I - 1) = H*YPRIME(I) -C - GO TO 500 -C -C----------------------------------------------------------------------- -C This block is for continuation calls only. -C Its purpose is to check stop conditions before taking a step. -C Adjust H if necessary to meet HMAX bound. -C----------------------------------------------------------------------- -C -400 CONTINUE - UROUND=RWORK(LROUND) - DONE = .FALSE. - TN=RWORK(LTN) - H=RWORK(LH) - IF(INFO(7) .EQ. 0) GO TO 410 - RH = ABS(H)/RWORK(LHMAX) - IF(RH .GT. 1.0D0) H = H/RH -410 CONTINUE - IF(T .EQ. TOUT) GO TO 719 - IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 - IF(INFO(4) .EQ. 1) GO TO 430 - IF(INFO(3) .EQ. 1) GO TO 420 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 - IF((TN - TOUT)*H .GE. 0.0D0) GO TO 425 - CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -425 CONTINUE - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -430 IF(INFO(3) .EQ. 1) GO TO 440 - TSTOP=RWORK(LTSTOP) - write(*,*) 'tstop = ',tstop - IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 - IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -440 TSTOP = RWORK(LTSTOP) - write(*,*) 'tstop = ',tstop - IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 - IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 - IF((TN-T)*H .LE. 0.0D0) GO TO 450 - IF((TN - TOUT)*H .GE. 0.0D0) GO TO 445 - CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -445 CONTINUE - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -450 CONTINUE -C -C Check whether we are within roundoff of TSTOP. -C - IF(ABS(TN-TSTOP).GT.100.0D0*UROUND* - * (ABS(TN)+ABS(H)))GO TO 460 - CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - DONE = .TRUE. - GO TO 490 -460 TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 - H=TSTOP-TN - RWORK(LH)=H -C -490 IF (DONE) GO TO 590 -C -C----------------------------------------------------------------------- -C The next block contains the call to the one-step integrator DDSTP. -C This is a looping point for the integration steps. -C Check for too many steps. -C Check for poor Newton/Krylov performance. -C Update WT. Check for too much accuracy requested. -C Compute minimum stepsize. -C----------------------------------------------------------------------- -C -500 CONTINUE -C -C Check for too many steps. -C - IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) GO TO 505 - IDID=-1 - GO TO 527 -C -C Check for poor Newton/Krylov performance. -C -505 IF (INFO(12) .EQ. 0) GO TO 510 - NSTD = IWORK(LNST) - IWORK(LNSTL) - NNID = IWORK(LNNI) - NNI0 - IF (NSTD .LT. 10 .OR. NNID .EQ. 0) GO TO 510 - AVLIN = REAL(IWORK(LNLI) - NLI0)/REAL(NNID) - RCFN = REAL(IWORK(LNCFN) - NCFN0)/REAL(NSTD) - RCFL = REAL(IWORK(LNCFL) - NCFL0)/REAL(NNID) - FMAXL = IWORK(LMAXL) - LAVL = AVLIN .GT. FMAXL - LCFN = RCFN .GT. 0.9D0 - LCFL = RCFL .GT. 0.9D0 - LWARN = LAVL .OR. LCFN .OR. LCFL - IF (.NOT.LWARN) GO TO 510 - NWARN = NWARN + 1 - IF (NWARN .GT. 10) GO TO 510 - IF (LAVL) THEN - MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' - CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' at T = R1. Average no. of linear iterations = R2 ' - CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 2, TN, AVLIN) - ENDIF - IF (LCFN) THEN - MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' - CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' at T = R1. Nonlinear convergence failure rate = R2' - CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 2, TN, RCFN) - ENDIF - IF (LCFL) THEN - MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' - CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' at T = R1. Linear convergence failure rate = R2 ' - CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 2, TN, RCFL) - ENDIF -C -C Update WT and VT, if this is not the first call. -C -510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),RWORK(LWT), - * RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) THEN - IDID = -3 - GO TO 527 - ENDIF - IF (INFO(16) .NE. 0) THEN - DO 515 I = 1, NEQ - 515 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) - ENDIF -C -C Test for too much accuracy requested. -C - R = DDWNRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*100.0D0*UROUND - IF (R .LE. 1.0D0) GO TO 525 -C -C Multiply RTOL and ATOL by R and return. -C - IF(INFO(2).EQ.1)GO TO 523 - RTOL(1)=R*RTOL(1) - ATOL(1)=R*ATOL(1) - IDID=-2 - GO TO 527 -523 DO 524 I=1,NEQ - RTOL(I)=R*RTOL(I) -524 ATOL(I)=R*ATOL(I) - IDID=-2 - GO TO 527 -525 CONTINUE -C -C Compute minimum stepsize. -C - HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT)) -C -C Test H vs. HMAX - IF (INFO(7) .NE. 0) THEN - RH = ABS(H)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H = H/RH - ENDIF -C -C Call the one-step integrator. -C Note that INFO(12) represents the nonlinear solver type. -C Pass the required nonlinear solver, depending upon INFO(12). -C - IF (INFO(12) .EQ. 0) THEN - CALL DDSTP(TN,Y,YPRIME,NEQ, - * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM), - * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), - * RWORK(LPSI),RWORK(LSIGMA), - * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, - * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), - * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), - * DNEDD) - ELSE IF (INFO(12) .EQ. 1) THEN - CALL DDSTP(TN,Y,YPRIME,NEQ, - * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM), - * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), - * RWORK(LPSI),RWORK(LSIGMA), - * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, - * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), - * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), - * DNEDK) - ENDIF -C -527 IF(IDID.LT.0)GO TO 600 -C -C----------------------------------------------------------------------- -C This block handles the case of a successful return from DDSTP -C (IDID=1). Test for stop conditions. -C----------------------------------------------------------------------- -C - IF(INFO(4).NE.0)GO TO 540 - IF(INFO(3).NE.0)GO TO 530 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=3 - T=TOUT - GO TO 580 -530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 - T=TN - IDID=1 - GO TO 580 -535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=3 - T=TOUT - GO TO 580 -540 IF(INFO(3).NE.0)GO TO 550 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 - GO TO 580 -542 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND* - * (ABS(TN)+ABS(H)))GO TO 545 - TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 - H=TSTOP-TN - GO TO 500 -545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 - IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 - T=TN - IDID=1 - GO TO 580 -552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 -580 CONTINUE -C -C----------------------------------------------------------------------- -C All successful returns from DDASPK are made from this block. -C----------------------------------------------------------------------- -C -590 CONTINUE - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C This block handles all unsuccessful returns other than for -C illegal input. -C----------------------------------------------------------------------- -C -600 CONTINUE - ITEMP = -IDID - GO TO (610,620,630,700,655,640,650,660,670,675, - * 680,685,690,695), ITEMP -C -C The maximum number of steps was taken before -C reaching tout. -C -610 MSG = 'DASPK-- AT CURRENT T (=R1) 500 STEPS' - CALL XERRWD(MSG,38,610,0,0,0,0,1,TN,0.0D0) - MSG = 'DASPK-- TAKEN ON THIS CALL BEFORE REACHING TOUT' - CALL XERRWD(MSG,48,611,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Too much accuracy for machine precision. -C -620 MSG = 'DASPK-- AT T (=R1) TOO MUCH ACCURACY REQUESTED' - CALL XERRWD(MSG,47,620,0,0,0,0,1,TN,0.0D0) - MSG = 'DASPK-- FOR PRECISION OF MACHINE. RTOL AND ATOL' - CALL XERRWD(MSG,48,621,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- WERE INCREASED TO APPROPRIATE VALUES' - CALL XERRWD(MSG,45,622,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C WT(I) .LE. 0.0D0 for some I (not at start of problem). -C -630 MSG = 'DASPK-- AT T (=R1) SOME ELEMENT OF WT' - CALL XERRWD(MSG,38,630,0,0,0,0,1,TN,0.0D0) - MSG = 'DASPK-- HAS BECOME .LE. 0.0' - CALL XERRWD(MSG,28,631,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Error test failed repeatedly or with H=HMIN. -C -640 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,640,0,0,0,0,2,TN,H) - MSG='DASPK-- ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN' - CALL XERRWD(MSG,57,641,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Nonlinear solver failed to converge repeatedly or with H=HMIN. -C -650 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,650,0,0,0,0,2,TN,H) - MSG = 'DASPK-- NONLINEAR SOLVER FAILED TO CONVERGE' - CALL XERRWD(MSG,44,651,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- REPEATEDLY OR WITH ABS(H)=HMIN' - CALL XERRWD(MSG,40,652,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C The preconditioner had repeated failures. -C -655 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,655,0,0,0,0,2,TN,H) - MSG = 'DASPK-- PRECONDITIONER HAD REPEATED FAILURES.' - CALL XERRWD(MSG,46,656,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C The iteration matrix is singular. -C -660 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,660,0,0,0,0,2,TN,H) - MSG = 'DASPK-- ITERATION MATRIX IS SINGULAR.' - CALL XERRWD(MSG,38,661,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Nonlinear system failure preceded by error test failures. -C -670 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,670,0,0,0,0,2,TN,H) - MSG = 'DASPK-- NONLINEAR SOLVER COULD NOT CONVERGE.' - CALL XERRWD(MSG,45,671,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- ALSO, THE ERROR TEST FAILED REPEATEDLY.' - CALL XERRWD(MSG,49,672,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Nonlinear system failure because IRES = -1. -C -675 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,675,0,0,0,0,2,TN,H) - MSG = 'DASPK-- NONLINEAR SYSTEM SOLVER COULD NOT CONVERGE' - CALL XERRWD(MSG,51,676,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- BECAUSE IRES WAS EQUAL TO MINUS ONE' - CALL XERRWD(MSG,44,677,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Failure because IRES = -2. -C -680 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2)' - CALL XERRWD(MSG,40,680,0,0,0,0,2,TN,H) - MSG = 'DASPK-- IRES WAS EQUAL TO MINUS TWO' - CALL XERRWD(MSG,36,681,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Failed to compute initial YPRIME. -C -685 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,685,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- INITIAL (Y,YPRIME) COULD NOT BE COMPUTED' - CALL XERRWD(MSG,49,686,0,0,0,0,2,TN,H0) - GO TO 700 -C -C Failure because IER was negative from PSOL. -C -690 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2)' - CALL XERRWD(MSG,40,690,0,0,0,0,2,TN,H) - MSG = 'DASPK-- IER WAS NEGATIVE FROM PSOL' - CALL XERRWD(MSG,35,691,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Failure because the linear system solver could not converge. -C -695 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,695,0,0,0,0,2,TN,H) - MSG = 'DASPK-- LINEAR SYSTEM SOLVER COULD NOT CONVERGE.' - CALL XERRWD(MSG,50,696,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C -700 CONTINUE - INFO(1)=-1 - T=TN - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C This block handles all error returns due to illegal input, -C as detected before calling DDSTP. -C First the error message routine is called. If this happens -C twice in succession, execution is terminated. -C----------------------------------------------------------------------- -C -701 MSG = 'DASPK-- ELEMENT (=I1) OF INFO VECTOR IS NOT VALID' - CALL XERRWD(MSG,50,1,0,1,ITEMP,0,0,0.0D0,0.0D0) - GO TO 750 -702 MSG = 'DASPK-- NEQ (=I1) .LE. 0' - CALL XERRWD(MSG,25,2,0,1,NEQ,0,0,0.0D0,0.0D0) - GO TO 750 -703 MSG = 'DASPK-- MAXORD (=I1) NOT IN RANGE' - CALL XERRWD(MSG,34,3,0,1,MXORD,0,0,0.0D0,0.0D0) - GO TO 750 -704 MSG='DASPK-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)' - CALL XERRWD(MSG,60,4,0,2,LENRW,LRW,0,0.0D0,0.0D0) - GO TO 750 -705 MSG='DASPK-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)' - CALL XERRWD(MSG,60,5,0,2,LENIW,LIW,0,0.0D0,0.0D0) - GO TO 750 -706 MSG = 'DASPK-- SOME ELEMENT OF RTOL IS .LT. 0' - CALL XERRWD(MSG,39,6,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -707 MSG = 'DASPK-- SOME ELEMENT OF ATOL IS .LT. 0' - CALL XERRWD(MSG,39,7,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -708 MSG = 'DASPK-- ALL ELEMENTS OF RTOL AND ATOL ARE ZERO' - CALL XERRWD(MSG,47,8,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -709 MSG='DASPK-- INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)' - CALL XERRWD(MSG,54,9,0,0,0,0,2,TSTOP,TOUT) - GO TO 750 -710 MSG = 'DASPK-- HMAX (=R1) .LT. 0.0' - CALL XERRWD(MSG,28,10,0,0,0,0,1,HMAX,0.0D0) - GO TO 750 -711 MSG = 'DASPK-- TOUT (=R1) BEHIND T (=R2)' - CALL XERRWD(MSG,34,11,0,0,0,0,2,TOUT,T) - GO TO 750 -712 MSG = 'DASPK-- INFO(8)=1 AND H0=0.0' - CALL XERRWD(MSG,29,12,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -713 MSG = 'DASPK-- SOME ELEMENT OF WT IS .LE. 0.0' - CALL XERRWD(MSG,39,13,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -714 MSG='DASPK-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION' - CALL XERRWD(MSG,60,14,0,0,0,0,2,TOUT,T) - GO TO 750 -715 MSG = 'DASPK-- INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)' - CALL XERRWD(MSG,49,15,0,0,0,0,2,TSTOP,T) - GO TO 750 -717 MSG = 'DASPK-- ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' - CALL XERRWD(MSG,52,17,0,1,IWORK(LML),0,0,0.0D0,0.0D0) - GO TO 750 -718 MSG = 'DASPK-- MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' - CALL XERRWD(MSG,52,18,0,1,IWORK(LMU),0,0,0.0D0,0.0D0) - GO TO 750 -719 MSG = 'DASPK-- TOUT (=R1) IS EQUAL TO T (=R2)' - CALL XERRWD(MSG,39,19,0,0,0,0,2,TOUT,T) - GO TO 750 -720 MSG = 'DASPK-- MAXL (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. NEQ' - CALL XERRWD(MSG,54,20,0,1,IWORK(LMAXL),0,0,0.0D0,0.0D0) - GO TO 750 -721 MSG = 'DASPK-- KMP (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. MAXL' - CALL XERRWD(MSG,54,21,0,1,IWORK(LKMP),0,0,0.0D0,0.0D0) - GO TO 750 -722 MSG = 'DASPK-- NRMAX (=I1) ILLEGAL. .LT. 0' - CALL XERRWD(MSG,36,22,0,1,IWORK(LNRMAX),0,0,0.0D0,0.0D0) - GO TO 750 -723 MSG = 'DASPK-- EPLI (=R1) ILLEGAL. EITHER .LE. 0.D0 OR .GE. 1.D0' - CALL XERRWD(MSG,58,23,0,0,0,0,1,RWORK(LEPLI),0.0D0) - GO TO 750 -724 MSG = 'DASPK-- ILLEGAL IWORK VALUE FOR INFO(11) .NE. 0' - CALL XERRWD(MSG,48,24,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -725 MSG = 'DASPK-- ONE OF THE INPUTS FOR INFO(17) = 1 IS ILLEGAL' - CALL XERRWD(MSG,54,25,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -726 MSG = 'DASPK-- ILLEGAL IWORK VALUE FOR INFO(10) .NE. 0' - CALL XERRWD(MSG,48,26,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -727 MSG = 'DASPK-- Y(I) AND IWORK(40+I) (I=I1) INCONSISTENT' - CALL XERRWD(MSG,49,27,0,1,IRET,0,0,0.0D0,0.0D0) - GO TO 750 -750 IF(INFO(1).EQ.-1) GO TO 760 - INFO(1)=-1 - IDID=-33 - RETURN -760 MSG = 'DASPK-- REPEATED OCCURRENCES OF ILLEGAL INPUT' - CALL XERRWD(MSG,46,701,0,0,0,0,0,0.0D0,0.0D0) -770 MSG = 'DASPK-- RUN TERMINATED. APPARENT INFINITE LOOP' - CALL XERRWD(MSG,47,702,1,0,0,0,0,0.0D0,0.0D0) - RETURN -C -C------END OF SUBROUTINE DDASPK----------------------------------------- - END - SUBROUTINE DDASIC (X, Y, YPRIME, NEQ, ICOPT, ID, RES, JAC, PSOL, - * H, TSCALE, WT, NIC, IDID, RPAR, IPAR, PHI, SAVR, DELTA, E, - * YIC, YPIC, PWK, WM, IWM, UROUND, EPLI, SQRTN, RSQRTN, - * EPCONI, STPTOL, JFLG, ICNFLG, ICNSTR, NLSIC) -C -C***BEGIN PROLOGUE DDASIC -C***REFER TO DDASPK -C***DATE WRITTEN 940628 (YYMMDD) -C***REVISION DATE 941206 (YYMMDD) -C***REVISION DATE 950714 (YYMMDD) -C***REVISION DATE 000628 TSCALE argument added. -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DDASIC is a driver routine to compute consistent initial values -C for Y and YPRIME. There are two different options: -C Denoting the differential variables in Y by Y_d, and -C the algebraic variables by Y_a, the problem solved is either: -C 1. Given Y_d, calculate Y_a and Y_d', or -C 2. Given Y', calculate Y. -C In either case, initial values for the given components -C are input, and initial guesses for the unknown components -C must also be provided as input. -C -C The external routine NLSIC solves the resulting nonlinear system. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector at X. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of equations to be integrated. -C ICOPT -- Flag indicating initial condition option chosen. -C ICOPT = 1 for option 1 above. -C ICOPT = 2 for option 2. -C ID -- Array of dimension NEQ, which must be initialized -C if option 1 is chosen. -C ID(i) = +1 if Y_i is a differential variable, -C ID(i) = -1 if Y_i is an algebraic variable. -C RES -- External user-supplied subroutine to evaluate the -C residual. See RES description in DDASPK prologue. -C JAC -- External user-supplied routine to update Jacobian -C or preconditioner information in the nonlinear solver -C (optional). See JAC description in DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C See PSOL in DDASPK prologue. -C H -- Scaling factor in iteration matrix. DDASIC may -C reduce H to achieve convergence. -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C WT -- Vector of weights for error criterion. -C NIC -- Input number of initial condition calculation call -C (= 1 or 2). -C IDID -- Completion code. See IDID in DDASPK prologue. -C RPAR,IPAR -- Real and integer parameter arrays that -C are used for communication between the -C calling program and external user routines. -C They are not altered by DNSK -C PHI -- Work space for DDASIC of length at least 2*NEQ. -C SAVR -- Work vector for DDASIC of length NEQ. -C DELTA -- Work vector for DDASIC of length NEQ. -C E -- Work vector for DDASIC of length NEQ. -C YIC,YPIC -- Work vectors for DDASIC, each of length NEQ. -C PWK -- Work vector for DDASIC of length NEQ. -C WM,IWM -- Real and integer arrays storing -C information required by the linear solver. -C EPCONI -- Test constant for Newton iteration convergence. -C ICNFLG -- Flag showing whether constraints on Y are to apply. -C ICNSTR -- Integer array of length NEQ with constraint types. -C -C The other parameters are for use internally by DDASIC. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DCOPY, NLSIC -C -C***END PROLOGUE DDASIC -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),ID(*),WT(*),PHI(NEQ,*) - DIMENSION SAVR(*),DELTA(*),E(*),YIC(*),YPIC(*),PWK(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*), ICNSTR(*) - EXTERNAL RES, JAC, PSOL, NLSIC -C - PARAMETER (LCFN=15) - PARAMETER (LMXNH=34) -C -C The following parameters are data-loaded here: -C RHCUT = factor by which H is reduced on retry of Newton solve. -C RATEMX = maximum convergence rate for which Newton iteration -C is considered converging. -C - SAVE RHCUT, RATEMX - DATA RHCUT/0.1D0/, RATEMX/0.8D0/ -C -C -C----------------------------------------------------------------------- -C BLOCK 1. -C Initializations. -C JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that -C the initial call to the JAC routine is to be skipped then. -C Save Y and YPRIME in PHI. Initialize IDID, NH, and CJ. -C----------------------------------------------------------------------- -C - MXNH = IWM(LMXNH) - IDID = 1 - NH = 1 - JSKIP = 0 - IF (NIC .EQ. 2) JSKIP = 1 - CALL DCOPY (NEQ, Y, 1, PHI(1,1), 1) - CALL DCOPY (NEQ, YPRIME, 1, PHI(1,2), 1) -C - IF (ICOPT .EQ. 2) THEN - CJ = 0.0D0 - ELSE - CJ = 1.0D0/H - ENDIF -C -C----------------------------------------------------------------------- -C BLOCK 2 -C Call the nonlinear system solver to obtain -C consistent initial values for Y and YPRIME. -C----------------------------------------------------------------------- -C - 200 CONTINUE - CALL NLSIC(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JAC,PSOL,H,TSCALE,WT, - * JSKIP,RPAR,IPAR,SAVR,DELTA,E,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, - * EPLI,SQRTN,RSQRTN,EPCONI,RATEMX,STPTOL,JFLG,ICNFLG,ICNSTR, - * IERNLS) -C - IF (IERNLS .EQ. 0) RETURN -C -C----------------------------------------------------------------------- -C BLOCK 3 -C The nonlinear solver was unsuccessful. Increment NCFN. -C Return with IDID = -12 if either -C IERNLS = -1: error is considered unrecoverable, -C ICOPT = 2: we are doing initialization problem type 2, or -C NH = MXNH: the maximum number of H values has been tried. -C Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again. -C If IERNLS > 1, restore Y and YPRIME to their original values. -C----------------------------------------------------------------------- -C - IWM(LCFN) = IWM(LCFN) + 1 - JSKIP = 0 -C - IF (IERNLS .EQ. -1) GO TO 350 - IF (ICOPT .EQ. 2) GO TO 350 - IF (NH .EQ. MXNH) GO TO 350 -C - NH = NH + 1 - H = H*RHCUT - CJ = 1.0D0/H -C - IF (IERNLS .EQ. 1) GO TO 200 -C - CALL DCOPY (NEQ, PHI(1,1), 1, Y, 1) - CALL DCOPY (NEQ, PHI(1,2), 1, YPRIME, 1) - GO TO 200 -C - 350 IDID = -12 - RETURN -C -C------END OF SUBROUTINE DDASIC----------------------------------------- - END - SUBROUTINE DYYPNW (NEQ, Y, YPRIME, CJ, RL, P, ICOPT, ID, - * YNEW, YPNEW) -C -C***BEGIN PROLOGUE DYYPNW -C***REFER TO DLINSK -C***DATE WRITTEN 940830 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DYYPNW calculates the new (Y,YPRIME) pair needed in the -C linesearch algorithm based on the current lambda value. It is -C called by DLINSK and DLINSD. Based on the ICOPT and ID values, -C the corresponding entry in Y or YPRIME is updated. -C -C In addition to the parameters described in the calling programs, -C the parameters represent -C -C P -- Array of length NEQ that contains the current -C approximate Newton step. -C RL -- Scalar containing the current lambda value. -C YNEW -- Array of length NEQ containing the updated Y vector. -C YPNEW -- Array of length NEQ containing the updated YPRIME -C vector. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED (NONE) -C -C***END PROLOGUE DYYPNW -C -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION Y(*), YPRIME(*), YNEW(*), YPNEW(*), ID(*), P(*) -C - IF (ICOPT .EQ. 1) THEN - DO 10 I=1,NEQ - IF(ID(I) .LT. 0) THEN - YNEW(I) = Y(I) - RL*P(I) - YPNEW(I) = YPRIME(I) - ELSE - YNEW(I) = Y(I) - YPNEW(I) = YPRIME(I) - RL*CJ*P(I) - ENDIF - 10 CONTINUE - ELSE - DO 20 I = 1,NEQ - YNEW(I) = Y(I) - RL*P(I) - YPNEW(I) = YPRIME(I) - 20 CONTINUE - ENDIF - RETURN -C----------------------- END OF SUBROUTINE DYYPNW ---------------------- - END - SUBROUTINE DDSTP(X,Y,YPRIME,NEQ,RES,JAC,PSOL,H,WT,VT, - * JSTART,IDID,RPAR,IPAR,PHI,SAVR,DELTA,E,WM,IWM, - * ALPHA,BETA,GAMMA,PSI,SIGMA,CJ,CJOLD,HOLD,S,HMIN,UROUND, - * EPLI,SQRTN,RSQRTN,EPCON,IPHASE,JCALC,JFLG,K,KOLD,NS,NONNEG, - * NTYPE,NLS) -C -C***BEGIN PROLOGUE DDSTP -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940909 (YYMMDD) (Reset PSI(1), PHI(*,2) at 690) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DDSTP solves a system of differential/algebraic equations of -C the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H). -C -C The methods used are modified divided difference, fixed leading -C coefficient forms of backward differentiation formulas. -C The code adjusts the stepsize and order to control the local error -C per step. -C -C -C The parameters represent -C X -- Independent variable. -C Y -- Solution vector at X. -C YPRIME -- Derivative of solution vector -C after successful step. -C NEQ -- Number of equations to be integrated. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JAC -- External user-supplied routine to update -C Jacobian or preconditioner information in the -C nonlinear solver. See JAC description in DDASPK -C prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C (This is optional). See PSOL in DDASPK prologue. -C H -- Appropriate step size for next step. -C Normally determined by the code. -C WT -- Vector of weights for error criterion used in Newton test. -C VT -- Masked vector of weights used in error test. -C JSTART -- Integer variable set 0 for -C first step, 1 otherwise. -C IDID -- Completion code returned from the nonlinear solver. -C See IDID description in DDASPK prologue. -C RPAR,IPAR -- Real and integer parameter arrays that -C are used for communication between the -C calling program and external user routines. -C They are not altered by DNSK -C PHI -- Array of divided differences used by -C DDSTP. The length is NEQ*(K+1), where -C K is the maximum order. -C SAVR -- Work vector for DDSTP of length NEQ. -C DELTA,E -- Work vectors for DDSTP of length NEQ. -C WM,IWM -- Real and integer arrays storing -C information required by the linear solver. -C -C The other parameters are information -C which is needed internally by DDSTP to -C continue from step to step. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C NLS, DDWNRM, DDATRP -C -C***END PROLOGUE DDSTP -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),VT(*) - DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) - DIMENSION WM(*),IWM(*) - DIMENSION PSI(*),ALPHA(*),BETA(*),GAMMA(*),SIGMA(*) - DIMENSION RPAR(*),IPAR(*) - EXTERNAL RES, JAC, PSOL, NLS -C - PARAMETER (LMXORD=3) - PARAMETER (LNST=11, LETF=14, LCFN=15) -C -C -C----------------------------------------------------------------------- -C BLOCK 1. -C Initialize. On the first call, set -C the order to 1 and initialize -C other variables. -C----------------------------------------------------------------------- -C -C Initializations for all calls -C - XOLD=X - NCF=0 - NEF=0 - IF(JSTART .NE. 0) GO TO 120 -C -C If this is the first step, perform -C other initializations -C - K=1 - KOLD=0 - HOLD=0.0D0 - PSI(1)=H - CJ = 1.D0/H - IPHASE = 0 - NS=0 -120 CONTINUE -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 2 -C Compute coefficients of formulas for -C this step. -C----------------------------------------------------------------------- -200 CONTINUE - KP1=K+1 - KP2=K+2 - KM1=K-1 - IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 - NS=MIN0(NS+1,KOLD+2) - NSP1=NS+1 - IF(KP1 .LT. NS)GO TO 230 -C - BETA(1)=1.0D0 - ALPHA(1)=1.0D0 - TEMP1=H - GAMMA(1)=0.0D0 - SIGMA(1)=1.0D0 - DO 210 I=2,KP1 - 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 -210 CONTINUE - PSI(KP1)=TEMP1 -230 CONTINUE -C -C Compute ALPHAS, ALPHA0 -C - ALPHAS = 0.0D0 - ALPHA0 = 0.0D0 - DO 240 I = 1,K - ALPHAS = ALPHAS - 1.0D0/I - ALPHA0 = ALPHA0 - ALPHA(I) -240 CONTINUE -C -C Compute leading coefficient CJ -C - CJLAST = CJ - CJ = -ALPHAS/H -C -C Compute variable stepsize error coefficient CK -C - CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) - CK = MAX(CK,ALPHA(KP1)) -C -C Change PHI to PHI STAR -C - IF(KP1 .LT. NSP1) GO TO 280 - DO 270 J=NSP1,KP1 - DO 260 I=1,NEQ -260 PHI(I,J)=BETA(J)*PHI(I,J) -270 CONTINUE -280 CONTINUE -C -C Update time -C - X=X+H -C -C Initialize IDID to 1 -C - IDID = 1 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 3 -C Call the nonlinear system solver to obtain the solution and -C derivative. -C----------------------------------------------------------------------- -C - CALL NLS(X,Y,YPRIME,NEQ, - * RES,JAC,PSOL,H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA, - * SAVR,DELTA,E,WM,IWM,CJ,CJOLD,CJLAST,S, - * UROUND,EPLI,SQRTN,RSQRTN,EPCON,JCALC,JFLG,KP1, - * NONNEG,NTYPE,IERNLS) -C - IF(IERNLS .NE. 0)GO TO 600 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 4 -C Estimate the errors at orders K,K-1,K-2 -C as if constant stepsize was used. Estimate -C the local error at order K and test -C whether the current step is successful. -C----------------------------------------------------------------------- -C -C Estimate errors at orders K,K-1,K-2 -C - ENORM = DDWNRM(NEQ,E,VT,RPAR,IPAR) - ERK = SIGMA(K+1)*ENORM - TERK = (K+1)*ERK - EST = ERK - KNEW=K - IF(K .EQ. 1)GO TO 430 - DO 405 I = 1,NEQ -405 DELTA(I) = PHI(I,KP1) + E(I) - ERKM1=SIGMA(K)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) - TERKM1 = K*ERKM1 - IF(K .GT. 2)GO TO 410 - IF(TERKM1 .LE. 0.5*TERK)GO TO 420 - GO TO 430 -410 CONTINUE - DO 415 I = 1,NEQ -415 DELTA(I) = PHI(I,K) + DELTA(I) - ERKM2=SIGMA(K-1)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) - TERKM2 = (K-1)*ERKM2 - IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 -C -C Lower the order -C -420 CONTINUE - KNEW=K-1 - EST = ERKM1 -C -C -C Calculate the local error for the current step -C to see if the step was successful -C -430 CONTINUE - ERR = CK * ENORM - IF(ERR .GT. 1.0D0)GO TO 600 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 5 -C The step is successful. Determine -C the best order and stepsize for -C the next step. Update the differences -C for the next step. -C----------------------------------------------------------------------- - IDID=1 - IWM(LNST)=IWM(LNST)+1 - KDIFF=K-KOLD - KOLD=K - HOLD=H -C -C -C Estimate the error at order K+1 unless -C already decided to lower order, or -C already using maximum order, or -C stepsize not constant, or -C order raised in previous step -C - IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 - IF(IPHASE .EQ. 0)GO TO 545 - IF(KNEW.EQ.KM1)GO TO 540 - IF(K.EQ.IWM(LMXORD)) GO TO 550 - IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 - DO 510 I=1,NEQ -510 DELTA(I)=E(I)-PHI(I,KP2) - ERKP1 = (1.0D0/(K+2))*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) - TERKP1 = (K+2)*ERKP1 - IF(K.GT.1)GO TO 520 - IF(TERKP1.GE.0.5D0*TERK)GO TO 550 - GO TO 530 -520 IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540 - IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 -C -C Raise order -C -530 K=KP1 - EST = ERKP1 - GO TO 550 -C -C Lower order -C -540 K=KM1 - EST = ERKM1 - GO TO 550 -C -C If IPHASE = 0, increase order by one and multiply stepsize by -C factor two -C -545 K = KP1 - HNEW = H*2.0D0 - H = HNEW - GO TO 575 -C -C -C Determine the appropriate stepsize for -C the next step. -C -550 HNEW=H - TEMP2=K+1 - R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) - IF(R .LT. 2.0D0) GO TO 555 - HNEW = 2.0D0*H - GO TO 560 -555 IF(R .GT. 1.0D0) GO TO 560 - R = MAX(0.5D0,MIN(0.9D0,R)) - HNEW = H*R -560 H=HNEW -C -C -C Update differences for next step -C -575 CONTINUE - IF(KOLD.EQ.IWM(LMXORD))GO TO 585 - DO 580 I=1,NEQ -580 PHI(I,KP2)=E(I) -585 CONTINUE - DO 590 I=1,NEQ -590 PHI(I,KP1)=PHI(I,KP1)+E(I) - DO 595 J1=2,KP1 - J=KP1-J1+1 - DO 595 I=1,NEQ -595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) - JSTART = 1 - RETURN -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 6 -C The step is unsuccessful. Restore X,PSI,PHI -C Determine appropriate stepsize for -C continuing the integration, or exit with -C an error flag if there have been many -C failures. -C----------------------------------------------------------------------- -600 IPHASE = 1 -C -C Restore X,PHI,PSI -C - X=XOLD - IF(KP1.LT.NSP1)GO TO 630 - DO 620 J=NSP1,KP1 - TEMP1=1.0D0/BETA(J) - DO 610 I=1,NEQ -610 PHI(I,J)=TEMP1*PHI(I,J) -620 CONTINUE -630 CONTINUE - DO 640 I=2,KP1 -640 PSI(I-1)=PSI(I)-H -C -C -C Test whether failure is due to nonlinear solver -C or error test -C - IF(IERNLS .EQ. 0)GO TO 660 - IWM(LCFN)=IWM(LCFN)+1 -C -C -C The nonlinear solver failed to converge. -C Determine the cause of the failure and take appropriate action. -C If IERNLS .LT. 0, then return. Otherwise, reduce the stepsize -C and try again, unless too many failures have occurred. -C - IF (IERNLS .LT. 0) GO TO 675 - NCF = NCF + 1 - R = 0.25D0 - H = H*R - IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 - IF (IDID .EQ. 1) IDID = -7 - IF (NEF .GE. 3) IDID = -9 - GO TO 675 -C -C -C The nonlinear solver converged, and the cause -C of the failure was the error estimate -C exceeding the tolerance. -C -660 NEF=NEF+1 - IWM(LETF)=IWM(LETF)+1 - IF (NEF .GT. 1) GO TO 665 -C -C On first error test failure, keep current order or lower -C order by one. Compute new stepsize based on differences -C of the solution. -C - K = KNEW - TEMP2 = K + 1 - R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) - R = MAX(0.25D0,MIN(0.9D0,R)) - H = H*R - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C On second error test failure, use the current order or -C decrease order by one. Reduce the stepsize by a factor of -C one quarter. -C -665 IF (NEF .GT. 2) GO TO 670 - K = KNEW - R = 0.25D0 - H = R*H - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C On third and subsequent error test failures, set the order to -C one, and reduce the stepsize by a factor of one quarter. -C -670 K = 1 - R = 0.25D0 - H = R*H - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C -C -C -C For all crashes, restore Y to its last value, -C interpolate to find YPRIME at last X, and return. -C -C Before returning, verify that the user has not set -C IDID to a nonnegative value. If the user has set IDID -C to a nonnegative value, then reset IDID to be -7, indicating -C a failure in the nonlinear system solver. -C -675 CONTINUE - CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) - JSTART = 1 - IF (IDID .GE. 0) IDID = -7 - RETURN -C -C -C Go back and try this step again. -C If this is the first step, reset PSI(1) and rescale PHI(*,2). -C -690 IF (KOLD .EQ. 0) THEN - PSI(1) = H - DO 695 I = 1,NEQ -695 PHI(I,2) = R*PHI(I,2) - ENDIF - GO TO 200 -C -C------END OF SUBROUTINE DDSTP------------------------------------------ - END - SUBROUTINE DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) -C -C***BEGIN PROLOGUE DCNSTR -C***DATE WRITTEN 950808 (YYMMDD) -C***REVISION DATE 950814 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This subroutine checks for constraint violations in the proposed -C new approximate solution YNEW. -C If a constraint violation occurs, then a new step length, TAU, -C is calculated, and this value is to be given to the linesearch routine -C to calculate a new approximate solution YNEW. -C -C On entry: -C -C NEQ -- size of the nonlinear system, and the length of arrays -C Y, YNEW and ICNSTR. -C -C Y -- real array containing the current approximate y. -C -C YNEW -- real array containing the new approximate y. -C -C ICNSTR -- INTEGER array of length NEQ containing flags indicating -C which entries in YNEW are to be constrained. -C if ICNSTR(I) = 2, then YNEW(I) must be .GT. 0, -C if ICNSTR(I) = 1, then YNEW(I) must be .GE. 0, -C if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while -C if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while -C if ICNSTR(I) = 0, then YNEW(I) is not constrained. -C -C RLX -- real scalar restricting update, if ICNSTR(I) = 2 or -2, -C to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I. -C -C TAU -- the current size of the step length for the linesearch. -C -C On return -C -C TAU -- the adjusted size of the step length if a constraint -C violation occurred (otherwise, it is unchanged). it is -C the step length to give to the linesearch routine. -C -C IRET -- output flag. -C IRET=0 means that YNEW satisfied all constraints. -C IRET=1 means that YNEW failed to satisfy all the -C constraints, and a new linesearch step -C must be computed. -C -C IVAR -- index of variable causing constraint to be violated. -C -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(NEQ), YNEW(NEQ), ICNSTR(NEQ) - SAVE FAC, FAC2, ZERO - DATA FAC /0.6D0/, FAC2 /0.9D0/, ZERO/0.0D0/ -C----------------------------------------------------------------------- -C Check constraints for proposed new step YNEW. If a constraint has -C been violated, then calculate a new step length, TAU, to be -C used in the linesearch routine. -C----------------------------------------------------------------------- - IRET = 0 - RDYMX = ZERO - IVAR = 0 - DO 100 I = 1,NEQ -C - IF (ICNSTR(I) .EQ. 2) THEN - RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) - IF (RDY .GT. RDYMX) THEN - RDYMX = RDY - IVAR = I - ENDIF - IF (YNEW(I) .LE. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ELSEIF (ICNSTR(I) .EQ. 1) THEN - IF (YNEW(I) .LT. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ELSEIF (ICNSTR(I) .EQ. -1) THEN - IF (YNEW(I) .GT. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ELSEIF (ICNSTR(I) .EQ. -2) THEN - RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) - IF (RDY .GT. RDYMX) THEN - RDYMX = RDY - IVAR = I - ENDIF - IF (YNEW(I) .GE. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ENDIF - 100 CONTINUE - - IF(RDYMX .GE. RLX) THEN - TAU = FAC2*TAU*RLX/RDYMX - IRET = 1 - ENDIF -C - RETURN -C----------------------- END OF SUBROUTINE DCNSTR ---------------------- - END - SUBROUTINE DCNST0 (NEQ, Y, ICNSTR, IRET) -C -C***BEGIN PROLOGUE DCNST0 -C***DATE WRITTEN 950808 (YYMMDD) -C***REVISION DATE 950808 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This subroutine checks for constraint violations in the initial -C approximate solution u. -C -C On entry -C -C NEQ -- size of the nonlinear system, and the length of arrays -C Y and ICNSTR. -C -C Y -- real array containing the initial approximate root. -C -C ICNSTR -- INTEGER array of length NEQ containing flags indicating -C which entries in Y are to be constrained. -C if ICNSTR(I) = 2, then Y(I) must be .GT. 0, -C if ICNSTR(I) = 1, then Y(I) must be .GE. 0, -C if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while -C if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while -C if ICNSTR(I) = 0, then Y(I) is not constrained. -C -C On return -C -C IRET -- output flag. -C IRET=0 means that u satisfied all constraints. -C IRET.NE.0 means that Y(IRET) failed to satisfy its -C constraint. -C -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(NEQ), ICNSTR(NEQ) - SAVE ZERO - DATA ZERO/0.D0/ -C----------------------------------------------------------------------- -C Check constraints for initial Y. If a constraint has been violated, -C set IRET = I to signal an error return to calling routine. -C----------------------------------------------------------------------- - IRET = 0 - DO 100 I = 1,NEQ - IF (ICNSTR(I) .EQ. 2) THEN - IF (Y(I) .LE. ZERO) THEN - IRET = I - RETURN - ENDIF - ELSEIF (ICNSTR(I) .EQ. 1) THEN - IF (Y(I) .LT. ZERO) THEN - IRET = I - RETURN - ENDIF - ELSEIF (ICNSTR(I) .EQ. -1) THEN - IF (Y(I) .GT. ZERO) THEN - IRET = I - RETURN - ENDIF - ELSEIF (ICNSTR(I) .EQ. -2) THEN - IF (Y(I) .GE. ZERO) THEN - IRET = I - RETURN - ENDIF - ENDIF - 100 CONTINUE - RETURN -C----------------------- END OF SUBROUTINE DCNST0 ---------------------- - END - SUBROUTINE DDAWTS(NEQ,IWT,RTOL,ATOL,Y,WT,RPAR,IPAR) -C -C***BEGIN PROLOGUE DDAWTS -C***REFER TO DDASPK -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***END PROLOGUE DDAWTS -C----------------------------------------------------------------------- -C This subroutine sets the error weight vector, -C WT, according to WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), -C I = 1 to NEQ. -C RTOL and ATOL are scalars if IWT = 0, -C and vectors if IWT = 1. -C----------------------------------------------------------------------- -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION RTOL(*),ATOL(*),Y(*),WT(*) - DIMENSION RPAR(*),IPAR(*) - RTOLI=RTOL(1) - ATOLI=ATOL(1) - DO 20 I=1,NEQ - IF (IWT .EQ.0) GO TO 10 - RTOLI=RTOL(I) - ATOLI=ATOL(I) -10 WT(I)=RTOLI*ABS(Y(I))+ATOLI -20 CONTINUE - RETURN -C -C------END OF SUBROUTINE DDAWTS----------------------------------------- - END - SUBROUTINE DINVWT(NEQ,WT,IER) -C -C***BEGIN PROLOGUE DINVWT -C***REFER TO DDASPK -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 950125 (YYMMDD) -C***END PROLOGUE DINVWT -C----------------------------------------------------------------------- -C This subroutine checks the error weight vector WT, of length NEQ, -C for components that are .le. 0, and if none are found, it -C inverts the WT(I) in place. This replaces division operations -C with multiplications in all norm evaluations. -C IER is returned as 0 if all WT(I) were found positive, -C and the first I with WT(I) .le. 0.0 otherwise. -C----------------------------------------------------------------------- -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION WT(*) -C - DO 10 I = 1,NEQ - IF (WT(I) .LE. 0.0D0) GO TO 30 - 10 CONTINUE - DO 20 I = 1,NEQ - 20 WT(I) = 1.0D0/WT(I) - IER = 0 - RETURN -C - 30 IER = I - RETURN -C -C------END OF SUBROUTINE DINVWT----------------------------------------- - END - SUBROUTINE DDATRP(X,XOUT,YOUT,YPOUT,NEQ,KOLD,PHI,PSI) -C -C***BEGIN PROLOGUE DDATRP -C***REFER TO DDASPK -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***END PROLOGUE DDATRP -C -C----------------------------------------------------------------------- -C The methods in subroutine DDSTP use polynomials -C to approximate the solution. DDATRP approximates the -C solution and its derivative at time XOUT by evaluating -C one of these polynomials, and its derivative, there. -C Information defining this polynomial is passed from -C DDSTP, so DDATRP cannot be used alone. -C -C The parameters are -C -C X The current time in the integration. -C XOUT The time at which the solution is desired. -C YOUT The interpolated approximation to Y at XOUT. -C (This is output.) -C YPOUT The interpolated approximation to YPRIME at XOUT. -C (This is output.) -C NEQ Number of equations. -C KOLD Order used on last successful step. -C PHI Array of scaled divided differences of Y. -C PSI Array of past stepsize history. -C----------------------------------------------------------------------- -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION YOUT(*),YPOUT(*) - DIMENSION PHI(NEQ,*),PSI(*) - KOLDP1=KOLD+1 - TEMP1=XOUT-X - DO 10 I=1,NEQ - YOUT(I)=PHI(I,1) -10 YPOUT(I)=0.0D0 - C=1.0D0 - D=0.0D0 - GAMMA=TEMP1/PSI(1) - DO 30 J=2,KOLDP1 - D=D*GAMMA+C/PSI(J-1) - C=C*GAMMA - GAMMA=(TEMP1+PSI(J-1))/PSI(J) - DO 20 I=1,NEQ - YOUT(I)=YOUT(I)+C*PHI(I,J) -20 YPOUT(I)=YPOUT(I)+D*PHI(I,J) -30 CONTINUE - RETURN -C -C------END OF SUBROUTINE DDATRP----------------------------------------- - END - DOUBLE PRECISION FUNCTION DDWNRM(NEQ,V,RWT,RPAR,IPAR) -C -C***BEGIN PROLOGUE DDWNRM -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***END PROLOGUE DDWNRM -C----------------------------------------------------------------------- -C This function routine computes the weighted -C root-mean-square norm of the vector of length -C NEQ contained in the array V, with reciprocal weights -C contained in the array RWT of length NEQ. -C DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2) -C----------------------------------------------------------------------- -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION V(*),RWT(*) - DIMENSION RPAR(*),IPAR(*) - DDWNRM = 0.0D0 - VMAX = 0.0D0 - DO 10 I = 1,NEQ - IF(ABS(V(I)*RWT(I)) .GT. VMAX) VMAX = ABS(V(I)*RWT(I)) -10 CONTINUE - IF(VMAX .LE. 0.0D0) GO TO 30 - SUM = 0.0D0 - DO 20 I = 1,NEQ -20 SUM = SUM + ((V(I)*RWT(I))/VMAX)**2 - DDWNRM = VMAX*SQRT(SUM/NEQ) -30 CONTINUE - RETURN -C -C------END OF FUNCTION DDWNRM------------------------------------------- - END - SUBROUTINE DDASID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACD,PDUM,H,TSCALE, - * WT,JSDUM,RPAR,IPAR,DUMSVR,DELTA,R,YIC,YPIC,DUMPWK,WM,IWM,CJ, - * UROUND,DUME,DUMS,DUMR,EPCON,RATEMX,STPTOL,JFDUM, - * ICNFLG,ICNSTR,IERNLS) -C -C***BEGIN PROLOGUE DDASID -C***REFER TO DDASPK -C***DATE WRITTEN 940701 (YYMMDD) -C***REVISION DATE 950808 (YYMMDD) -C***REVISION DATE 951110 Removed unreachable block 390. -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C -C DDASID solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in -C the initial conditions. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine to evaluate the -C residual. See RES description in DDASPK prologue. -C JACD -- External user-supplied routine to evaluate the -C Jacobian. See JAC description for the case -C INFO(12) = 0 in the DDASPK prologue. -C PDUM -- Dummy argument. -C H -- Scaling factor for this initial condition calc. -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C WT -- Vector of weights for error criterion. -C JSDUM -- Dummy argument. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C DUMSVR -- Dummy argument. -C DELTA -- Work vector for NLS of length NEQ. -C R -- Work vector for NLS of length NEQ. -C YIC,YPIC -- Work vectors for NLS, each of length NEQ. -C DUMPWK -- Dummy argument. -C WM,IWM -- Real and integer arrays storing matrix information -C such as the matrix of partial derivatives, -C permutation vector, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C UROUND -- Unit roundoff. -C DUME -- Dummy argument. -C DUMS -- Dummy argument. -C DUMR -- Dummy argument. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C JFDUM -- Dummy argument. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1,2 ==> recoverable error inside nonlinear solver. -C 1 => retry with current Y, YPRIME -C 2 => retry with original Y, YPRIME -C -1 ==> unrecoverable error in nonlinear solver. -C -C All variables with "DUM" in their names are dummy variables -C which are not used in this routine. -C -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DMATD, DNSID -C -C***END PROLOGUE DDASID -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) - DIMENSION DELTA(*),R(*),YIC(*),YPIC(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, JACD -C - PARAMETER (LNRE=12, LNJE=13, LMXNIT=32, LMXNJ=33) -C -C -C Perform initializations. -C - MXNIT = IWM(LMXNIT) - MXNJ = IWM(LMXNJ) - IERNLS = 0 - NJ = 0 -C -C Call RES to initialize DELTA. -C - IRES = 0 - IWM(LNRE) = IWM(LNRE) + 1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 370 -C -C Looping point for updating the Jacobian. -C -300 CONTINUE -C -C Initialize all error flags to zero. -C - IERJ = 0 - IRES = 0 - IERNEW = 0 -C -C Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME, -C where G(X,Y,YPRIME) = 0. -C - NJ = NJ + 1 - IWM(LNJE)=IWM(LNJE)+1 - CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,R, - * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) - IF (IRES .LT. 0 .OR. IERJ .NE. 0) GO TO 370 -C -C Call the nonlinear Newton solver for up to MXNIT iterations. -C - CALL DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR,DELTA,R, - * YIC,YPIC,WM,IWM,CJ,TSCALE,EPCON,RATEMX,MXNIT,STPTOL, - * ICNFLG,ICNSTR,IERNEW) -C - IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ) THEN -C -C MXNIT iterations were done, the convergence rate is < 1, -C and the number of Jacobian evaluations is less than MXNJ. -C Call RES, reevaluate the Jacobian, and try again. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 370 - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 - - RETURN -C -C -C Unsuccessful exits from nonlinear solver. -C Compute IERNLS accordingly. -C -370 IERNLS = 2 - IF (IRES .LE. -2) IERNLS = -1 - RETURN -C -380 IERNLS = MIN(IERNEW,2) - RETURN -C -C------END OF SUBROUTINE DDASID----------------------------------------- - END - SUBROUTINE DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR, - * DELTA,R,YIC,YPIC,WM,IWM,CJ,TSCALE,EPCON,RATEMX,MAXIT,STPTOL, - * ICNFLG,ICNSTR,IERNEW) -C -C***BEGIN PROLOGUE DNSID -C***REFER TO DDASPK -C***DATE WRITTEN 940701 (YYMMDD) -C***REVISION DATE 950713 (YYMMDD) -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSID solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME -C in the initial conditions. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine to evaluate the -C residual. See RES description in DDASPK prologue. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C DELTA -- Residual vector on entry, and work vector of -C length NEQ for DNSID. -C WM,IWM -- Real and integer arrays storing matrix information -C such as the matrix of partial derivatives, -C permutation vector, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C R -- Array of length NEQ used as workspace by the -C linesearch routine DLINSD. -C YIC,YPIC -- Work vectors for DLINSD, each of length NEQ. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C MAXIT -- Maximum allowed number of Newton iterations. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> failed to converge, but RATE .le. RATEMX. -C 2 ==> failed to converge, RATE .gt. RATEMX. -C 3 ==> other recoverable error (IRES = -1, or -C linesearch failed). -C -1 ==> unrecoverable error (IRES = -2). -C -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DSLVD, DDWNRM, DLINSD, DCOPY -C -C***END PROLOGUE DNSID -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),R(*) - DIMENSION ID(*),DELTA(*), YIC(*), YPIC(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - DIMENSION ICNSTR(*) - EXTERNAL RES -C - PARAMETER (LNNI=19, LLSOFF=35) -C -C -C Initializations. M is the Newton iteration counter. -C - LSOFF = IWM(LLSOFF) - M = 0 - RATE = 1.0D0 - RLX = 0.4D0 -C -C Compute a new step vector DELTA by back-substitution. -C - CALL DSLVD (NEQ, DELTA, WM, IWM) -C -C Get norm of DELTA. Return now if norm(DELTA) .le. EPCON. -C - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - FNRM = DELNRM - IF (TSCALE .GT. 0.0D0) FNRM = FNRM*TSCALE*ABS(CJ) - IF (FNRM .LE. EPCON) RETURN -C -C Newton iteration loop. -C - 300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C Call linesearch routine for global strategy and set RATE -C - OLDFNM = FNRM -C - CALL DLINSD (NEQ, Y, X, YPRIME, CJ, TSCALE, DELTA, DELNRM, WT, - * LSOFF, STPTOL, IRET, RES, IRES, WM, IWM, FNRM, ICOPT, - * ID, R, YIC, YPIC, ICNFLG, ICNSTR, RLX, RPAR, IPAR) -C - RATE = FNRM/OLDFNM -C -C Check for error condition from linesearch. - IF (IRET .NE. 0) GO TO 390 -C -C Test for convergence of the iteration, and return or loop. -C - IF (FNRM .LE. EPCON) RETURN -C -C The iteration has not yet converged. Update M. -C Test whether the maximum number of iterations have been tried. -C - M = M + 1 - IF (M .GE. MAXIT) GO TO 380 -C -C Copy the residual to DELTA and its norm to DELNRM, and loop for -C another iteration. -C - CALL DCOPY (NEQ, R, 1, DELTA, 1) - DELNRM = FNRM - GO TO 300 -C -C The maximum number of iterations was done. Set IERNEW and return. -C - 380 IF (RATE .LE. RATEMX) THEN - IERNEW = 1 - ELSE - IERNEW = 2 - ENDIF - RETURN -C - 390 IF (IRES .LE. -2) THEN - IERNEW = -1 - ELSE - IERNEW = 3 - ENDIF - RETURN -C -C -C------END OF SUBROUTINE DNSID------------------------------------------ - END - SUBROUTINE DLINSD (NEQ, Y, T, YPRIME, CJ, TSCALE, P, PNRM, WT, - * LSOFF, STPTOL, IRET, RES, IRES, WM, IWM, - * FNRM, ICOPT, ID, R, YNEW, YPNEW, ICNFLG, - * ICNSTR, RLX, RPAR, IPAR) -C -C***BEGIN PROLOGUE DLINSD -C***REFER TO DNSID -C***DATE WRITTEN 941025 (YYMMDD) -C***REVISION DATE 941215 (YYMMDD) -C***REVISION DATE 960129 Moved line RL = ONE to top block. -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME) -C pair (YNEW,YPNEW) such that -C -C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) , -C -C where 0 < RL <= 1. Here, f(y,y') is defined as -C -C f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 , -C -C where norm() is the weighted RMS vector norm, G is the DAE -C system residual function, and J is the system iteration matrix -C (Jacobian). -C -C In addition to the parameters defined elsewhere, we have -C -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C P -- Approximate Newton step used in backtracking. -C PNRM -- Weighted RMS norm of P. -C LSOFF -- Flag showing whether the linesearch algorithm is -C to be invoked. 0 means do the linesearch, and -C 1 means turn off linesearch. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint violations -C in the proposed new approximate solution will be -C checked for, and the maximum step length will be -C adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C RLX -- Real scalar restricting update size in DCNSTR. -C YNEW -- Array of length NEQ used to hold the new Y in -C performing the linesearch. -C YPNEW -- Array of length NEQ used to hold the new YPRIME in -C performing the linesearch. -C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). -C YPRIME -- Array of length NEQ containing the new YPRIME -C (i.e.,=YPNEW). -C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the -C current (Y,YPRIME) on input and output. -C R -- Work array of length NEQ, containing the scaled -C residual (J-inverse)*G(t,y,y') on return. -C IRET -- Return flag. -C IRET=0 means that a satisfactory (Y,YPRIME) was found. -C IRET=1 means that the routine failed to find a new -C (Y,YPRIME) that was sufficiently distinct from -C the current (Y,YPRIME) pair. -C IRET=2 means IRES .ne. 0 from RES. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DFNRMD, DYYPNW, DCNSTR, DCOPY, XERRWD -C -C***END PROLOGUE DLINSD -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - EXTERNAL RES - DIMENSION Y(*), YPRIME(*), WT(*), R(*), ID(*) - DIMENSION WM(*), IWM(*) - DIMENSION YNEW(*), YPNEW(*), P(*), ICNSTR(*) - DIMENSION RPAR(*), IPAR(*) - CHARACTER MSG*80 -C - PARAMETER (LNRE=12, LKPRIN=31) -C - SAVE ALPHA, ONE, TWO - DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ -C - KPRIN=IWM(LKPRIN) -C - F1NRM = (FNRM*FNRM)/TWO - RATIO = ONE - IF (KPRIN .GE. 2) THEN - MSG = '------ IN ROUTINE DLINSD-- PNRM = (R1)' - CALL XERRWD(MSG, 38, 901, 0, 0, 0, 0, 1, PNRM, 0.0D0) - ENDIF - TAU = PNRM - RL = ONE -C----------------------------------------------------------------------- -C Check for violations of the constraints, if any are imposed. -C If any violations are found, the step vector P is rescaled, and the -C constraint check is repeated, until no violations are found. -C----------------------------------------------------------------------- - IF (ICNFLG .NE. 0) THEN - 10 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) - IF (IRET .EQ. 1) THEN - RATIO1 = TAU/PNRM - RATIO = RATIO*RATIO1 - DO 20 I = 1,NEQ - 20 P(I) = P(I)*RATIO1 - PNRM = TAU - IF (KPRIN .GE. 2) THEN - MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)' - CALL XERRWD(MSG, 50, 902, 0, 1, IVAR, 0, 1, PNRM, 0.0D0) - ENDIF - IF (PNRM .LE. STPTOL) THEN - IRET = 1 - RETURN - ENDIF - GO TO 10 - ENDIF - ENDIF -C - SLPI = (-TWO*F1NRM)*RATIO - RLMIN = STPTOL/PNRM - IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN - MSG = '------ MIN. LAMBDA = (R1)' - CALL XERRWD(MSG, 25, 903, 0, 0, 0, 0, 1, RLMIN, 0.0D0) - ENDIF -C----------------------------------------------------------------------- -C Begin iteration to find RL value satisfying alpha-condition. -C If RL becomes less than RLMIN, then terminate with IRET = 1. -C----------------------------------------------------------------------- - 100 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DFNRMD (NEQ, YNEW, T, YPNEW, R, CJ, TSCALE, WT, RES, IRES, - * FNRMP, WM, IWM, RPAR, IPAR) - IWM(LNRE) = IWM(LNRE) + 1 - IF (IRES .NE. 0) THEN - IRET = 2 - RETURN - ENDIF - IF (LSOFF .EQ. 1) GO TO 150 -C - F1NRMP = FNRMP*FNRMP/TWO - IF (KPRIN .GE. 2) THEN - MSG = '------ LAMBDA = (R1)' - CALL XERRWD(MSG, 20, 904, 0, 0, 0, 0, 1, RL, 0.0D0) - MSG = '------ NORM(F1) = (R1), NORM(F1NEW) = (R2)' - CALL XERRWD(MSG, 43, 905, 0, 0, 0, 0, 2, F1NRM, F1NRMP) - ENDIF - IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 -C----------------------------------------------------------------------- -C Alpha-condition is satisfied, or linesearch is turned off. -C Copy YNEW,YPNEW to Y,YPRIME and return. -C----------------------------------------------------------------------- - 150 IRET = 0 - CALL DCOPY (NEQ, YNEW, 1, Y, 1) - CALL DCOPY (NEQ, YPNEW, 1, YPRIME, 1) - FNRM = FNRMP - IF (KPRIN .GE. 1) THEN - MSG = '------ LEAVING ROUTINE DLINSD, FNRM = (R1)' - CALL XERRWD(MSG, 42, 906, 0, 0, 0, 0, 1, FNRM, 0.0D0) - ENDIF - RETURN -C----------------------------------------------------------------------- -C Alpha-condition not satisfied. Perform backtrack to compute new RL -C value. If no satisfactory YNEW,YPNEW can be found sufficiently -C distinct from Y,YPRIME, then return IRET = 1. -C----------------------------------------------------------------------- - 200 CONTINUE - IF (RL .LT. RLMIN) THEN - IRET = 1 - RETURN - ENDIF -C - RL = RL/TWO - GO TO 100 -C -C----------------------- END OF SUBROUTINE DLINSD ---------------------- - END - SUBROUTINE DFNRMD (NEQ, Y, T, YPRIME, R, CJ, TSCALE, WT, - * RES, IRES, FNORM, WM, IWM, RPAR, IPAR) -C -C***BEGIN PROLOGUE DFNRMD -C***REFER TO DLINSD -C***DATE WRITTEN 941025 (YYMMDD) -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DFNRMD calculates the scaled preconditioned norm of the nonlinear -C function used in the nonlinear iteration for obtaining consistent -C initial conditions. Specifically, DFNRMD calculates the weighted -C root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME), -C where J is the Jacobian matrix. -C -C In addition to the parameters described in the calling program -C DLINSD, the parameters represent -C -C R -- Array of length NEQ that contains -C (J-inverse)*G(T,Y,YPRIME) on return. -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C FNORM -- Scalar containing the weighted norm of R on return. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DSLVD, DDWNRM -C -C***END PROLOGUE DFNRMD -C -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL RES - DIMENSION Y(*), YPRIME(*), WT(*), R(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) -C----------------------------------------------------------------------- -C Call RES routine. -C----------------------------------------------------------------------- - IRES = 0 - CALL RES(T,Y,YPRIME,CJ,R,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN -C----------------------------------------------------------------------- -C Apply inverse of Jacobian to vector R. -C----------------------------------------------------------------------- - CALL DSLVD(NEQ,R,WM,IWM) -C----------------------------------------------------------------------- -C Calculate norm of R. -C----------------------------------------------------------------------- - FNORM = DDWNRM(NEQ,R,WT,RPAR,IPAR) - IF (TSCALE .GT. 0.0D0) FNORM = FNORM*TSCALE*ABS(CJ) -C - RETURN -C----------------------- END OF SUBROUTINE DFNRMD ---------------------- - END - SUBROUTINE DNEDD(X,Y,YPRIME,NEQ,RES,JACD,PDUM,H,WT, - * JSTART,IDID,RPAR,IPAR,PHI,GAMMA,DUMSVR,DELTA,E, - * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,DUME,DUMS,DUMR, - * EPCON,JCALC,JFDUM,KP1,NONNEG,NTYPE,IERNLS) -C -C***BEGIN PROLOGUE DNEDD -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNEDD solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JACD -- External user-supplied routine to evaluate the -C Jacobian. See JAC description for the case -C INFO(12) = 0 in the DDASPK prologue. -C PDUM -- Dummy argument. -C H -- Appropriate step size for next step. -C WT -- Vector of weights for error criterion. -C JSTART -- Indicates first call to this routine. -C If JSTART = 0, then this is the first call, -C otherwise it is not. -C IDID -- Completion flag, output by DNEDD. -C See IDID description in DDASPK prologue. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C PHI -- Array of divided differences used by -C DNEDD. The length is NEQ*(K+1),where -C K is the maximum order. -C GAMMA -- Array used to predict Y and YPRIME. The length -C is MAXORD+1 where MAXORD is the maximum order. -C DUMSVR -- Dummy argument. -C DELTA -- Work vector for NLS of length NEQ. -C E -- Error accumulation vector for NLS of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Parameter always proportional to 1/H. -C CJOLD -- Saves the value of CJ as of the last call to DMATD. -C Accounts for changes in CJ needed to -C decide whether to call DMATD. -C CJLAST -- Previous value of CJ. -C S -- A scalar determined by the approximate rate -C of convergence of the Newton iteration and used -C in the convergence test for the Newton iteration. -C -C If RATE is defined to be an estimate of the -C rate of convergence of the Newton iteration, -C then S = RATE/(1.D0-RATE). -C -C The closer RATE is to 0., the faster the Newton -C iteration is converging; the closer RATE is to 1., -C the slower the Newton iteration is converging. -C -C On the first Newton iteration with an up-dated -C preconditioner S = 100.D0, Thus the initial -C RATE of convergence is approximately 1. -C -C S is preserved from call to call so that the rate -C estimate from a previous step can be applied to -C the current step. -C UROUND -- Unit roundoff. -C DUME -- Dummy argument. -C DUMS -- Dummy argument. -C DUMR -- Dummy argument. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C JCALC -- Flag used to determine when to update -C the Jacobian matrix. In general: -C -C JCALC = -1 ==> Call the DMATD routine to update -C the Jacobian matrix. -C JCALC = 0 ==> Jacobian matrix is up-to-date. -C JCALC = 1 ==> Jacobian matrix is out-dated, -C but DMATD will not be called unless -C JCALC is set to -1. -C JFDUM -- Dummy argument. -C KP1 -- The current order(K) + 1; updated across calls. -C NONNEG -- Flag to determine nonnegativity constraints. -C NTYPE -- Identification code for the NLS routine. -C 0 ==> modified Newton; direct solver. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1 ==> recoverable error inside nonlinear solver. -C -1 ==> unrecoverable error inside nonlinear solver. -C -C All variables with "DUM" in their names are dummy variables -C which are not used in this routine. -C -C Following is a list and description of local variables which -C may not have an obvious usage. They are listed in roughly the -C order they occur in this subroutine. -C -C The following group of variables are passed as arguments to -C the Newton iteration solver. They are explained in greater detail -C in DNSD: -C TOLNEW, MULDEL, MAXIT, IERNEW -C -C IERTYP -- Flag which tells whether this subroutine is correct. -C 0 ==> correct subroutine. -C 1 ==> incorrect subroutine. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DDWNRM, RES, DMATD, DNSD -C -C***END PROLOGUE DNEDD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*) - DIMENSION DELTA(*),E(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - DIMENSION PHI(NEQ,*),GAMMA(*) - EXTERNAL RES, JACD -C - PARAMETER (LNRE=12, LNJE=13) -C - SAVE MULDEL, MAXIT, XRATE - DATA MULDEL/1/, MAXIT/4/, XRATE/0.25D0/ -C -C Verify that this is the correct subroutine. -C - IERTYP = 0 - IF (NTYPE .NE. 0) THEN - IERTYP = 1 - GO TO 380 - ENDIF -C -C If this is the first step, perform initializations. -C - IF (JSTART .EQ. 0) THEN - CJOLD = CJ - JCALC = -1 - ENDIF -C -C Perform all other initializations. -C - IERNLS = 0 -C -C Decide whether new Jacobian is needed. -C - TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) - TEMP2 = 1.0D0/TEMP1 - IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 - IF (CJ .NE. CJLAST) S = 100.D0 -C -C----------------------------------------------------------------------- -C Entry point for updating the Jacobian with current -C stepsize. -C----------------------------------------------------------------------- -300 CONTINUE -C -C Initialize all error flags to zero. -C - IERJ = 0 - IRES = 0 - IERNEW = 0 -C -C Predict the solution and derivative and compute the tolerance -C for the Newton iteration. -C - DO 310 I=1,NEQ - Y(I)=PHI(I,1) -310 YPRIME(I)=0.0D0 - DO 330 J=2,KP1 - DO 320 I=1,NEQ - Y(I)=Y(I)+PHI(I,J) -320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) -330 CONTINUE - PNORM = DDWNRM (NEQ,Y,WT,RPAR,IPAR) - TOLNEW = 100.D0*UROUND*PNORM -C -C Call RES to initialize DELTA. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 -C -C If indicated, reevaluate the iteration matrix -C J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). -C Set JCALC to 0 as an indicator that this has been done. -C - IF(JCALC .EQ. -1) THEN - IWM(LNJE)=IWM(LNJE)+1 - JCALC=0 - CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,E,WM,IWM, - * RES,IRES,UROUND,JACD,RPAR,IPAR) - CJOLD=CJ - S = 100.D0 - IF (IRES .LT. 0) GO TO 380 - IF(IERJ .NE. 0)GO TO 380 - ENDIF -C -C Call the nonlinear Newton solver. -C - TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) - CALL DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR,DUMSVR, - * DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON,S,TEMP1, - * TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) -C - IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN -C -C The Newton iteration had a recoverable failure with an old -C iteration matrix. Retry the step with a new iteration matrix. -C - JCALC = -1 - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 -C -C The Newton iteration has converged. If nonnegativity of -C solution is required, set the solution nonnegative, if the -C perturbation to do it is small enough. If the change is too -C large, then consider the corrector iteration to have failed. -C -375 IF(NONNEG .EQ. 0) GO TO 390 - DO 377 I = 1,NEQ -377 DELTA(I) = MIN(Y(I),0.0D0) - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF(DELNRM .GT. EPCON) GO TO 380 - DO 378 I = 1,NEQ -378 E(I) = E(I) - DELTA(I) - GO TO 390 -C -C -C Exits from nonlinear solver. -C No convergence with current iteration -C matrix, or singular iteration matrix. -C Compute IERNLS and IDID accordingly. -C -380 CONTINUE - IF (IRES .LE. -2 .OR. IERTYP .NE. 0) THEN - IERNLS = -1 - IF (IRES .LE. -2) IDID = -11 - IF (IERTYP .NE. 0) IDID = -15 - ELSE - IERNLS = 1 - IF (IRES .LT. 0) IDID = -10 - IF (IERJ .NE. 0) IDID = -8 - ENDIF -C -390 JCALC = 1 - RETURN -C -C------END OF SUBROUTINE DNEDD------------------------------------------ - END - SUBROUTINE DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR, - * DUMSVR,DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON, - * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) -C -C***BEGIN PROLOGUE DNSD -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 950126 (YYMMDD) -C***REVISION DATE 000711 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSD solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C PDUM -- Dummy argument. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C DUMSVR -- Dummy argument. -C DELTA -- Work vector for DNSD of length NEQ. -C E -- Error accumulation vector for DNSD of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Parameter always proportional to 1/H (step size). -C DUMS -- Dummy argument. -C DUMR -- Dummy argument. -C DUME -- Dummy argument. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C S -- Used for error convergence tests. -C In the Newton iteration: S = RATE/(1 - RATE), -C where RATE is the estimated rate of convergence -C of the Newton iteration. -C The calling routine passes the initial value -C of S to the Newton iteration. -C CONFAC -- A residual scale factor to improve convergence. -C TOLNEW -- Tolerance on the norm of Newton correction in -C alternative Newton convergence test. -C MULDEL -- A flag indicating whether or not to multiply -C DELTA by CONFAC. -C 0 ==> do not scale DELTA by CONFAC. -C 1 ==> scale DELTA by CONFAC. -C MAXIT -- Maximum allowed number of Newton iterations. -C IRES -- Error flag returned from RES. See RES description -C in DDASPK prologue. If IRES = -1, then IERNEW -C will be set to 1. -C If IRES < -1, then IERNEW will be set to -1. -C IDUM -- Dummy argument. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> recoverable error inside Newton iteration. -C -1 ==> unrecoverable error inside Newton iteration. -C -C All arguments with "DUM" in their names are dummy arguments -C which are not used in this routine. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DSLVD, DDWNRM, RES -C -C***END PROLOGUE DNSD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES -C - PARAMETER (LNRE=12, LNNI=19) -C -C Initialize Newton counter M and accumulation vector E. -C - M = 0 - DO 100 I=1,NEQ -100 E(I)=0.0D0 -C -C Corrector loop. -C -300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C If necessary, multiply residual by convergence factor. -C - IF (MULDEL .EQ. 1) THEN - DO 320 I = 1,NEQ -320 DELTA(I) = DELTA(I) * CONFAC - ENDIF -C -C Compute a new iterate (back-substitution). -C Store the correction in DELTA. -C - CALL DSLVD(NEQ,DELTA,WM,IWM) -C -C Update Y, E, and YPRIME. -C - DO 340 I=1,NEQ - Y(I)=Y(I)-DELTA(I) - E(I)=E(I)-DELTA(I) -340 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) -C -C Test for convergence of the iteration. -C - DELNRM=DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (M .EQ. 0) THEN - OLDNRM = DELNRM - IF (DELNRM .LE. TOLNEW) GO TO 370 - ELSE - RATE = (DELNRM/OLDNRM)**(1.0D0/M) - IF (RATE .GT. 0.9D0) GO TO 380 - S = RATE/(1.0D0 - RATE) - ENDIF - IF (S*DELNRM .LE. EPCON) GO TO 370 -C -C The corrector has not yet converged. -C Update M and test whether the -C maximum number of iterations have -C been tried. -C - M=M+1 - IF(M.GE.MAXIT) GO TO 380 -C -C Evaluate the residual, -C and go back to do another iteration. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 - GO TO 300 -C -C The iteration has converged. -C -370 RETURN -C -C The iteration has not converged. Set IERNEW appropriately. -C -380 CONTINUE - IF (IRES .LE. -2 ) THEN - IERNEW = -1 - ELSE - IERNEW = 1 - ENDIF - RETURN -C -C -C------END OF SUBROUTINE DNSD------------------------------------------- - END - SUBROUTINE DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IER,EWT,E, - * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) -C -C***BEGIN PROLOGUE DMATD -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940701 (YYMMDD) (new LIPVT) -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine computes the iteration matrix -C J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). -C Here J is computed by: -C the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or -C by numerical difference quotients if IWM(MTYPE) is 2 or 5. -C -C The parameters have the following meanings. -C X = Independent variable. -C Y = Array containing predicted values. -C YPRIME = Array containing predicted derivatives. -C DELTA = Residual evaluated at (X,Y,YPRIME). -C (Used only if IWM(MTYPE)=2 or 5). -C CJ = Scalar parameter defining iteration matrix. -C H = Current stepsize in integration. -C IER = Variable which is .NE. 0 if iteration matrix -C is singular, and 0 otherwise. -C EWT = Vector of error weights for computing norms. -C E = Work space (temporary) of length NEQ. -C WM = Real work space for matrices. On output -C it contains the LU decomposition -C of the iteration matrix. -C IWM = Integer work space containing -C matrix information. -C RES = External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C IRES = Flag which is equal to zero if no illegal values -C in RES, and less than zero otherwise. (If IRES -C is less than zero, the matrix was not completed). -C In this case (if IRES .LT. 0), then IER = 0. -C UROUND = The unit roundoff error of the machine being used. -C JACD = Name of the external user-supplied routine -C to evaluate the iteration matrix. (This routine -C is only used if IWM(MTYPE) is 1 or 4) -C See JAC description for the case INFO(12) = 0 -C in DDASPK prologue. -C RPAR,IPAR= Real and integer parameter arrays that -C are used for communication between the -C calling program and external user routines. -C They are not altered by DMATD. -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C JACD, RES, DGEFA, DGBFA -C -C***END PROLOGUE DMATD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),DELTA(*),EWT(*),E(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, JACD -C - PARAMETER (LML=1, LMU=2, LMTYPE=4, LNRE=12, LNPD=22, LLCIWP=30) -C - LIPVT = IWM(LLCIWP) - IER = 0 - MTYPE=IWM(LMTYPE) - GO TO (100,200,300,400,500),MTYPE -C -C -C Dense user-supplied matrix. -C -100 LENPD=IWM(LNPD) - DO 110 I=1,LENPD -110 WM(I)=0.0D0 - CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) - GO TO 230 -C -C -C Dense finite-difference-generated matrix. -C -200 IRES=0 - NROW=0 - SQUR = SQRT(UROUND) - DO 210 I=1,NEQ - DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)), - * ABS(1.D0/EWT(I))) - DEL=SIGN(DEL,H*YPRIME(I)) - DEL=(Y(I)+DEL)-Y(I) - YSAVE=Y(I) - YPSAVE=YPRIME(I) - Y(I)=Y(I)+DEL - YPRIME(I)=YPRIME(I)+CJ*DEL - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN - DELINV=1.0D0/DEL - DO 220 L=1,NEQ -220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV - NROW=NROW+NEQ - Y(I)=YSAVE - YPRIME(I)=YPSAVE -210 CONTINUE -C -C -C Do dense-matrix LU decomposition on J. -C -230 CALL DGEFA(WM,NEQ,NEQ,IWM(LIPVT),IER) - RETURN -C -C -C Dummy section for IWM(MTYPE)=3. -C -300 RETURN -C -C -C Banded user-supplied matrix. -C -400 LENPD=IWM(LNPD) - DO 410 I=1,LENPD -410 WM(I)=0.0D0 - CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) - MEBAND=2*IWM(LML)+IWM(LMU)+1 - GO TO 550 -C -C -C Banded finite-difference-generated matrix. -C -500 MBAND=IWM(LML)+IWM(LMU)+1 - MBA=MIN0(MBAND,NEQ) - MEBAND=MBAND+IWM(LML) - MEB1=MEBAND-1 - MSAVE=(NEQ/MBAND)+1 - ISAVE=IWM(LNPD) - IPSAVE=ISAVE+MSAVE - IRES=0 - SQUR=SQRT(UROUND) - DO 540 J=1,MBA - DO 510 N=J,NEQ,MBAND - K= (N-J)/MBAND + 1 - WM(ISAVE+K)=Y(N) - WM(IPSAVE+K)=YPRIME(N) - DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), - * ABS(1.D0/EWT(N))) - DEL=SIGN(DEL,H*YPRIME(N)) - DEL=(Y(N)+DEL)-Y(N) - Y(N)=Y(N)+DEL -510 YPRIME(N)=YPRIME(N)+CJ*DEL - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN - DO 530 N=J,NEQ,MBAND - K= (N-J)/MBAND + 1 - Y(N)=WM(ISAVE+K) - YPRIME(N)=WM(IPSAVE+K) - DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), - * ABS(1.D0/EWT(N))) - DEL=SIGN(DEL,H*YPRIME(N)) - DEL=(Y(N)+DEL)-Y(N) - DELINV=1.0D0/DEL - I1=MAX0(1,(N-IWM(LMU))) - I2=MIN0(NEQ,(N+IWM(LML))) - II=N*MEB1-IWM(LML) - DO 520 I=I1,I2 -520 WM(II+I)=(E(I)-DELTA(I))*DELINV -530 CONTINUE -540 CONTINUE -C -C -C Do LU decomposition of banded J. -C -550 CALL DGBFA (WM,MEBAND,NEQ,IWM(LML),IWM(LMU),IWM(LIPVT),IER) - RETURN -C -C------END OF SUBROUTINE DMATD------------------------------------------ - END - SUBROUTINE DSLVD(NEQ,DELTA,WM,IWM) -C -C***BEGIN PROLOGUE DSLVD -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940701 (YYMMDD) (new LIPVT) -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine manages the solution of the linear -C system arising in the Newton iteration. -C Real matrix information and real temporary storage -C is stored in the array WM. -C Integer matrix information is stored in the array IWM. -C For a dense matrix, the LINPACK routine DGESL is called. -C For a banded matrix, the LINPACK routine DGBSL is called. -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DGESL, DGBSL -C -C***END PROLOGUE DSLVD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DELTA(*),WM(*),IWM(*) -C - PARAMETER (LML=1, LMU=2, LMTYPE=4, LLCIWP=30) -C - LIPVT = IWM(LLCIWP) - MTYPE=IWM(LMTYPE) - GO TO(100,100,300,400,400),MTYPE -C -C Dense matrix. -C -100 CALL DGESL(WM,NEQ,NEQ,IWM(LIPVT),DELTA,0) - RETURN -C -C Dummy section for MTYPE=3. -C -300 CONTINUE - RETURN -C -C Banded matrix. -C -400 MEBAND=2*IWM(LML)+IWM(LMU)+1 - CALL DGBSL(WM,MEBAND,NEQ,IWM(LML), - * IWM(LMU),IWM(LIPVT),DELTA,0) - RETURN -C -C------END OF SUBROUTINE DSLVD------------------------------------------ - END - SUBROUTINE DDASIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACK,PSOL,H,TSCALE, - * WT,JSKIP,RPAR,IPAR,SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, - * EPLI,SQRTN,RSQRTN,EPCON,RATEMX,STPTOL,JFLG, - * ICNFLG,ICNSTR,IERNLS) -C -C***BEGIN PROLOGUE DDASIK -C***REFER TO DDASPK -C***DATE WRITTEN 941026 (YYMMDD) -C***REVISION DATE 950808 (YYMMDD) -C***REVISION DATE 951110 Removed unreachable block 390. -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C -C DDASIK solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in -C the initial conditions. -C -C An initial value for Y and initial guess for YPRIME are input. -C -C The method used is a Newton scheme with Krylov iteration and a -C linesearch algorithm. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector at x. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of equations to be integrated. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JACK -- External user-supplied routine to update -C the preconditioner. (This is optional). -C See JAC description for the case -C INFO(12) = 1 in the DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C (This is optional). See explanation inside DDASPK. -C H -- Scaling factor for this initial condition calc. -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C WT -- Vector of weights for error criterion. -C JSKIP -- input flag to signal if initial JAC call is to be -C skipped. 1 => skip the call, 0 => do not skip call. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C SAVR -- Work vector for DDASIK of length NEQ. -C DELTA -- Work vector for DDASIK of length NEQ. -C R -- Work vector for DDASIK of length NEQ. -C YIC,YPIC -- Work vectors for DDASIK, each of length NEQ. -C PWK -- Work vector for DDASIK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information for linear system -C solvers, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C UROUND -- Unit roundoff. Not used here. -C EPLI -- convergence test constant. -C See DDASPK prologue for more details. -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C JFLG -- Flag showing whether a Jacobian routine is supplied. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1,2 ==> recoverable error inside nonlinear solver. -C 1 => retry with current Y, YPRIME -C 2 => retry with original Y, YPRIME -C -1 ==> unrecoverable error in nonlinear solver. -C -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, JACK, DNSIK, DCOPY -C -C***END PROLOGUE DDASIK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) - DIMENSION SAVR(*),DELTA(*),R(*),YIC(*),YPIC(*),PWK(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, JACK, PSOL -C - PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) - PARAMETER (LMXNIT=32, LMXNJ=33) -C -C -C Perform initializations. -C - LWP = IWM(LLOCWP) - LIWP = IWM(LLCIWP) - MXNIT = IWM(LMXNIT) - MXNJ = IWM(LMXNJ) - IERNLS = 0 - NJ = 0 - EPLIN = EPLI*EPCON -C -C Call RES to initialize DELTA. -C - IRES = 0 - IWM(LNRE) = IWM(LNRE) + 1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 370 -C -C Looping point for updating the preconditioner. -C - 300 CONTINUE -C -C Initialize all error flags to zero. -C - IERPJ = 0 - IRES = 0 - IERNEW = 0 -C -C If a Jacobian routine was supplied, call it. -C - IF (JFLG .EQ. 1 .AND. JSKIP .EQ. 0) THEN - NJ = NJ + 1 - IWM(LNJE)=IWM(LNJE)+1 - CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, R, H, CJ, - * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) - IF (IRES .LT. 0 .OR. IERPJ .NE. 0) GO TO 370 - ENDIF - JSKIP = 0 -C -C Call the nonlinear Newton solver for up to MXNIT iterations. -C - CALL DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, - * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,TSCALE,SQRTN,RSQRTN, - * EPLIN,EPCON,RATEMX,MXNIT,STPTOL,ICNFLG,ICNSTR,IERNEW) -C - IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ .AND. JFLG .EQ. 1) THEN -C -C Up to MXNIT iterations were done, the convergence rate is < 1, -C a Jacobian routine is supplied, and the number of JACK calls -C is less than MXNJ. -C Copy the residual SAVR to DELTA, call JACK, and try again. -C - CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 - RETURN -C -C -C Unsuccessful exits from nonlinear solver. -C Set IERNLS accordingly. -C - 370 IERNLS = 2 - IF (IRES .LE. -2) IERNLS = -1 - RETURN -C - 380 IERNLS = MIN(IERNEW,2) - RETURN -C -C----------------------- END OF SUBROUTINE DDASIK----------------------- - END - SUBROUTINE DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, - * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,TSCALE,SQRTN,RSQRTN,EPLIN, - * EPCON,RATEMX,MAXIT,STPTOL,ICNFLG,ICNSTR,IERNEW) -C -C***BEGIN PROLOGUE DNSIK -C***REFER TO DDASPK -C***DATE WRITTEN 940701 (YYMMDD) -C***REVISION DATE 950714 (YYMMDD) -C***REVISION DATE 000628 TSCALE argument added. -C***REVISION DATE 000628 Added criterion for IERNEW = 1 return. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSIK solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in -C the initial conditions. -C -C The method used is a Newton scheme combined with a linesearch -C algorithm, using Krylov iterative linear system methods. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C See explanation inside DDASPK. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C SAVR -- Work vector for DNSIK of length NEQ. -C DELTA -- Residual vector on entry, and work vector of -C length NEQ for DNSIK. -C R -- Work vector for DNSIK of length NEQ. -C YIC,YPIC -- Work vectors for DNSIK, each of length NEQ. -C PWK -- Work vector for DNSIK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPLIN -- Tolerance for linear system solver. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C MAXIT -- Maximum allowed number of Newton iterations. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> failed to converge, but RATE .lt. 1, or the -C residual norm was reduced by a factor of .1. -C 2 ==> failed to converge, RATE .gt. RATEMX. -C 3 ==> other recoverable error. -C -1 ==> unrecoverable error inside Newton iteration. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY -C -C***END PROLOGUE DNSIK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),ID(*),DELTA(*),R(*),SAVR(*) - DIMENSION YIC(*),YPIC(*),PWK(*),WM(*),IWM(*), RPAR(*),IPAR(*) - DIMENSION ICNSTR(*) - EXTERNAL RES, PSOL -C - PARAMETER (LNNI=19, LNPS=21, LLOCWP=29, LLCIWP=30) - PARAMETER (LLSOFF=35, LSTOL=14) -C -C -C Initializations. M is the Newton iteration counter. -C - LSOFF = IWM(LLSOFF) - M = 0 - RATE = 1.0D0 - LWP = IWM(LLOCWP) - LIWP = IWM(LLCIWP) - RLX = 0.4D0 -C -C Save residual in SAVR. -C - CALL DCOPY (NEQ, DELTA, 1, SAVR, 1) -C -C Compute norm of (P-inverse)*(residual). -C - CALL DFNRMK (NEQ, Y, X, YPRIME, SAVR, R, CJ, TSCALE, WT, - * SQRTN, RSQRTN, RES, IRES, PSOL, 1, IER, FNRM, EPLIN, - * WM(LWP), IWM(LIWP), PWK, RPAR, IPAR) - IWM(LNPS) = IWM(LNPS) + 1 - IF (IER .NE. 0) THEN - IERNEW = 3 - RETURN - ENDIF -C -C Return now if residual norm is .le. EPCON. -C - IF (FNRM .LE. EPCON) RETURN -C -C Newton iteration loop. -C - FNRM0 = FNRM -300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C Compute a new step vector DELTA. -C - CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, - * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, - * RPAR, IPAR) - IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 390 -C -C Get norm of DELTA. Return now if DELTA is zero. -C - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM .EQ. 0.0D0) RETURN -C -C Call linesearch routine for global strategy and set RATE. -C - OLDFNM = FNRM -C - CALL DLINSK (NEQ, Y, X, YPRIME, SAVR, CJ, TSCALE, DELTA, DELNRM, - * WT, SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, - * WM, IWM, RHOK, FNRM, ICOPT, ID, WM(LWP), IWM(LIWP), R, EPLIN, - * YIC, YPIC, PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR) -C - RATE = FNRM/OLDFNM -C -C Check for error condition from linesearch. - IF (IRET .NE. 0) GO TO 390 -C -C Test for convergence of the iteration, and return or loop. -C - IF (FNRM .LE. EPCON) RETURN -C -C The iteration has not yet converged. Update M. -C Test whether the maximum number of iterations have been tried. -C - M = M + 1 - IF(M .GE. MAXIT) GO TO 380 -C -C Copy the residual SAVR to DELTA and loop for another iteration. -C - CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) - GO TO 300 -C -C The maximum number of iterations was done. Set IERNEW and return. -C -380 IF (RATE .LE. RATEMX .OR. FNRM .LE. 0.1D0*FNRM0) THEN - IERNEW = 1 - ELSE - IERNEW = 2 - ENDIF - RETURN -C -390 IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN - IERNEW = -1 - ELSE - IERNEW = 3 - IF (IRES .EQ. 0 .AND. IERSL .EQ. 1 .AND. M .GE. 2 - 1 .AND. RATE .LT. 1.0D0) IERNEW = 1 - ENDIF - RETURN -C -C -C----------------------- END OF SUBROUTINE DNSIK------------------------ - END - SUBROUTINE DLINSK (NEQ, Y, T, YPRIME, SAVR, CJ, TSCALE, P, PNRM, - * WT, SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, - * WM, IWM, RHOK, FNRM, ICOPT, ID, WP, IWP, R, EPLIN, YNEW, YPNEW, - * PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR) -C -C***BEGIN PROLOGUE DLINSK -C***REFER TO DNSIK -C***DATE WRITTEN 940830 (YYMMDD) -C***REVISION DATE 951006 (Arguments SQRTN, RSQRTN added.) -C***REVISION DATE 960129 Moved line RL = ONE to top block. -C***REVISION DATE 000628 TSCALE argument added. -C***REVISION DATE 000628 RHOK*RHOK term removed in alpha test. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME) -C pair (YNEW,YPNEW) such that -C -C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) -C -C where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of -C the final residual vector in the Krylov iteration. -C Here, f(y,y') is defined as -C -C f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 , -C -C where norm() is the weighted RMS vector norm, G is the DAE -C system residual function, and P is the preconditioner used -C in the Krylov iteration. -C -C In addition to the parameters defined elsewhere, we have -C -C SAVR -- Work array of length NEQ, containing the residual -C vector G(t,y,y') on return. -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C P -- Approximate Newton step used in backtracking. -C PNRM -- Weighted RMS norm of P. -C LSOFF -- Flag showing whether the linesearch algorithm is -C to be invoked. 0 means do the linesearch, -C 1 means turn off linesearch. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint violations -C in the proposed new approximate solution will be -C checked for, and the maximum step length will be -C adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C RHOK -- Weighted norm of preconditioned Krylov residual. -C RLX -- Real scalar restricting update size in DCNSTR. -C YNEW -- Array of length NEQ used to hold the new Y in -C performing the linesearch. -C YPNEW -- Array of length NEQ used to hold the new YPRIME in -C performing the linesearch. -C PWK -- Work vector of length NEQ for use in PSOL. -C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). -C YPRIME -- Array of length NEQ containing the new YPRIME -C (i.e.,=YPNEW). -C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the -C current (Y,YPRIME) on input and output. -C R -- Work space length NEQ for residual vector. -C IRET -- Return flag. -C IRET=0 means that a satisfactory (Y,YPRIME) was found. -C IRET=1 means that the routine failed to find a new -C (Y,YPRIME) that was sufficiently distinct from -C the current (Y,YPRIME) pair. -C IRET=2 means a failure in RES or PSOL. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DFNRMK, DYYPNW, DCNSTR, DCOPY, XERRWD -C -C***END PROLOGUE DLINSK -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - EXTERNAL RES, PSOL - DIMENSION Y(*), YPRIME(*), P(*), WT(*), SAVR(*), R(*), ID(*) - DIMENSION WM(*), IWM(*), YNEW(*), YPNEW(*), PWK(*), ICNSTR(*) - DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) - CHARACTER MSG*80 -C - PARAMETER (LNRE=12, LNPS=21, LKPRIN=31) -C - SAVE ALPHA, ONE, TWO - DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ -C - KPRIN=IWM(LKPRIN) - F1NRM = (FNRM*FNRM)/TWO - RATIO = ONE -C - IF (KPRIN .GE. 2) THEN - MSG = '------ IN ROUTINE DLINSK-- PNRM = (R1)' - CALL XERRWD(MSG, 38, 921, 0, 0, 0, 0, 1, PNRM, 0.0D0) - ENDIF - TAU = PNRM - RL = ONE -C----------------------------------------------------------------------- -C Check for violations of the constraints, if any are imposed. -C If any violations are found, the step vector P is rescaled, and the -C constraint check is repeated, until no violations are found. -C----------------------------------------------------------------------- - IF (ICNFLG .NE. 0) THEN - 10 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) - IF (IRET .EQ. 1) THEN - RATIO1 = TAU/PNRM - RATIO = RATIO*RATIO1 - DO 20 I = 1,NEQ - 20 P(I) = P(I)*RATIO1 - PNRM = TAU - IF (KPRIN .GE. 2) THEN - MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)' - CALL XERRWD(MSG, 50, 922, 0, 1, IVAR, 0, 1, PNRM, 0.0D0) - ENDIF - IF (PNRM .LE. STPTOL) THEN - IRET = 1 - RETURN - ENDIF - GO TO 10 - ENDIF - ENDIF -C - SLPI = -TWO*F1NRM*RATIO - RLMIN = STPTOL/PNRM - IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN - MSG = '------ MIN. LAMBDA = (R1)' - CALL XERRWD(MSG, 25, 923, 0, 0, 0, 0, 1, RLMIN, 0.0D0) - ENDIF -C----------------------------------------------------------------------- -C Begin iteration to find RL value satisfying alpha-condition. -C Update YNEW and YPNEW, then compute norm of new scaled residual and -C perform alpha condition test. -C----------------------------------------------------------------------- - 100 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DFNRMK (NEQ, YNEW, T, YPNEW, SAVR, R, CJ, TSCALE, WT, - * SQRTN, RSQRTN, RES, IRES, PSOL, 0, IER, FNRMP, EPLIN, - * WP, IWP, PWK, RPAR, IPAR) - IWM(LNRE) = IWM(LNRE) + 1 - IF (IRES .GE. 0) IWM(LNPS) = IWM(LNPS) + 1 - IF (IRES .NE. 0 .OR. IER .NE. 0) THEN - IRET = 2 - RETURN - ENDIF - IF (LSOFF .EQ. 1) GO TO 150 -C - F1NRMP = FNRMP*FNRMP/TWO - IF (KPRIN .GE. 2) THEN - MSG = '------ LAMBDA = (R1)' - CALL XERRWD(MSG, 20, 924, 0, 0, 0, 0, 1, RL, 0.0D0) - MSG = '------ NORM(F1) = (R1), NORM(F1NEW) = (R2)' - CALL XERRWD(MSG, 43, 925, 0, 0, 0, 0, 2, F1NRM, F1NRMP) - ENDIF - IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 -C----------------------------------------------------------------------- -C Alpha-condition is satisfied, or linesearch is turned off. -C Copy YNEW,YPNEW to Y,YPRIME and return. -C----------------------------------------------------------------------- - 150 IRET = 0 - CALL DCOPY(NEQ, YNEW, 1, Y, 1) - CALL DCOPY(NEQ, YPNEW, 1, YPRIME, 1) - FNRM = FNRMP - IF (KPRIN .GE. 1) THEN - MSG = '------ LEAVING ROUTINE DLINSK, FNRM = (R1)' - CALL XERRWD(MSG, 42, 926, 0, 0, 0, 0, 1, FNRM, 0.0D0) - ENDIF - RETURN -C----------------------------------------------------------------------- -C Alpha-condition not satisfied. Perform backtrack to compute new RL -C value. If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can -C be found sufficiently distinct from Y,YPRIME, then return IRET = 1. -C----------------------------------------------------------------------- - 200 CONTINUE - IF (RL .LT. RLMIN) THEN - IRET = 1 - RETURN - ENDIF -C - RL = RL/TWO - GO TO 100 -C -C----------------------- END OF SUBROUTINE DLINSK ---------------------- - END - SUBROUTINE DFNRMK (NEQ, Y, T, YPRIME, SAVR, R, CJ, TSCALE, WT, - * SQRTN, RSQRTN, RES, IRES, PSOL, IRIN, IER, - * FNORM, EPLIN, WP, IWP, PWK, RPAR, IPAR) -C -C***BEGIN PROLOGUE DFNRMK -C***REFER TO DLINSK -C***DATE WRITTEN 940830 (YYMMDD) -C***REVISION DATE 951006 (SQRTN, RSQRTN, and scaling of WT added.) -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DFNRMK calculates the scaled preconditioned norm of the nonlinear -C function used in the nonlinear iteration for obtaining consistent -C initial conditions. Specifically, DFNRMK calculates the weighted -C root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME), -C where P is the preconditioner matrix. -C -C In addition to the parameters described in the calling program -C DLINSK, the parameters represent -C -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C IRIN -- Flag showing whether the current residual vector is -C input in SAVR. 1 means it is, 0 means it is not. -C R -- Array of length NEQ that contains -C (P-inverse)*G(T,Y,YPRIME) on return. -C FNORM -- Scalar containing the weighted norm of R on return. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DCOPY, DSCAL, PSOL, DDWNRM -C -C***END PROLOGUE DFNRMK -C -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL RES, PSOL - DIMENSION Y(*), YPRIME(*), WT(*), SAVR(*), R(*), PWK(*) - DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) -C----------------------------------------------------------------------- -C Call RES routine if IRIN = 0. -C----------------------------------------------------------------------- - IF (IRIN .EQ. 0) THEN - IRES = 0 - CALL RES (T, Y, YPRIME, CJ, SAVR, IRES, RPAR, IPAR) - IF (IRES .LT. 0) RETURN - ENDIF -C----------------------------------------------------------------------- -C Apply inverse of left preconditioner to vector R. -C First scale WT array by 1/sqrt(N), and undo scaling afterward. -C----------------------------------------------------------------------- - CALL DCOPY(NEQ, SAVR, 1, R, 1) - CALL DSCAL (NEQ, RSQRTN, WT, 1) - IER = 0 - CALL PSOL (NEQ, T, Y, YPRIME, SAVR, PWK, CJ, WT, WP, IWP, - * R, EPLIN, IER, RPAR, IPAR) - CALL DSCAL (NEQ, SQRTN, WT, 1) - IF (IER .NE. 0) RETURN -C----------------------------------------------------------------------- -C Calculate norm of R. -C----------------------------------------------------------------------- - FNORM = DDWNRM (NEQ, R, WT, RPAR, IPAR) - IF (TSCALE .GT. 0.0D0) FNORM = FNORM*TSCALE*ABS(CJ) -C - RETURN -C----------------------- END OF SUBROUTINE DFNRMK ---------------------- - END - SUBROUTINE DNEDK(X,Y,YPRIME,NEQ,RES,JACK,PSOL, - * H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA,SAVR,DELTA,E, - * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,EPLI,SQRTN,RSQRTN, - * EPCON,JCALC,JFLG,KP1,NONNEG,NTYPE,IERNLS) -C -C***BEGIN PROLOGUE DNEDK -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940701 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNEDK solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a matrix-free Newton scheme. -C -C The parameters represent -C X -- Independent variable. -C Y -- Solution vector at x. -C YPRIME -- Derivative of solution vector -C after successful step. -C NEQ -- Number of equations to be integrated. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JACK -- External user-supplied routine to update -C the preconditioner. (This is optional). -C See JAC description for the case -C INFO(12) = 1 in the DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C (This is optional). See explanation inside DDASPK. -C H -- Appropriate step size for this step. -C WT -- Vector of weights for error criterion. -C JSTART -- Indicates first call to this routine. -C If JSTART = 0, then this is the first call, -C otherwise it is not. -C IDID -- Completion flag, output by DNEDK. -C See IDID description in DDASPK prologue. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C PHI -- Array of divided differences used by -C DNEDK. The length is NEQ*(K+1), where -C K is the maximum order. -C GAMMA -- Array used to predict Y and YPRIME. The length -C is K+1, where K is the maximum order. -C SAVR -- Work vector for DNEDK of length NEQ. -C DELTA -- Work vector for DNEDK of length NEQ. -C E -- Error accumulation vector for DNEDK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information for linear system -C solvers, and various other information. -C CJ -- Parameter always proportional to 1/H. -C CJOLD -- Saves the value of CJ as of the last call to DITMD. -C Accounts for changes in CJ needed to -C decide whether to call DITMD. -C CJLAST -- Previous value of CJ. -C S -- A scalar determined by the approximate rate -C of convergence of the Newton iteration and used -C in the convergence test for the Newton iteration. -C -C If RATE is defined to be an estimate of the -C rate of convergence of the Newton iteration, -C then S = RATE/(1.D0-RATE). -C -C The closer RATE is to 0., the faster the Newton -C iteration is converging; the closer RATE is to 1., -C the slower the Newton iteration is converging. -C -C On the first Newton iteration with an up-dated -C preconditioner S = 100.D0, Thus the initial -C RATE of convergence is approximately 1. -C -C S is preserved from call to call so that the rate -C estimate from a previous step can be applied to -C the current step. -C UROUND -- Unit roundoff. Not used here. -C EPLI -- convergence test constant. -C See DDASPK prologue for more details. -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C JCALC -- Flag used to determine when to update -C the Jacobian matrix. In general: -C -C JCALC = -1 ==> Call the DITMD routine to update -C the Jacobian matrix. -C JCALC = 0 ==> Jacobian matrix is up-to-date. -C JCALC = 1 ==> Jacobian matrix is out-dated, -C but DITMD will not be called unless -C JCALC is set to -1. -C JFLG -- Flag showing whether a Jacobian routine is supplied. -C KP1 -- The current order + 1; updated across calls. -C NONNEG -- Flag to determine nonnegativity constraints. -C NTYPE -- Identification code for the DNEDK routine. -C 1 ==> modified Newton; iterative linear solver. -C 2 ==> modified Newton; user-supplied linear solver. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1 ==> recoverable error inside non-linear solver. -C -1 ==> unrecoverable error inside non-linear solver. -C -C The following group of variables are passed as arguments to -C the Newton iteration solver. They are explained in greater detail -C in DNSK: -C TOLNEW, MULDEL, MAXIT, IERNEW -C -C IERTYP -- Flag which tells whether this subroutine is correct. -C 0 ==> correct subroutine. -C 1 ==> incorrect subroutine. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C RES, JACK, DDWNRM, DNSK -C -C***END PROLOGUE DNEDK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*) - DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) - DIMENSION WM(*),IWM(*) - DIMENSION GAMMA(*),RPAR(*),IPAR(*) - EXTERNAL RES, JACK, PSOL -C - PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) -C - SAVE MULDEL, MAXIT, XRATE - DATA MULDEL/0/, MAXIT/4/, XRATE/0.25D0/ -C -C Verify that this is the correct subroutine. -C - IERTYP = 0 - IF (NTYPE .NE. 1) THEN - IERTYP = 1 - GO TO 380 - ENDIF -C -C If this is the first step, perform initializations. -C - IF (JSTART .EQ. 0) THEN - CJOLD = CJ - JCALC = -1 - S = 100.D0 - ENDIF -C -C Perform all other initializations. -C - IERNLS = 0 - LWP = IWM(LLOCWP) - LIWP = IWM(LLCIWP) -C -C Decide whether to update the preconditioner. -C - IF (JFLG .NE. 0) THEN - TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) - TEMP2 = 1.0D0/TEMP1 - IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 - IF (CJ .NE. CJLAST) S = 100.D0 - ELSE - JCALC = 0 - ENDIF -C -C Looping point for updating preconditioner with current stepsize. -C -300 CONTINUE -C -C Initialize all error flags to zero. -C - IERPJ = 0 - IRES = 0 - IERSL = 0 - IERNEW = 0 -C -C Predict the solution and derivative and compute the tolerance -C for the Newton iteration. -C - DO 310 I=1,NEQ - Y(I)=PHI(I,1) -310 YPRIME(I)=0.0D0 - DO 330 J=2,KP1 - DO 320 I=1,NEQ - Y(I)=Y(I)+PHI(I,J) -320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) -330 CONTINUE - EPLIN = EPLI*EPCON - TOLNEW = EPLIN -C -C Call RES to initialize DELTA. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 -C -C -C If indicated, update the preconditioner. -C Set JCALC to 0 as an indicator that this has been done. -C - IF(JCALC .EQ. -1)THEN - IWM(LNJE) = IWM(LNJE) + 1 - JCALC=0 - CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, E, H, CJ, - * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) - CJOLD=CJ - S = 100.D0 - IF (IRES .LT. 0) GO TO 380 - IF (IERPJ .NE. 0) GO TO 380 - ENDIF -C -C Call the nonlinear Newton solver. -C - CALL DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR,SAVR, - * DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, - * S,TEMP1,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) -C - IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN -C -C The Newton iteration had a recoverable failure with an old -C preconditioner. Retry the step with a new preconditioner. -C - JCALC = -1 - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 -C -C The Newton iteration has converged. If nonnegativity of -C solution is required, set the solution nonnegative, if the -C perturbation to do it is small enough. If the change is too -C large, then consider the corrector iteration to have failed. -C - IF(NONNEG .EQ. 0) GO TO 390 - DO 360 I = 1,NEQ - 360 DELTA(I) = MIN(Y(I),0.0D0) - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF(DELNRM .GT. EPCON) GO TO 380 - DO 370 I = 1,NEQ - 370 E(I) = E(I) - DELTA(I) - GO TO 390 -C -C -C Exits from nonlinear solver. -C No convergence with current preconditioner. -C Compute IERNLS and IDID accordingly. -C -380 CONTINUE - IF (IRES .LE. -2 .OR. IERSL .LT. 0 .OR. IERTYP .NE. 0) THEN - IERNLS = -1 - IF (IRES .LE. -2) IDID = -11 - IF (IERSL .LT. 0) IDID = -13 - IF (IERTYP .NE. 0) IDID = -15 - ELSE - IERNLS = 1 - IF (IRES .EQ. -1) IDID = -10 - IF (IERPJ .NE. 0) IDID = -5 - IF (IERSL .GT. 0) IDID = -14 - ENDIF -C -C -390 JCALC = 1 - RETURN -C -C------END OF SUBROUTINE DNEDK------------------------------------------ - END - SUBROUTINE DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR, - * SAVR,DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, - * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) -C -C***BEGIN PROLOGUE DNSK -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 950126 (YYMMDD) -C***REVISION DATE 000711 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSK solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C See explanation inside DDASPK. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C SAVR -- Work vector for DNSK of length NEQ. -C DELTA -- Work vector for DNSK of length NEQ. -C E -- Error accumulation vector for DNSK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Parameter always proportional to 1/H (step size). -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPLIN -- Tolerance for linear system solver. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C S -- Used for error convergence tests. -C In the Newton iteration: S = RATE/(1.D0-RATE), -C where RATE is the estimated rate of convergence -C of the Newton iteration. -C -C The closer RATE is to 0., the faster the Newton -C iteration is converging; the closer RATE is to 1., -C the slower the Newton iteration is converging. -C -C The calling routine sends the initial value -C of S to the Newton iteration. -C CONFAC -- A residual scale factor to improve convergence. -C TOLNEW -- Tolerance on the norm of Newton correction in -C alternative Newton convergence test. -C MULDEL -- A flag indicating whether or not to multiply -C DELTA by CONFAC. -C 0 ==> do not scale DELTA by CONFAC. -C 1 ==> scale DELTA by CONFAC. -C MAXIT -- Maximum allowed number of Newton iterations. -C IRES -- Error flag returned from RES. See RES description -C in DDASPK prologue. If IRES = -1, then IERNEW -C will be set to 1. -C If IRES < -1, then IERNEW will be set to -1. -C IERSL -- Error flag for linear system solver. -C See IERSL description in subroutine DSLVK. -C If IERSL = 1, then IERNEW will be set to 1. -C If IERSL < 0, then IERNEW will be set to -1. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> recoverable error inside Newton iteration. -C -1 ==> unrecoverable error inside Newton iteration. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DSLVK, DDWNRM -C -C***END PROLOGUE DNSK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*),SAVR(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, PSOL -C - PARAMETER (LNNI=19, LNRE=12) -C -C Initialize Newton counter M and accumulation vector E. -C - M = 0 - DO 100 I=1,NEQ -100 E(I) = 0.0D0 -C -C Corrector loop. -C -300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C If necessary, multiply residual by convergence factor. -C - IF (MULDEL .EQ. 1) THEN - DO 320 I = 1,NEQ -320 DELTA(I) = DELTA(I) * CONFAC - ENDIF -C -C Save residual in SAVR. -C - DO 340 I = 1,NEQ -340 SAVR(I) = DELTA(I) -C -C Compute a new iterate. Store the correction in DELTA. -C - CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, - * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, - * RPAR, IPAR) - IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 380 -C -C Update Y, E, and YPRIME. -C - DO 360 I=1,NEQ - Y(I) = Y(I) - DELTA(I) - E(I) = E(I) - DELTA(I) -360 YPRIME(I) = YPRIME(I) - CJ*DELTA(I) -C -C Test for convergence of the iteration. -C - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (M .EQ. 0) THEN - OLDNRM = DELNRM - IF (DELNRM .LE. TOLNEW) GO TO 370 - ELSE - RATE = (DELNRM/OLDNRM)**(1.0D0/M) - IF (RATE .GT. 0.9D0) GO TO 380 - S = RATE/(1.0D0 - RATE) - ENDIF - IF (S*DELNRM .LE. EPCON) GO TO 370 -C -C The corrector has not yet converged. Update M and test whether -C the maximum number of iterations have been tried. -C - M = M + 1 - IF (M .GE. MAXIT) GO TO 380 -C -C Evaluate the residual, and go back to do another iteration. -C - IWM(LNRE) = IWM(LNRE) + 1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 - GO TO 300 -C -C The iteration has converged. -C -370 RETURN -C -C The iteration has not converged. Set IERNEW appropriately. -C -380 CONTINUE - IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN - IERNEW = -1 - ELSE - IERNEW = 1 - ENDIF - RETURN -C -C -C------END OF SUBROUTINE DNSK------------------------------------------- - END - SUBROUTINE DSLVK (NEQ, Y, TN, YPRIME, SAVR, X, EWT, WM, IWM, - * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, - * RPAR, IPAR) -C -C***BEGIN PROLOGUE DSLVK -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940928 Removed MNEWT and added RHOK in call list. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DSLVK uses a restart algorithm and interfaces to DSPIGM for -C the solution of the linear system arising from a Newton iteration. -C -C In addition to variables described elsewhere, -C communication with DSLVK uses the following variables.. -C WM = Real work space containing data for the algorithm -C (Krylov basis vectors, Hessenberg matrix, etc.). -C IWM = Integer work space containing data for the algorithm. -C X = The right-hand side vector on input, and the solution vector -C on output, of length NEQ. -C IRES = Error flag from RES. -C IERSL = Output flag .. -C IERSL = 0 means no trouble occurred (or user RES routine -C returned IRES < 0) -C IERSL = 1 means the iterative method failed to converge -C (DSPIGM returned IFLAG > 0.) -C IERSL = -1 means there was a nonrecoverable error in the -C iterative solver, and an error exit will occur. -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DSCAL, DCOPY, DSPIGM -C -C***END PROLOGUE DSLVK -C - INTEGER NEQ, IWM, IRES, IERSL, IPAR - DOUBLE PRECISION Y, TN, YPRIME, SAVR, X, EWT, WM, CJ, EPLIN, - 1 SQRTN, RSQRTN, RHOK, RPAR - DIMENSION Y(*), YPRIME(*), SAVR(*), X(*), EWT(*), - 1 WM(*), IWM(*), RPAR(*), IPAR(*) -C - INTEGER IFLAG, IRST, NRSTS, NRMAX, LR, LDL, LHES, LGMR, LQ, LV, - 1 LWK, LZ, MAXLP1, NPSL - INTEGER NLI, NPS, NCFL, NRE, MAXL, KMP, MITER - EXTERNAL RES, PSOL -C - PARAMETER (LNRE=12, LNCFL=16, LNLI=20, LNPS=21) - PARAMETER (LLOCWP=29, LLCIWP=30) - PARAMETER (LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26) -C -C----------------------------------------------------------------------- -C IRST is set to 1, to indicate restarting is in effect. -C NRMAX is the maximum number of restarts. -C----------------------------------------------------------------------- - DATA IRST/1/ -C - LIWP = IWM(LLCIWP) - NLI = IWM(LNLI) - NPS = IWM(LNPS) - NCFL = IWM(LNCFL) - NRE = IWM(LNRE) - LWP = IWM(LLOCWP) - MAXL = IWM(LMAXL) - KMP = IWM(LKMP) - NRMAX = IWM(LNRMAX) - MITER = IWM(LMITER) - IERSL = 0 - IRES = 0 -C----------------------------------------------------------------------- -C Use a restarting strategy to solve the linear system -C P*X = -F. Parse the work vector, and perform initializations. -C Note that zero is the initial guess for X. -C----------------------------------------------------------------------- - MAXLP1 = MAXL + 1 - LV = 1 - LR = LV + NEQ*MAXL - LHES = LR + NEQ + 1 - LQ = LHES + MAXL*MAXLP1 - LWK = LQ + 2*MAXL - LDL = LWK + MIN0(1,MAXL-KMP)*NEQ - LZ = LDL + NEQ - CALL DSCAL (NEQ, RSQRTN, EWT, 1) - CALL DCOPY (NEQ, X, 1, WM(LR), 1) - DO 110 I = 1,NEQ - 110 X(I) = 0.D0 -C----------------------------------------------------------------------- -C Top of loop for the restart algorithm. Initial pass approximates -C X and sets up a transformed system to perform subsequent restarts -C to update X. NRSTS is initialized to -1, because restarting -C does not occur until after the first pass. -C Update NRSTS; conditionally copy DL to R; call the DSPIGM -C algorithm to solve A*Z = R; updated counters; update X with -C the residual solution. -C Note: if convergence is not achieved after NRMAX restarts, -C then the linear solver is considered to have failed. -C----------------------------------------------------------------------- - NRSTS = -1 - 115 CONTINUE - NRSTS = NRSTS + 1 - IF (NRSTS .GT. 0) CALL DCOPY (NEQ, WM(LDL), 1, WM(LR),1) - CALL DSPIGM (NEQ, TN, Y, YPRIME, SAVR, WM(LR), EWT, MAXL, MAXLP1, - 1 KMP, EPLIN, CJ, RES, IRES, NRES, PSOL, NPSL, WM(LZ), WM(LV), - 2 WM(LHES), WM(LQ), LGMR, WM(LWP), IWM(LIWP), WM(LWK), - 3 WM(LDL), RHOK, IFLAG, IRST, NRSTS, RPAR, IPAR) - NLI = NLI + LGMR - NPS = NPS + NPSL - NRE = NRE + NRES - DO 120 I = 1,NEQ - 120 X(I) = X(I) + WM(LZ+I-1) - IF ((IFLAG .EQ. 1) .AND. (NRSTS .LT. NRMAX) .AND. (IRES .EQ. 0)) - 1 GO TO 115 -C----------------------------------------------------------------------- -C The restart scheme is finished. Test IRES and IFLAG to see if -C convergence was not achieved, and set flags accordingly. -C----------------------------------------------------------------------- - IF (IRES .LT. 0) THEN - NCFL = NCFL + 1 - ELSE IF (IFLAG .NE. 0) THEN - NCFL = NCFL + 1 - IF (IFLAG .GT. 0) IERSL = 1 - IF (IFLAG .LT. 0) IERSL = -1 - ENDIF -C----------------------------------------------------------------------- -C Update IWM with counters, rescale EWT, and return. -C----------------------------------------------------------------------- - IWM(LNLI) = NLI - IWM(LNPS) = NPS - IWM(LNCFL) = NCFL - IWM(LNRE) = NRE - CALL DSCAL (NEQ, SQRTN, EWT, 1) - RETURN -C -C------END OF SUBROUTINE DSLVK------------------------------------------ - END - SUBROUTINE DSPIGM (NEQ, TN, Y, YPRIME, SAVR, R, WGHT, MAXL, - * MAXLP1, KMP, EPLIN, CJ, RES, IRES, NRE, PSOL, NPSL, Z, V, - * HES, Q, LGMR, WP, IWP, WK, DL, RHOK, IFLAG, IRST, NRSTS, - * RPAR, IPAR) -C -C***BEGIN PROLOGUE DSPIGM -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940927 Removed MNEWT and added RHOK in call list. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine solves the linear system A * Z = R using a scaled -C preconditioned version of the generalized minimum residual method. -C An initial guess of Z = 0 is assumed. -C -C On entry -C -C NEQ = Problem size, passed to PSOL. -C -C TN = Current Value of T. -C -C Y = Array Containing current dependent variable vector. -C -C YPRIME = Array Containing current first derivative of Y. -C -C SAVR = Array containing current value of G(T,Y,YPRIME). -C -C R = The right hand side of the system A*Z = R. -C R is also used as work space when computing -C the final approximation and will therefore be -C destroyed. -C (R is the same as V(*,MAXL+1) in the call to DSPIGM.) -C -C WGHT = The vector of length NEQ containing the nonzero -C elements of the diagonal scaling matrix. -C -C MAXL = The maximum allowable order of the matrix H. -C -C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. -C -C KMP = The number of previous vectors the new vector, VNEW, -C must be made orthogonal to. (KMP .LE. MAXL.) -C -C EPLIN = Tolerance on residuals R-A*Z in weighted rms norm. -C -C CJ = Scalar proportional to current value of -C 1/(step size H). -C -C WK = Real work array used by routine DATV and PSOL. -C -C DL = Real work array used for calculation of the residual -C norm RHO when the method is incomplete (KMP.LT.MAXL) -C and/or when using restarting. -C -C WP = Real work array used by preconditioner PSOL. -C -C IWP = Integer work array used by preconditioner PSOL. -C -C IRST = Method flag indicating if restarting is being -C performed. IRST .GT. 0 means restarting is active, -C while IRST = 0 means restarting is not being used. -C -C NRSTS = Counter for the number of restarts on the current -C call to DSPIGM. If NRSTS .GT. 0, then the residual -C R is already scaled, and so scaling of R is not -C necessary. -C -C -C On Return -C -C Z = The final computed approximation to the solution -C of the system A*Z = R. -C -C LGMR = The number of iterations performed and -C the current order of the upper Hessenberg -C matrix HES. -C -C NRE = The number of calls to RES (i.e. DATV) -C -C NPSL = The number of calls to PSOL. -C -C V = The neq by (LGMR+1) array containing the LGMR -C orthogonal vectors V(*,1) to V(*,LGMR). -C -C HES = The upper triangular factor of the QR decomposition -C of the (LGMR+1) by LGMR upper Hessenberg matrix whose -C entries are the scaled inner-products of A*V(*,I) -C and V(*,K). -C -C Q = Real array of length 2*MAXL containing the components -C of the givens rotations used in the QR decomposition -C of HES. It is loaded in DHEQR and used in DHELS. -C -C IRES = Error flag from RES. -C -C DL = Scaled preconditioned residual, -C (D-inverse)*(P-inverse)*(R-A*Z). Only loaded when -C performing restarts of the Krylov iteration. -C -C RHOK = Weighted norm of final preconditioned residual. -C -C IFLAG = Integer error flag.. -C 0 Means convergence in LGMR iterations, LGMR.LE.MAXL. -C 1 Means the convergence test did not pass in MAXL -C iterations, but the new residual norm (RHO) is -C .LT. the old residual norm (RNRM), and so Z is -C computed. -C 2 Means the convergence test did not pass in MAXL -C iterations, new residual norm (RHO) .GE. old residual -C norm (RNRM), and the initial guess, Z = 0, is -C returned. -C 3 Means there was a recoverable error in PSOL -C caused by the preconditioner being out of date. -C -1 Means there was an unrecoverable error in PSOL. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C PSOL, DNRM2, DSCAL, DATV, DORTH, DHEQR, DCOPY, DHELS, DAXPY -C -C***END PROLOGUE DSPIGM -C - INTEGER NEQ,MAXL,MAXLP1,KMP,IRES,NRE,NPSL,LGMR,IWP, - 1 IFLAG,IRST,NRSTS,IPAR - DOUBLE PRECISION TN,Y,YPRIME,SAVR,R,WGHT,EPLIN,CJ,Z,V,HES,Q,WP,WK, - 1 DL,RHOK,RPAR - DIMENSION Y(*), YPRIME(*), SAVR(*), R(*), WGHT(*), Z(*), - 1 V(NEQ,*), HES(MAXLP1,*), Q(*), WP(*), IWP(*), WK(*), DL(*), - 2 RPAR(*), IPAR(*) - INTEGER I, IER, INFO, IP1, I2, J, K, LL, LLP1 - DOUBLE PRECISION RNRM,C,DLNRM,PROD,RHO,S,SNORMW,DNRM2,TEM - EXTERNAL RES, PSOL -C - IER = 0 - IFLAG = 0 - LGMR = 0 - NPSL = 0 - NRE = 0 -C----------------------------------------------------------------------- -C The initial guess for Z is 0. The initial residual is therefore -C the vector R. Initialize Z to 0. -C----------------------------------------------------------------------- - DO 10 I = 1,NEQ - 10 Z(I) = 0.0D0 -C----------------------------------------------------------------------- -C Apply inverse of left preconditioner to vector R if NRSTS .EQ. 0. -C Form V(*,1), the scaled preconditioned right hand side. -C----------------------------------------------------------------------- - IF (NRSTS .EQ. 0) THEN - CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, WK, CJ, WGHT, WP, IWP, - 1 R, EPLIN, IER, RPAR, IPAR) - NPSL = 1 - IF (IER .NE. 0) GO TO 300 - DO 30 I = 1,NEQ - 30 V(I,1) = R(I)*WGHT(I) - ELSE - DO 35 I = 1,NEQ - 35 V(I,1) = R(I) - ENDIF -C----------------------------------------------------------------------- -C Calculate norm of scaled vector V(*,1) and normalize it -C If, however, the norm of V(*,1) (i.e. the norm of the preconditioned -C residual) is .le. EPLIN, then return with Z=0. -C----------------------------------------------------------------------- - RNRM = DNRM2 (NEQ, V, 1) - IF (RNRM .LE. EPLIN) THEN - RHOK = RNRM - RETURN - ENDIF - TEM = 1.0D0/RNRM - CALL DSCAL (NEQ, TEM, V(1,1), 1) -C----------------------------------------------------------------------- -C Zero out the HES array. -C----------------------------------------------------------------------- - DO 65 J = 1,MAXL - DO 60 I = 1,MAXLP1 - 60 HES(I,J) = 0.0D0 - 65 CONTINUE -C----------------------------------------------------------------------- -C Main loop to compute the vectors V(*,2) to V(*,MAXL). -C The running product PROD is needed for the convergence test. -C----------------------------------------------------------------------- - PROD = 1.0D0 - DO 90 LL = 1,MAXL - LGMR = LL -C----------------------------------------------------------------------- -C Call routine DATV to compute VNEW = ABAR*V(LL), where ABAR is -C the matrix A with scaling and inverse preconditioner factors applied. -C Call routine DORTH to orthogonalize the new vector VNEW = V(*,LL+1). -C call routine DHEQR to update the factors of HES. -C----------------------------------------------------------------------- - CALL DATV (NEQ, Y, TN, YPRIME, SAVR, V(1,LL), WGHT, Z, - 1 RES, IRES, PSOL, V(1,LL+1), WK, WP, IWP, CJ, EPLIN, - 1 IER, NRE, NPSL, RPAR, IPAR) - IF (IRES .LT. 0) RETURN - IF (IER .NE. 0) GO TO 300 - CALL DORTH (V(1,LL+1), V, HES, NEQ, LL, MAXLP1, KMP, SNORMW) - HES(LL+1,LL) = SNORMW - CALL DHEQR (HES, MAXLP1, LL, Q, INFO, LL) - IF (INFO .EQ. LL) GO TO 120 -C----------------------------------------------------------------------- -C Update RHO, the estimate of the norm of the residual R - A*ZL. -C If KMP .LT. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not -C necessarily orthogonal for LL .GT. KMP. The vector DL must then -C be computed, and its norm used in the calculation of RHO. -C----------------------------------------------------------------------- - PROD = PROD*Q(2*LL) - RHO = ABS(PROD*RNRM) - IF ((LL.GT.KMP) .AND. (KMP.LT.MAXL)) THEN - IF (LL .EQ. KMP+1) THEN - CALL DCOPY (NEQ, V(1,1), 1, DL, 1) - DO 75 I = 1,KMP - IP1 = I + 1 - I2 = I*2 - S = Q(I2) - C = Q(I2-1) - DO 70 K = 1,NEQ - 70 DL(K) = S*DL(K) + C*V(K,IP1) - 75 CONTINUE - ENDIF - S = Q(2*LL) - C = Q(2*LL-1)/SNORMW - LLP1 = LL + 1 - DO 80 K = 1,NEQ - 80 DL(K) = S*DL(K) + C*V(K,LLP1) - DLNRM = DNRM2 (NEQ, DL, 1) - RHO = RHO*DLNRM - ENDIF -C----------------------------------------------------------------------- -C Test for convergence. If passed, compute approximation ZL. -C If failed and LL .LT. MAXL, then continue iterating. -C----------------------------------------------------------------------- - IF (RHO .LE. EPLIN) GO TO 200 - IF (LL .EQ. MAXL) GO TO 100 -C----------------------------------------------------------------------- -C Rescale so that the norm of V(1,LL+1) is one. -C----------------------------------------------------------------------- - TEM = 1.0D0/SNORMW - CALL DSCAL (NEQ, TEM, V(1,LL+1), 1) - 90 CONTINUE - 100 CONTINUE - IF (RHO .LT. RNRM) GO TO 150 - 120 CONTINUE - IFLAG = 2 - DO 130 I = 1,NEQ - 130 Z(I) = 0.D0 - RETURN - 150 IFLAG = 1 -C----------------------------------------------------------------------- -C The tolerance was not met, but the residual norm was reduced. -C If performing restarting (IRST .gt. 0) calculate the residual vector -C RL and store it in the DL array. If the incomplete version is -C being used (KMP .lt. MAXL) then DL has already been calculated. -C----------------------------------------------------------------------- - IF (IRST .GT. 0) THEN - IF (KMP .EQ. MAXL) THEN -C -C Calculate DL from the V(I)'s. -C - CALL DCOPY (NEQ, V(1,1), 1, DL, 1) - MAXLM1 = MAXL - 1 - DO 175 I = 1,MAXLM1 - IP1 = I + 1 - I2 = I*2 - S = Q(I2) - C = Q(I2-1) - DO 170 K = 1,NEQ - 170 DL(K) = S*DL(K) + C*V(K,IP1) - 175 CONTINUE - S = Q(2*MAXL) - C = Q(2*MAXL-1)/SNORMW - DO 180 K = 1,NEQ - 180 DL(K) = S*DL(K) + C*V(K,MAXLP1) - ENDIF -C -C Scale DL by RNRM*PROD to obtain the residual RL. -C - TEM = RNRM*PROD - CALL DSCAL(NEQ, TEM, DL, 1) - ENDIF -C----------------------------------------------------------------------- -C Compute the approximation ZL to the solution. -C Since the vector Z was used as work space, and the initial guess -C of the Newton correction is zero, Z must be reset to zero. -C----------------------------------------------------------------------- - 200 CONTINUE - LL = LGMR - LLP1 = LL + 1 - DO 210 K = 1,LLP1 - 210 R(K) = 0.0D0 - R(1) = RNRM - CALL DHELS (HES, MAXLP1, LL, Q, R) - DO 220 K = 1,NEQ - 220 Z(K) = 0.0D0 - DO 230 I = 1,LL - CALL DAXPY (NEQ, R(I), V(1,I), 1, Z, 1) - 230 CONTINUE - DO 240 I = 1,NEQ - 240 Z(I) = Z(I)/WGHT(I) -C Load RHO into RHOK. - RHOK = RHO - RETURN -C----------------------------------------------------------------------- -C This block handles error returns forced by routine PSOL. -C----------------------------------------------------------------------- - 300 CONTINUE - IF (IER .LT. 0) IFLAG = -1 - IF (IER .GT. 0) IFLAG = 3 -C - RETURN -C -C------END OF SUBROUTINE DSPIGM----------------------------------------- - END - SUBROUTINE DATV (NEQ, Y, TN, YPRIME, SAVR, V, WGHT, YPTEM, RES, - * IRES, PSOL, Z, VTEM, WP, IWP, CJ, EPLIN, IER, NRE, NPSL, - * RPAR,IPAR) -C -C***BEGIN PROLOGUE DATV -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine computes the product -C -C Z = (D-inverse)*(P-inverse)*(dF/dY)*(D*V), -C -C where F(Y) = G(T, Y, CJ*(Y-A)), CJ is a scalar proportional to 1/H, -C and A involves the past history of Y. The quantity CJ*(Y-A) is -C an approximation to the first derivative of Y and is stored -C in the array YPRIME. Note that dF/dY = dG/dY + CJ*dG/dYPRIME. -C -C D is a diagonal scaling matrix, and P is the left preconditioning -C matrix. V is assumed to have L2 norm equal to 1. -C The product is stored in Z and is computed by means of a -C difference quotient, a call to RES, and one call to PSOL. -C -C On entry -C -C NEQ = Problem size, passed to RES and PSOL. -C -C Y = Array containing current dependent variable vector. -C -C YPRIME = Array containing current first derivative of y. -C -C SAVR = Array containing current value of G(T,Y,YPRIME). -C -C V = Real array of length NEQ (can be the same array as Z). -C -C WGHT = Array of length NEQ containing scale factors. -C 1/WGHT(I) are the diagonal elements of the matrix D. -C -C YPTEM = Work array of length NEQ. -C -C VTEM = Work array of length NEQ used to store the -C unscaled version of V. -C -C WP = Real work array used by preconditioner PSOL. -C -C IWP = Integer work array used by preconditioner PSOL. -C -C CJ = Scalar proportional to current value of -C 1/(step size H). -C -C -C On return -C -C Z = Array of length NEQ containing desired scaled -C matrix-vector product. -C -C IRES = Error flag from RES. -C -C IER = Error flag from PSOL. -C -C NRE = The number of calls to RES. -C -C NPSL = The number of calls to PSOL. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C RES, PSOL -C -C***END PROLOGUE DATV -C - INTEGER NEQ, IRES, IWP, IER, NRE, NPSL, IPAR - DOUBLE PRECISION Y, TN, YPRIME, SAVR, V, WGHT, YPTEM, Z, VTEM, - 1 WP, CJ, RPAR - DIMENSION Y(*), YPRIME(*), SAVR(*), V(*), WGHT(*), YPTEM(*), - 1 Z(*), VTEM(*), WP(*), IWP(*), RPAR(*), IPAR(*) - INTEGER I - DOUBLE PRECISION EPLIN - EXTERNAL RES, PSOL -C - IRES = 0 -C----------------------------------------------------------------------- -C Set VTEM = D * V. -C----------------------------------------------------------------------- - DO 10 I = 1,NEQ - 10 VTEM(I) = V(I)/WGHT(I) - IER = 0 -C----------------------------------------------------------------------- -C Store Y in Z and increment Z by VTEM. -C Store YPRIME in YPTEM and increment YPTEM by VTEM*CJ. -C----------------------------------------------------------------------- - DO 20 I = 1,NEQ - YPTEM(I) = YPRIME(I) + VTEM(I)*CJ - 20 Z(I) = Y(I) + VTEM(I) -C----------------------------------------------------------------------- -C Call RES with incremented Y, YPRIME arguments -C stored in Z, YPTEM. VTEM is overwritten with new residual. -C----------------------------------------------------------------------- - CONTINUE - CALL RES(TN,Z,YPTEM,CJ,VTEM,IRES,RPAR,IPAR) - NRE = NRE + 1 - IF (IRES .LT. 0) RETURN -C----------------------------------------------------------------------- -C Set Z = (dF/dY) * VBAR using difference quotient. -C (VBAR is old value of VTEM before calling RES) -C----------------------------------------------------------------------- - DO 70 I = 1,NEQ - 70 Z(I) = VTEM(I) - SAVR(I) -C----------------------------------------------------------------------- -C Apply inverse of left preconditioner to Z. -C----------------------------------------------------------------------- - CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, YPTEM, CJ, WGHT, WP, IWP, - 1 Z, EPLIN, IER, RPAR, IPAR) - NPSL = NPSL + 1 - IF (IER .NE. 0) RETURN -C----------------------------------------------------------------------- -C Apply D-inverse to Z and return. -C----------------------------------------------------------------------- - DO 90 I = 1,NEQ - 90 Z(I) = Z(I)*WGHT(I) - RETURN -C -C------END OF SUBROUTINE DATV------------------------------------------- - END - SUBROUTINE DORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) -C -C***BEGIN PROLOGUE DORTH -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine orthogonalizes the vector VNEW against the previous -C KMP vectors in the V array. It uses a modified Gram-Schmidt -C orthogonalization procedure with conditional reorthogonalization. -C -C On entry -C -C VNEW = The vector of length N containing a scaled product -C OF The Jacobian and the vector V(*,LL). -C -C V = The N x LL array containing the previous LL -C orthogonal vectors V(*,1) to V(*,LL). -C -C HES = An LL x LL upper Hessenberg matrix containing, -C in HES(I,K), K.LT.LL, scaled inner products of -C A*V(*,K) and V(*,I). -C -C LDHES = The leading dimension of the HES array. -C -C N = The order of the matrix A, and the length of VNEW. -C -C LL = The current order of the matrix HES. -C -C KMP = The number of previous vectors the new vector VNEW -C must be made orthogonal to (KMP .LE. MAXL). -C -C -C On return -C -C VNEW = The new vector orthogonal to V(*,I0), -C where I0 = MAX(1, LL-KMP+1). -C -C HES = Upper Hessenberg matrix with column LL filled in with -C scaled inner products of A*V(*,LL) and V(*,I). -C -C SNORMW = L-2 norm of VNEW. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DDOT, DNRM2, DAXPY -C -C***END PROLOGUE DORTH -C - INTEGER N, LL, LDHES, KMP - DOUBLE PRECISION VNEW, V, HES, SNORMW - DIMENSION VNEW(*), V(N,*), HES(LDHES,*) - INTEGER I, I0 - DOUBLE PRECISION ARG, DDOT, DNRM2, SUMDSQ, TEM, VNRM -C -C----------------------------------------------------------------------- -C Get norm of unaltered VNEW for later use. -C----------------------------------------------------------------------- - VNRM = DNRM2 (N, VNEW, 1) -C----------------------------------------------------------------------- -C Do Modified Gram-Schmidt on VNEW = A*V(LL). -C Scaled inner products give new column of HES. -C Projections of earlier vectors are subtracted from VNEW. -C----------------------------------------------------------------------- - I0 = MAX0(1,LL-KMP+1) - DO 10 I = I0,LL - HES(I,LL) = DDOT (N, V(1,I), 1, VNEW, 1) - TEM = -HES(I,LL) - CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) - 10 CONTINUE -C----------------------------------------------------------------------- -C Compute SNORMW = norm of VNEW. -C If VNEW is small compared to its input value (in norm), then -C Reorthogonalize VNEW to V(*,1) through V(*,LL). -C Correct if relative correction exceeds 1000*(unit roundoff). -C Finally, correct SNORMW using the dot products involved. -C----------------------------------------------------------------------- - SNORMW = DNRM2 (N, VNEW, 1) - IF (VNRM + 0.001D0*SNORMW .NE. VNRM) RETURN - SUMDSQ = 0.0D0 - DO 30 I = I0,LL - TEM = -DDOT (N, V(1,I), 1, VNEW, 1) - IF (HES(I,LL) + 0.001D0*TEM .EQ. HES(I,LL)) GO TO 30 - HES(I,LL) = HES(I,LL) - TEM - CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) - SUMDSQ = SUMDSQ + TEM**2 - 30 CONTINUE - IF (SUMDSQ .EQ. 0.0D0) RETURN - ARG = MAX(0.0D0,SNORMW**2 - SUMDSQ) - SNORMW = SQRT(ARG) - RETURN -C -C------END OF SUBROUTINE DORTH------------------------------------------ - END - SUBROUTINE DHEQR (A, LDA, N, Q, INFO, IJOB) -C -C***BEGIN PROLOGUE DHEQR -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine performs a QR decomposition of an upper -C Hessenberg matrix A. There are two options available: -C -C (1) performing a fresh decomposition -C (2) updating the QR factors by adding a row and A -C column to the matrix A. -C -C DHEQR decomposes an upper Hessenberg matrix by using Givens -C rotations. -C -C On entry -C -C A DOUBLE PRECISION(LDA, N) -C The matrix to be decomposed. -C -C LDA INTEGER -C The leading dimension of the array A. -C -C N INTEGER -C A is an (N+1) by N Hessenberg matrix. -C -C IJOB INTEGER -C = 1 Means that a fresh decomposition of the -C matrix A is desired. -C .GE. 2 Means that the current decomposition of A -C will be updated by the addition of a row -C and a column. -C On return -C -C A The upper triangular matrix R. -C The factorization can be written Q*A = R, where -C Q is a product of Givens rotations and R is upper -C triangular. -C -C Q DOUBLE PRECISION(2*N) -C The factors C and S of each Givens rotation used -C in decomposing A. -C -C INFO INTEGER -C = 0 normal value. -C = K If A(K,K) .EQ. 0.0. This is not an error -C condition for this subroutine, but it does -C indicate that DHELS will divide by zero -C if called. -C -C Modification of LINPACK. -C Peter Brown, Lawrence Livermore Natl. Lab. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED (NONE) -C -C***END PROLOGUE DHEQR -C - INTEGER LDA, N, INFO, IJOB - DOUBLE PRECISION A(LDA,*), Q(*) - INTEGER I, IQ, J, K, KM1, KP1, NM1 - DOUBLE PRECISION C, S, T, T1, T2 -C - IF (IJOB .GT. 1) GO TO 70 -C----------------------------------------------------------------------- -C A new factorization is desired. -C----------------------------------------------------------------------- -C -C QR decomposition without pivoting. -C - INFO = 0 - DO 60 K = 1, N - KM1 = K - 1 - KP1 = K + 1 -C -C Compute Kth column of R. -C First, multiply the Kth column of A by the previous -C K-1 Givens rotations. -C - IF (KM1 .LT. 1) GO TO 20 - DO 10 J = 1, KM1 - I = 2*(J-1) + 1 - T1 = A(J,K) - T2 = A(J+1,K) - C = Q(I) - S = Q(I+1) - A(J,K) = C*T1 - S*T2 - A(J+1,K) = S*T1 + C*T2 - 10 CONTINUE -C -C Compute Givens components C and S. -C - 20 CONTINUE - IQ = 2*KM1 + 1 - T1 = A(K,K) - T2 = A(KP1,K) - IF (T2 .NE. 0.0D0) GO TO 30 - C = 1.0D0 - S = 0.0D0 - GO TO 50 - 30 CONTINUE - IF (ABS(T2) .LT. ABS(T1)) GO TO 40 - T = T1/T2 - S = -1.0D0/SQRT(1.0D0+T*T) - C = -S*T - GO TO 50 - 40 CONTINUE - T = T2/T1 - C = 1.0D0/SQRT(1.0D0+T*T) - S = -C*T - 50 CONTINUE - Q(IQ) = C - Q(IQ+1) = S - A(K,K) = C*T1 - S*T2 - IF (A(K,K) .EQ. 0.0D0) INFO = K - 60 CONTINUE - RETURN -C----------------------------------------------------------------------- -C The old factorization of A will be updated. A row and a column -C has been added to the matrix A. -C N by N-1 is now the old size of the matrix. -C----------------------------------------------------------------------- - 70 CONTINUE - NM1 = N - 1 -C----------------------------------------------------------------------- -C Multiply the new column by the N previous Givens rotations. -C----------------------------------------------------------------------- - DO 100 K = 1,NM1 - I = 2*(K-1) + 1 - T1 = A(K,N) - T2 = A(K+1,N) - C = Q(I) - S = Q(I+1) - A(K,N) = C*T1 - S*T2 - A(K+1,N) = S*T1 + C*T2 - 100 CONTINUE -C----------------------------------------------------------------------- -C Complete update of decomposition by forming last Givens rotation, -C and multiplying it times the column vector (A(N,N),A(NP1,N)). -C----------------------------------------------------------------------- - INFO = 0 - T1 = A(N,N) - T2 = A(N+1,N) - IF (T2 .NE. 0.0D0) GO TO 110 - C = 1.0D0 - S = 0.0D0 - GO TO 130 - 110 CONTINUE - IF (ABS(T2) .LT. ABS(T1)) GO TO 120 - T = T1/T2 - S = -1.0D0/SQRT(1.0D0+T*T) - C = -S*T - GO TO 130 - 120 CONTINUE - T = T2/T1 - C = 1.0D0/SQRT(1.0D0+T*T) - S = -C*T - 130 CONTINUE - IQ = 2*N - 1 - Q(IQ) = C - Q(IQ+1) = S - A(N,N) = C*T1 - S*T2 - IF (A(N,N) .EQ. 0.0D0) INFO = N - RETURN -C -C------END OF SUBROUTINE DHEQR------------------------------------------ - END - SUBROUTINE DHELS (A, LDA, N, Q, B) -C -C***BEGIN PROLOGUE DHELS -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This is similar to the LINPACK routine DGESL except that -C A is an upper Hessenberg matrix. -C -C DHELS solves the least squares problem -C -C MIN (B-A*X,B-A*X) -C -C using the factors computed by DHEQR. -C -C On entry -C -C A DOUBLE PRECISION (LDA, N) -C The output from DHEQR which contains the upper -C triangular factor R in the QR decomposition of A. -C -C LDA INTEGER -C The leading dimension of the array A . -C -C N INTEGER -C A is originally an (N+1) by N matrix. -C -C Q DOUBLE PRECISION(2*N) -C The coefficients of the N givens rotations -C used in the QR factorization of A. -C -C B DOUBLE PRECISION(N+1) -C The right hand side vector. -C -C -C On return -C -C B The solution vector X. -C -C -C Modification of LINPACK. -C Peter Brown, Lawrence Livermore Natl. Lab. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DAXPY -C -C***END PROLOGUE DHELS -C - INTEGER LDA, N - DOUBLE PRECISION A(LDA,*), B(*), Q(*) - INTEGER IQ, K, KB, KP1 - DOUBLE PRECISION C, S, T, T1, T2 -C -C Minimize (B-A*X,B-A*X). -C First form Q*B. -C - DO 20 K = 1, N - KP1 = K + 1 - IQ = 2*(K-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 - 20 CONTINUE -C -C Now solve R*X = Q*B. -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1) - 40 CONTINUE - RETURN -C -C------END OF SUBROUTINE DHELS------------------------------------------ - END diff --git a/Cantera/ext/math/dgbefa.f b/Cantera/ext/math/dgbefa.f deleted file mode 100644 index c26e6f579..000000000 --- a/Cantera/ext/math/dgbefa.f +++ /dev/null @@ -1,174 +0,0 @@ - subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) - integer lda,n,ml,mu,ipvt(1),info - double precision abd(lda,1) -c -c dgbfa factors a double precision band matrix by elimination. -c -c dgbfa is usually called by dgbco, but it can be called -c directly with a saving in time if rcond is not needed. -c -c on entry -c -c abd double precision(lda, n) -c contains the matrix in band storage. the columns -c of the matrix are stored in the columns of abd and -c the diagonals of the matrix are stored in rows -c ml+1 through 2*ml+mu+1 of abd . -c see the comments below for details. -c -c lda integer -c the leading dimension of the array abd . -c lda must be .ge. 2*ml + mu + 1 . -c -c n integer -c the order of the original matrix. -c -c ml integer -c number of diagonals below the main diagonal. -c 0 .le. ml .lt. n . -c -c mu integer -c number of diagonals above the main diagonal. -c 0 .le. mu .lt. n . -c more efficient if ml .le. mu . -c on return -c -c abd an upper triangular matrix in band storage and -c the multipliers which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. -c = k if u(k,k) .eq. 0.0 . this is not an error -c condition for this subroutine, but it does -c indicate that dgbsl will divide by zero if -c called. use rcond in dgbco for a reliable -c indication of singularity. -c -c band storage -c -c if a is a band matrix, the following program segment -c will set up the input. -c -c ml = (band width below the diagonal) -c mu = (band width above the diagonal) -c m = ml + mu + 1 -c do 20 j = 1, n -c i1 = max0(1, j-mu) -c i2 = min0(n, j+ml) -c do 10 i = i1, i2 -c k = i - j + m -c abd(k,j) = a(i,j) -c 10 continue -c 20 continue -c -c this uses rows ml+1 through 2*ml+mu+1 of abd . -c in addition, the first ml rows in abd are used for -c elements generated during the triangularization. -c the total number of rows needed in abd is 2*ml+mu+1 . -c the ml+mu by ml+mu upper left triangle and the -c ml by ml lower right triangle are not referenced. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,dscal,idamax -c fortran max0,min0 -c -c internal variables -c - double precision t - integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 -c -c - m = ml + mu + 1 - info = 0 -c -c zero initial fill-in columns -c - j0 = mu + 2 - j1 = min0(n,m) - 1 - if (j1 .lt. j0) go to 30 - do 20 jz = j0, j1 - i0 = m + 1 - jz - do 10 i = i0, ml - abd(i,jz) = 0.0d0 - 10 continue - 20 continue - 30 continue - jz = j1 - ju = 0 -c -c gaussian elimination with partial pivoting -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 130 - do 120 k = 1, nm1 - kp1 = k + 1 -c -c zero next fill-in column -c - jz = jz + 1 - if (jz .gt. n) go to 50 - if (ml .lt. 1) go to 50 - do 40 i = 1, ml - abd(i,jz) = 0.0d0 - 40 continue - 50 continue -c -c find l = pivot index -c - lm = min0(ml,n-k) - l = idamax(lm+1,abd(m,k),1) + m - 1 - ipvt(k) = l + k - m -c -c zero pivot implies this column already triangularized -c - if (abd(l,k) .eq. 0.0d0) go to 100 -c -c interchange if necessary -c - if (l .eq. m) go to 60 - t = abd(l,k) - abd(l,k) = abd(m,k) - abd(m,k) = t - 60 continue -c -c compute multipliers -c - t = -1.0d0/abd(m,k) - call dscal(lm,t,abd(m+1,k),1) -c -c row elimination with column indexing -c - ju = min0(max0(ju,mu+ipvt(k)),n) - mm = m - if (ju .lt. kp1) go to 90 - do 80 j = kp1, ju - l = l - 1 - mm = mm - 1 - t = abd(l,j) - if (l .eq. mm) go to 70 - abd(l,j) = abd(mm,j) - abd(mm,j) = t - 70 continue - call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) - 80 continue - 90 continue - go to 110 - 100 continue - info = k - 110 continue - 120 continue - 130 continue - ipvt(n) = n - if (abd(m,n) .eq. 0.0d0) info = n - return - end diff --git a/Cantera/ext/math/dgbfa.f b/Cantera/ext/math/dgbfa.f deleted file mode 100644 index c26e6f579..000000000 --- a/Cantera/ext/math/dgbfa.f +++ /dev/null @@ -1,174 +0,0 @@ - subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) - integer lda,n,ml,mu,ipvt(1),info - double precision abd(lda,1) -c -c dgbfa factors a double precision band matrix by elimination. -c -c dgbfa is usually called by dgbco, but it can be called -c directly with a saving in time if rcond is not needed. -c -c on entry -c -c abd double precision(lda, n) -c contains the matrix in band storage. the columns -c of the matrix are stored in the columns of abd and -c the diagonals of the matrix are stored in rows -c ml+1 through 2*ml+mu+1 of abd . -c see the comments below for details. -c -c lda integer -c the leading dimension of the array abd . -c lda must be .ge. 2*ml + mu + 1 . -c -c n integer -c the order of the original matrix. -c -c ml integer -c number of diagonals below the main diagonal. -c 0 .le. ml .lt. n . -c -c mu integer -c number of diagonals above the main diagonal. -c 0 .le. mu .lt. n . -c more efficient if ml .le. mu . -c on return -c -c abd an upper triangular matrix in band storage and -c the multipliers which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. -c = k if u(k,k) .eq. 0.0 . this is not an error -c condition for this subroutine, but it does -c indicate that dgbsl will divide by zero if -c called. use rcond in dgbco for a reliable -c indication of singularity. -c -c band storage -c -c if a is a band matrix, the following program segment -c will set up the input. -c -c ml = (band width below the diagonal) -c mu = (band width above the diagonal) -c m = ml + mu + 1 -c do 20 j = 1, n -c i1 = max0(1, j-mu) -c i2 = min0(n, j+ml) -c do 10 i = i1, i2 -c k = i - j + m -c abd(k,j) = a(i,j) -c 10 continue -c 20 continue -c -c this uses rows ml+1 through 2*ml+mu+1 of abd . -c in addition, the first ml rows in abd are used for -c elements generated during the triangularization. -c the total number of rows needed in abd is 2*ml+mu+1 . -c the ml+mu by ml+mu upper left triangle and the -c ml by ml lower right triangle are not referenced. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,dscal,idamax -c fortran max0,min0 -c -c internal variables -c - double precision t - integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 -c -c - m = ml + mu + 1 - info = 0 -c -c zero initial fill-in columns -c - j0 = mu + 2 - j1 = min0(n,m) - 1 - if (j1 .lt. j0) go to 30 - do 20 jz = j0, j1 - i0 = m + 1 - jz - do 10 i = i0, ml - abd(i,jz) = 0.0d0 - 10 continue - 20 continue - 30 continue - jz = j1 - ju = 0 -c -c gaussian elimination with partial pivoting -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 130 - do 120 k = 1, nm1 - kp1 = k + 1 -c -c zero next fill-in column -c - jz = jz + 1 - if (jz .gt. n) go to 50 - if (ml .lt. 1) go to 50 - do 40 i = 1, ml - abd(i,jz) = 0.0d0 - 40 continue - 50 continue -c -c find l = pivot index -c - lm = min0(ml,n-k) - l = idamax(lm+1,abd(m,k),1) + m - 1 - ipvt(k) = l + k - m -c -c zero pivot implies this column already triangularized -c - if (abd(l,k) .eq. 0.0d0) go to 100 -c -c interchange if necessary -c - if (l .eq. m) go to 60 - t = abd(l,k) - abd(l,k) = abd(m,k) - abd(m,k) = t - 60 continue -c -c compute multipliers -c - t = -1.0d0/abd(m,k) - call dscal(lm,t,abd(m+1,k),1) -c -c row elimination with column indexing -c - ju = min0(max0(ju,mu+ipvt(k)),n) - mm = m - if (ju .lt. kp1) go to 90 - do 80 j = kp1, ju - l = l - 1 - mm = mm - 1 - t = abd(l,j) - if (l .eq. mm) go to 70 - abd(l,j) = abd(mm,j) - abd(mm,j) = t - 70 continue - call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) - 80 continue - 90 continue - go to 110 - 100 continue - info = k - 110 continue - 120 continue - 130 continue - ipvt(n) = n - if (abd(m,n) .eq. 0.0d0) info = n - return - end diff --git a/Cantera/ext/math/dgbsl.f b/Cantera/ext/math/dgbsl.f deleted file mode 100644 index 1b1b6ed54..000000000 --- a/Cantera/ext/math/dgbsl.f +++ /dev/null @@ -1,135 +0,0 @@ - subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job) - integer lda,n,ml,mu,ipvt(1),job - double precision abd(lda,1),b(1) -c -c dgbsl solves the double precision band system -c a * x = b or trans(a) * x = b -c using the factors computed by dgbco or dgbfa. -c -c on entry -c -c abd double precision(lda, n) -c the output from dgbco or dgbfa. -c -c lda integer -c the leading dimension of the array abd . -c -c n integer -c the order of the original matrix. -c -c ml integer -c number of diagonals below the main diagonal. -c -c mu integer -c number of diagonals above the main diagonal. -c -c ipvt integer(n) -c the pivot vector from dgbco or dgbfa. -c -c b double precision(n) -c the right hand side vector. -c -c job integer -c = 0 to solve a*x = b , -c = nonzero to solve trans(a)*x = b , where -c trans(a) is the transpose. -c -c on return -c -c b the solution vector x . -c -c error condition -c -c a division by zero will occur if the input factor contains a -c zero on the diagonal. technically this indicates singularity -c but it is often caused by improper arguments or improper -c setting of lda . it will not occur if the subroutines are -c called correctly and if dgbco has set rcond .gt. 0.0 -c or dgbfa has set info .eq. 0 . -c -c to compute inverse(a) * c where c is a matrix -c with p columns -c call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) -c if (rcond is too small) go to ... -c do 10 j = 1, p -c call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) -c 10 continue -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,ddot -c fortran min0 -c -c internal variables -c - double precision ddot,t - integer k,kb,l,la,lb,lm,m,nm1 -c - m = mu + ml + 1 - nm1 = n - 1 - if (job .ne. 0) go to 50 -c -c job = 0 , solve a * x = b -c first solve l*y = b -c - if (ml .eq. 0) go to 30 - if (nm1 .lt. 1) go to 30 - do 20 k = 1, nm1 - lm = min0(ml,n-k) - l = ipvt(k) - t = b(l) - if (l .eq. k) go to 10 - b(l) = b(k) - b(k) = t - 10 continue - call daxpy(lm,t,abd(m+1,k),1,b(k+1),1) - 20 continue - 30 continue -c -c now solve u*x = y -c - do 40 kb = 1, n - k = n + 1 - kb - b(k) = b(k)/abd(m,k) - lm = min0(k,m) - 1 - la = m - lm - lb = k - lm - t = -b(k) - call daxpy(lm,t,abd(la,k),1,b(lb),1) - 40 continue - go to 100 - 50 continue -c -c job = nonzero, solve trans(a) * x = b -c first solve trans(u)*y = b -c - do 60 k = 1, n - lm = min0(k,m) - 1 - la = m - lm - lb = k - lm - t = ddot(lm,abd(la,k),1,b(lb),1) - b(k) = (b(k) - t)/abd(m,k) - 60 continue -c -c now solve trans(l)*x = y -c - if (ml .eq. 0) go to 90 - if (nm1 .lt. 1) go to 90 - do 80 kb = 1, nm1 - k = n - kb - lm = min0(ml,n-k) - b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1) - l = ipvt(k) - if (l .eq. k) go to 70 - t = b(l) - b(l) = b(k) - b(k) = t - 70 continue - 80 continue - 90 continue - 100 continue - return - end diff --git a/Cantera/ext/math/dgefa.f b/Cantera/ext/math/dgefa.f deleted file mode 100644 index 14f266a9c..000000000 --- a/Cantera/ext/math/dgefa.f +++ /dev/null @@ -1,104 +0,0 @@ - - subroutine dgefa(a,lda,n,ipvt,info) - integer lda,n,ipvt(1),info - double precision a(lda,1) -c -c dgefa factors a double precision matrix by gaussian elimination. -c -c dgefa is usually called by dgeco, but it can be called -c directly with a saving in time if rcond is not needed. -c (time for dgeco) = (1 + 9/n)*(time for dgefa) . -c -c on entry -c -c a double precision(lda, n) -c the matrix to be factored. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c on return -c -c a an upper triangular matrix and the multipliers -c which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. -c = k if u(k,k) .eq. 0.0 . this is not an error -c condition for this subroutine, but it does -c indicate that dgesl or dgedi will divide by zero -c if called. use rcond in dgeco for a reliable -c indication of singularity. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,dscal,idamax -c -c internal variables -c - double precision t - integer idamax,j,k,kp1,l,nm1 -c -c -c gaussian elimination with partial pivoting -c - info = 0 - nm1 = n - 1 - if (nm1 .lt. 1) go to 70 - do 60 k = 1, nm1 - kp1 = k + 1 -c -c find l = pivot index -c - l = idamax(n-k+1,a(k,k),1) + k - 1 - ipvt(k) = l -c -c zero pivot implies this column already triangularized -c - if (a(l,k) .eq. 0.0d0) go to 40 -c -c interchange if necessary -c - if (l .eq. k) go to 10 - t = a(l,k) - a(l,k) = a(k,k) - a(k,k) = t - 10 continue -c -c compute multipliers -c - t = -1.0d0/a(k,k) - call dscal(n-k,t,a(k+1,k),1) -c -c row elimination with column indexing -c - do 30 j = kp1, n - t = a(l,j) - if (l .eq. k) go to 20 - a(l,j) = a(k,j) - a(k,j) = t - 20 continue - call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) - 30 continue - go to 50 - 40 continue - info = k - 50 continue - 60 continue - 70 continue - ipvt(n) = n - if (a(n,n) .eq. 0.0d0) info = n - return - end diff --git a/Cantera/ext/math/dgesl.f b/Cantera/ext/math/dgesl.f deleted file mode 100644 index 093fa5182..000000000 --- a/Cantera/ext/math/dgesl.f +++ /dev/null @@ -1,117 +0,0 @@ - subroutine dgesl(a,lda,n,ipvt,b,job) - integer lda,n,ipvt(1),job - double precision a(lda,1),b(1) -c -c dgesl solves the double precision system -c a * x = b or trans(a) * x = b -c using the factors computed by dgeco or dgefa. -c -c on entry -c -c a double precision(lda, n) -c the output from dgeco or dgefa. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c ipvt integer(n) -c the pivot vector from dgeco or dgefa. -c -c b double precision(n) -c the right hand side vector. -c -c job integer -c = 0 to solve a*x = b , -c = nonzero to solve trans(a)*x = b where -c trans(a) is the transpose. -c -c on return -c -c b the solution vector x . -c -c error condition -c -c a division by zero will occur if the input factor contains a -c zero on the diagonal. technically this indicates singularity -c but it is often caused by improper arguments or improper -c setting of lda . it will not occur if the subroutines are -c called correctly and if dgeco has set rcond .gt. 0.0 -c or dgefa has set info .eq. 0 . -c -c to compute inverse(a) * c where c is a matrix -c with p columns -c call dgeco(a,lda,n,ipvt,rcond,z) -c if (rcond is too small) go to ... -c do 10 j = 1, p -c call dgesl(a,lda,n,ipvt,c(1,j),0) -c 10 continue -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,ddot -c -c internal variables -c - double precision ddot,t - integer k,kb,l,nm1 -c - nm1 = n - 1 - if (job .ne. 0) go to 50 -c -c job = 0 , solve a * x = b -c first solve l*y = b -c - if (nm1 .lt. 1) go to 30 - do 20 k = 1, nm1 - l = ipvt(k) - t = b(l) - if (l .eq. k) go to 10 - b(l) = b(k) - b(k) = t - 10 continue - call daxpy(n-k,t,a(k+1,k),1,b(k+1),1) - 20 continue - 30 continue -c -c now solve u*x = y -c - do 40 kb = 1, n - k = n + 1 - kb - b(k) = b(k)/a(k,k) - t = -b(k) - call daxpy(k-1,t,a(1,k),1,b(1),1) - 40 continue - go to 100 - 50 continue -c -c job = nonzero, solve trans(a) * x = b -c first solve trans(u)*y = b -c - do 60 k = 1, n - t = ddot(k-1,a(1,k),1,b(1),1) - b(k) = (b(k) - t)/a(k,k) - 60 continue -c -c now solve trans(l)*x = y -c - if (nm1 .lt. 1) go to 90 - do 80 kb = 1, nm1 - k = n - kb - b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1) - l = ipvt(k) - if (l .eq. k) go to 70 - t = b(l) - b(l) = b(k) - b(k) = t - 70 continue - 80 continue - 90 continue - 100 continue - return - end diff --git a/Cantera/ext/math/dp1vlu.f b/Cantera/ext/math/dp1vlu.f deleted file mode 100644 index 1af92d209..000000000 --- a/Cantera/ext/math/dp1vlu.f +++ /dev/null @@ -1,151 +0,0 @@ -*DECK DP1VLU - SUBROUTINE DP1VLU (L, NDER, X, YFIT, YP, A) -C***BEGIN PROLOGUE DP1VLU -C***PURPOSE Use the coefficients generated by DPOLFT to evaluate the -C polynomial fit of degree L, along with the first NDER of -C its derivatives, at a specified point. -C***LIBRARY SLATEC -C***CATEGORY K6 -C***TYPE DOUBLE PRECISION (PVALUE-S, DP1VLU-D) -C***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C The subroutine DP1VLU uses the coefficients generated by DPOLFT -C to evaluate the polynomial fit of degree L , along with the first -C NDER of its derivatives, at a specified point. Computationally -C stable recurrence relations are used to perform this task. -C -C The parameters for DP1VLU are -C -C Input -- ALL TYPE REAL variables are DOUBLE PRECISION -C L - the degree of polynomial to be evaluated. L may be -C any non-negative integer which is less than or equal -C to NDEG , the highest degree polynomial provided -C by DPOLFT . -C NDER - the number of derivatives to be evaluated. NDER -C may be 0 or any positive value. If NDER is less -C than 0, it will be treated as 0. -C X - the argument at which the polynomial and its -C derivatives are to be evaluated. -C A - work and output array containing values from last -C call to DPOLFT . -C -C Output -- ALL TYPE REAL variables are DOUBLE PRECISION -C YFIT - value of the fitting polynomial of degree L at X -C YP - array containing the first through NDER derivatives -C of the polynomial of degree L . YP must be -C dimensioned at least NDER in the calling program. -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DP1VLU - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - INTEGER I,IC,ILO,IN,INP1,IUP,K1,K1I,K2,K3,K3P1,K3PN,K4,K4P1,K4PN, - * KC,L,LM1,LP1,MAXORD,N,NDER,NDO,NDP1,NORD - DOUBLE PRECISION A(*),CC,DIF,VAL,X,YFIT,YP(*) - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT DP1VLU - IF (L .LT. 0) GO TO 12 - NDO = MAX(NDER,0) - NDO = MIN(NDO,L) - MAXORD = A(1) + 0.5D0 - K1 = MAXORD + 1 - K2 = K1 + MAXORD - K3 = K2 + MAXORD + 2 - NORD = A(K3) + 0.5D0 - IF (L .GT. NORD) GO TO 11 - K4 = K3 + L + 1 - IF (NDER .LT. 1) GO TO 2 - DO 1 I = 1,NDER - 1 YP(I) = 0.0D0 - 2 IF (L .GE. 2) GO TO 4 - IF (L .EQ. 1) GO TO 3 -C -C L IS 0 -C - VAL = A(K2+1) - GO TO 10 -C -C L IS 1 -C - 3 CC = A(K2+2) - VAL = A(K2+1) + (X-A(2))*CC - IF (NDER .GE. 1) YP(1) = CC - GO TO 10 -C -C L IS GREATER THAN 1 -C - 4 NDP1 = NDO + 1 - K3P1 = K3 + 1 - K4P1 = K4 + 1 - LP1 = L + 1 - LM1 = L - 1 - ILO = K3 + 3 - IUP = K4 + NDP1 - DO 5 I = ILO,IUP - 5 A(I) = 0.0D0 - DIF = X - A(LP1) - KC = K2 + LP1 - A(K4P1) = A(KC) - A(K3P1) = A(KC-1) + DIF*A(K4P1) - A(K3+2) = A(K4P1) -C -C EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES -C - DO 9 I = 1,LM1 - 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 .LE. 0) GO TO 8 - DO 6 N = 1,NDO - K3PN = K3P1 + N - K4PN = K4P1 + N - 6 YP(N) = DIF*A(K3PN) + N*A(K3PN-1) - A(K1I)*A(K4PN) -C -C SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS -C - DO 7 N = 1,NDO - K3PN = K3P1 + N - K4PN = K4P1 + N - A(K4PN) = A(K3PN) - 7 A(K3PN) = YP(N) - 8 A(K4P1) = A(K3P1) - 9 A(K3P1) = VAL -C -C NORMAL RETURN OR ABORT DUE TO ERROR -C - 10 YFIT = VAL - RETURN -C - 11 WRITE (XERN1, '(I8)') L - WRITE (XERN2, '(I8)') NORD - CALL XERMSG ('SLATEC', 'DP1VLU', - * 'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 // - * ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 // - * ', COMPUTED BY DPOLFT -- EXECUTION TERMINATED.', 8, 2) - RETURN -C - 12 CALL XERMSG ('SLATEC', 'DP1VLU', - + 'INVALID INPUT PARAMETER. ORDER OF POLYNOMIAL EVALUATION ' // - + 'REQUESTED IS NEGATIVE.', 2, 2) - RETURN - END diff --git a/Cantera/ext/math/dpcoef.f b/Cantera/ext/math/dpcoef.f deleted file mode 100644 index 074a3426f..000000000 --- a/Cantera/ext/math/dpcoef.f +++ /dev/null @@ -1,78 +0,0 @@ -*DECK DPCOEF - SUBROUTINE DPCOEF (L, C, TC, A) -C***BEGIN PROLOGUE DPCOEF -C***PURPOSE Convert the DPOLFT coefficients to Taylor series form. -C***LIBRARY SLATEC -C***CATEGORY K1A1A2 -C***TYPE DOUBLE PRECISION (PCOEF-S, DPCOEF-D) -C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C DPOLFT computes the least squares polynomial fit of degree L as -C a sum of orthogonal polynomials. DPCOEF changes this fit to its -C Taylor expansion about any point C , i.e. writes the polynomial -C as a sum of powers of (X-C). Taking C=0. gives the polynomial -C in powers of X, but a suitable non-zero C often leads to -C polynomials which are better scaled and more accurately evaluated. -C -C The parameters for DPCOEF are -C -C INPUT -- All TYPE REAL variables are DOUBLE PRECISION -C L - Indicates the degree of polynomial to be changed to -C its Taylor expansion. To obtain the Taylor -C coefficients in reverse order, input L as the -C negative of the degree desired. The absolute value -C of L must be less than or equal to NDEG, the highest -C degree polynomial fitted by DPOLFT . -C C - The point about which the Taylor expansion is to be -C made. -C A - Work and output array containing values from last -C call to DPOLFT . -C -C OUTPUT -- All TYPE REAL variables are DOUBLE PRECISION -C TC - Vector containing the first LL+1 Taylor coefficients -C where LL=ABS(L). If L.GT.0 , the coefficients are -C in the usual Taylor series order, i.e. -C P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N -C If L .LT. 0, the coefficients are in reverse order, -C i.e. -C P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED DP1VLU -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPCOEF -C - INTEGER I,L,LL,LLP1,LLP2,NEW,NR - DOUBLE PRECISION A(*),C,FAC,SAVE,TC(*) -C***FIRST EXECUTABLE STATEMENT DPCOEF - LL = ABS(L) - LLP1 = LL + 1 - CALL DP1VLU (LL,LL,C,TC(1),TC(2),A) - IF (LL .LT. 2) GO TO 2 - FAC = 1.0D0 - DO 1 I = 3,LLP1 - FAC = FAC*(I-1) - 1 TC(I) = TC(I)/FAC - 2 IF (L .GE. 0) GO TO 4 - NR = LLP1/2 - LLP2 = LL + 2 - DO 3 I = 1,NR - SAVE = TC(I) - NEW = LLP2 - I - TC(I) = TC(NEW) - 3 TC(NEW) = SAVE - 4 RETURN - END diff --git a/Cantera/ext/math/dpolft.f b/Cantera/ext/math/dpolft.f deleted file mode 100644 index bbebb3dbd..000000000 --- a/Cantera/ext/math/dpolft.f +++ /dev/null @@ -1,364 +0,0 @@ -*DECK DPOLFT - SUBROUTINE DPOLFT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A) -C***BEGIN PROLOGUE DPOLFT -C***PURPOSE Fit discrete data in a least squares sense by polynomials -C in one variable. -C***LIBRARY SLATEC -C***CATEGORY K1A1A2 -C***TYPE DOUBLE PRECISION (POLFIT-S, DPOLFT-D) -C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C Huddleston, R. E., (SNLL) -C***DESCRIPTION -C -C Abstract -C -C Given a collection of points X(I) and a set of values Y(I) which -C correspond to some function or measurement at each of the X(I), -C subroutine DPOLFT computes the weighted least-squares polynomial -C fits of all degrees up to some degree either specified by the user -C or determined by the routine. The fits thus obtained are in -C orthogonal polynomial form. Subroutine DP1VLU may then be -C called to evaluate the fitted polynomials and any of their -C derivatives at any point. The subroutine DPCOEF may be used to -C express the polynomial fits as powers of (X-C) for any specified -C point C. -C -C The parameters for DPOLFT are -C -C Input -- All TYPE REAL variables are DOUBLE PRECISION -C N - the number of data points. The arrays X, Y and W -C must be dimensioned at least N (N .GE. 1). -C X - array of values of the independent variable. These -C values may appear in any order and need not all be -C distinct. -C Y - array of corresponding function values. -C W - array of positive values to be used as weights. If -C W(1) is negative, DPOLFT will set all the weights -C to 1.0, which means unweighted least squares error -C will be minimized. To minimize relative error, the -C user should set the weights to: W(I) = 1.0/Y(I)**2, -C I = 1,...,N . -C MAXDEG - maximum degree to be allowed for polynomial fit. -C MAXDEG may be any non-negative integer less than N. -C Note -- MAXDEG cannot be equal to N-1 when a -C statistical test is to be used for degree selection, -C i.e., when input value of EPS is negative. -C EPS - specifies the criterion to be used in determining -C the degree of fit to be computed. -C (1) If EPS is input negative, DPOLFT chooses the -C degree based on a statistical F test of -C significance. One of three possible -C significance levels will be used: .01, .05 or -C .10. If EPS=-1.0 , the routine will -C automatically select one of these levels based -C on the number of data points and the maximum -C degree to be considered. If EPS is input as -C -.01, -.05, or -.10, a significance level of -C .01, .05, or .10, respectively, will be used. -C (2) If EPS is set to 0., DPOLFT computes the -C polynomials of degrees 0 through MAXDEG . -C (3) If EPS is input positive, EPS is the RMS -C error tolerance which must be satisfied by the -C fitted polynomial. DPOLFT will increase the -C degree of fit until this criterion is met or -C until the maximum degree is reached. -C -C Output -- All TYPE REAL variables are DOUBLE PRECISION -C NDEG - degree of the highest degree fit computed. -C EPS - RMS error of the polynomial of degree NDEG . -C R - vector of dimension at least NDEG containing values -C of the fit of degree NDEG at each of the X(I) . -C Except when the statistical test is used, these -C values are more accurate than results from subroutine -C DP1VLU normally are. -C IERR - error flag with the following possible values. -C 1 -- indicates normal execution, i.e., either -C (1) the input value of EPS was negative, and the -C computed polynomial fit of degree NDEG -C satisfies the specified F test, or -C (2) the input value of EPS was 0., and the fits of -C all degrees up to MAXDEG are complete, or -C (3) the input value of EPS was positive, and the -C polynomial of degree NDEG satisfies the RMS -C error requirement. -C 2 -- invalid input parameter. At least one of the input -C parameters has an illegal value and must be corrected -C before DPOLFT can proceed. Valid input results -C when the following restrictions are observed -C N .GE. 1 -C 0 .LE. MAXDEG .LE. N-1 for EPS .GE. 0. -C 0 .LE. MAXDEG .LE. N-2 for EPS .LT. 0. -C W(1)=-1.0 or W(I) .GT. 0., I=1,...,N . -C 3 -- cannot satisfy the RMS error requirement with a -C polynomial of degree no greater than MAXDEG . Best -C fit found is of degree MAXDEG . -C 4 -- cannot satisfy the test for significance using -C current value of MAXDEG . Statistically, the -C best fit found is of order NORD . (In this case, -C NDEG will have one of the values: MAXDEG-2, -C MAXDEG-1, or MAXDEG). Using a higher value of -C MAXDEG may result in passing the test. -C A - work and output array having at least 3N+3MAXDEG+3 -C locations -C -C Note - DPOLFT calculates all fits of degrees up to and including -C NDEG . Any or all of these fits can be evaluated or -C expressed as powers of (X-C) using DP1VLU and DPCOEF -C after just one call to DPOLFT . -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED DP1VLU, XERMSG -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900911 Added variable YP to DOUBLE PRECISION declaration. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920527 Corrected erroneous statements in DESCRIPTION. (WRB) -C***END PROLOGUE DPOLFT - INTEGER I,IDEGF,IERR,J,JP1,JPAS,K1,K1PJ,K2,K2PJ,K3,K3PI,K4, - * K4PI,K5,K5PI,KSIG,M,MAXDEG,MOP1,NDEG,NDER,NFAIL - DOUBLE PRECISION TEMD1,TEMD2 - DOUBLE PRECISION A(*),DEGF,DEN,EPS,ETST,F,FCRIT,R(*),SIG,SIGJ, - * SIGJM1,SIGPAS,TEMP,X(*),XM,Y(*),YP,W(*),W1,W11 - DOUBLE PRECISION CO(4,3) -c SAVE CO -c DATA CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2), -c 1 CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3), -c 2 CO(4,3)/-13.086850D0,-2.4648165D0,-3.3846535D0,-1.2973162D0, -c 3 -3.3381146D0,-1.7812271D0,-3.2578406D0,-1.6589279D0, -c 4 -1.6282703D0,-1.3152745D0,-3.2640179D0,-1.9829776D0/ -C***FIRST EXECUTABLE STATEMENT DPOLFT - -c write(*,*) 'DPOLFT n = ',n -c do ii = 1,n -c write(*,*) x(ii), y(ii), w(ii) -c end do -c write(*,*) ' maxdeg, eps = ',maxdeg,eps - - M = ABS(N) - IF (M .EQ. 0) GO TO 30 - IF (MAXDEG .LT. 0) GO TO 30 - A(1) = MAXDEG - MOP1 = MAXDEG + 1 - IF (M .LT. MOP1) GO TO 30 - IF (EPS .LT. 0.0D0 .AND. M .EQ. MOP1) GO TO 30 - XM = M - ETST = EPS*EPS*XM - IF (W(1) .LT. 0.0D0) GO TO 2 - DO 1 I = 1,M - IF (W(I) .LE. 0.0D0) GO TO 30 - 1 CONTINUE - GO TO 4 - 2 DO 3 I = 1,M - 3 W(I) = 1.0D0 - 4 IF (EPS .GE. 0.0D0) GO TO 8 -C -C DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR -C CHOOSING DEGREE OF POLYNOMIAL FIT -C - IF (EPS .GT. (-.55D0)) GO TO 5 - IDEGF = M - MAXDEG - 1 - KSIG = 1 - IF (IDEGF .LT. 10) KSIG = 2 - IF (IDEGF .LT. 5) KSIG = 3 - GO TO 8 - 5 KSIG = 1 - IF (EPS .LT. (-.03D0)) KSIG = 2 - IF (EPS .LT. (-.07D0)) KSIG = 3 -C -C INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING -C - 8 K1 = MAXDEG + 1 - K2 = K1 + MAXDEG - K3 = K2 + MAXDEG + 2 - K4 = K3 + M - K5 = K4 + M - DO 9 I = 2,K4 - 9 A(I) = 0.0D0 - W11 = 0.0D0 - IF (N .LT. 0) GO TO 11 -C -C UNCONSTRAINED CASE -C - DO 10 I = 1,M - K4PI = K4 + I - A(K4PI) = 1.0D0 - 10 W11 = W11 + W(I) - GO TO 13 -C -C CONSTRAINED CASE -C - 11 DO 12 I = 1,M - K4PI = K4 + I - 12 W11 = W11 + W(I)*A(K4PI)**2 -C -C COMPUTE FIT OF DEGREE ZERO -C - 13 TEMD1 = 0.0D0 - DO 14 I = 1,M - K4PI = K4 + I - TEMD1 = TEMD1 + W(I)*Y(I)*A(K4PI) - 14 CONTINUE - TEMD1 = TEMD1/W11 - A(K2+1) = TEMD1 - SIGJ = 0.0D0 - DO 15 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = TEMD1*A(K4PI) - R(I) = TEMD2 - A(K5PI) = TEMD2 - R(I) - 15 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 - J = 0 -C -C SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION -C - IF (EPS) 24,26,27 -C -C INCREMENT DEGREE -C - 16 J = J + 1 - JP1 = J + 1 - K1PJ = K1 + J - K2PJ = K2 + J - SIGJM1 = SIGJ -C -C COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 -C - IF (J .GT. 1) A(K1PJ) = W11/W1 -C -C COMPUTE NEW A COEFFICIENT -C - TEMD1 = 0.0D0 - DO 18 I = 1,M - K4PI = K4 + I - TEMD2 = A(K4PI) - TEMD1 = TEMD1 + X(I)*W(I)*TEMD2*TEMD2 - 18 CONTINUE - A(JP1) = TEMD1/W11 -C -C EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS -C - W1 = W11 - W11 = 0.0D0 - DO 19 I = 1,M - K3PI = K3 + I - K4PI = K4 + I - TEMP = A(K3PI) - A(K3PI) = A(K4PI) - A(K4PI) = (X(I)-A(JP1))*A(K3PI) - A(K1PJ)*TEMP - 19 W11 = W11 + W(I)*A(K4PI)**2 -C -C GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE -C PRECISION -C - TEMD1 = 0.0D0 - DO 20 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = W(I)*((Y(I)-R(I))-A(K5PI))*A(K4PI) - 20 TEMD1 = TEMD1 + TEMD2 - TEMD1 = TEMD1/W11 - A(K2PJ+1) = TEMD1 -C -C UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND -C ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE -C COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, -C THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST -C SIGNIFICANT BITS ARE IN A(K5PI) . -C - SIGJ = 0.0D0 - DO 21 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = R(I) + A(K5PI) + TEMD1*A(K4PI) - R(I) = TEMD2 - A(K5PI) = TEMD2 - R(I) - 21 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 -C -C SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE -C MAXDEG HAS BEEN REACHED -C - IF (EPS) 23,26,27 -C -C COMPUTE F STATISTICS (INPUT EPS .LT. 0.) -C - 23 IF (SIGJ .EQ. 0.0D0) GO TO 29 - DEGF = M - J - 1 - DEN = (CO(4,KSIG)*DEGF + 1.0D0)*DEGF - FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN - FCRIT = FCRIT*FCRIT - F = (SIGJM1 - SIGJ)*DEGF/SIGJ - IF (F .LT. FCRIT) GO TO 25 -C -C POLYNOMIAL OF DEGREE J SATISFIES F TEST -C - 24 SIGPAS = SIGJ - JPAS = J - NFAIL = 0 - IF (MAXDEG .EQ. J) GO TO 32 - GO TO 16 -C -C POLYNOMIAL OF DEGREE J FAILS F TEST. IF THERE HAVE BEEN THREE -C SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. -C - 25 NFAIL = NFAIL + 1 - IF (NFAIL .GE. 3) GO TO 29 - IF (MAXDEG .EQ. J) GO TO 32 - GO TO 16 -C -C RAISE THE DEGREE IF DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT -C EPS = 0.) -C - 26 IF (MAXDEG .EQ. J) GO TO 28 - GO TO 16 -C -C SEE IF RMS ERROR CRITERION IS SATISFIED (INPUT EPS .GT. 0.) -C - 27 IF (SIGJ .LE. ETST) GO TO 28 - IF (MAXDEG .EQ. J) GO TO 31 - GO TO 16 -C -C RETURNS -C - 28 IERR = 1 - NDEG = J - SIG = SIGJ - GO TO 33 - 29 IERR = 1 - NDEG = JPAS - SIG = SIGPAS - GO TO 33 - 30 IERR = 2 - CALL XERMSG ('SLATEC', 'DPOLFT', 'INVALID INPUT PARAMETER.', 2, - + 1) - GO TO 37 - 31 IERR = 3 - NDEG = MAXDEG - SIG = SIGJ - GO TO 33 - 32 IERR = 4 - NDEG = JPAS - SIG = SIGPAS -C - 33 A(K3) = NDEG -C -C WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT -C ALL THE DATA POINTS IF R DOES NOT ALREADY CONTAIN THESE VALUES -C - IF(EPS .GE. 0.0 .OR. NDEG .EQ. MAXDEG) GO TO 36 - NDER = 0 - DO 35 I = 1,M - CALL DP1VLU (NDEG,NDER,X(I),R(I),YP,A) - 35 CONTINUE - 36 EPS = SQRT(SIG/XM) - 37 RETURN - END diff --git a/Cantera/ext/math/fdump.f b/Cantera/ext/math/fdump.f deleted file mode 100644 index c649f252b..000000000 --- a/Cantera/ext/math/fdump.f +++ /dev/null @@ -1,72 +0,0 @@ -*DECK FDUMP - SUBROUTINE FDUMP -C***BEGIN PROLOGUE FDUMP -C***PURPOSE Symbolic dump (should be locally written). -C***LIBRARY SLATEC (XERMSG) -C***CATEGORY R3 -C***TYPE ALL (FDUMP-A) -C***KEYWORDS ERROR, XERMSG -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C ***Note*** Machine Dependent Routine -C FDUMP is intended to be replaced by a locally written -C version which produces a symbolic dump. Failing this, -C it should be replaced by a version which prints the -C subprogram nesting list. Note that this dump must be -C printed on each of up to five files, as indicated by the -C XGETUA routine. See XSETUA and XGETUA for details. -C -C Written by Ron Jones, with SLATEC Common Math Library Subcommittee -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE FDUMP -C***FIRST EXECUTABLE STATEMENT FDUMP - RETURN - END - -c$$$ -c$$$ integer function isamax(n,sx,incx) -c$$$c -c$$$c finds the index of element having max. absolute value. -c$$$c jack dongarra, linpack, 3/11/78. -c$$$c modified 3/93 to return if incx .le. 0. -c$$$c -c$$$ real sx(1),smax -c$$$ integer i,incx,ix,n -c$$$c -c$$$ isamax = 0 -c$$$ if( n.lt.1 .or. incx.le.0 ) return -c$$$ isamax = 1 -c$$$ if(n.eq.1)return -c$$$ if(incx.eq.1)go to 20 -c$$$c -c$$$c code for increment not equal to 1 -c$$$c -c$$$ ix = 1 -c$$$ smax = abs(sx(1)) -c$$$ ix = ix + incx -c$$$ do 10 i = 2,n -c$$$ if(abs(sx(ix)).le.smax) go to 5 -c$$$ isamax = i -c$$$ smax = abs(sx(ix)) -c$$$ 5 ix = ix + incx -c$$$ 10 continue -c$$$ return -c$$$c -c$$$c code for increment equal to 1 -c$$$c -c$$$ 20 smax = abs(sx(1)) -c$$$ do 30 i = 2,n -c$$$ if(abs(sx(i)).le.smax) go to 30 -c$$$ isamax = i -c$$$ smax = abs(sx(i)) -c$$$ 30 continue -c$$$ return -c$$$ end -c$$$ diff --git a/Cantera/ext/math/gmres.h b/Cantera/ext/math/gmres.h deleted file mode 100755 index 1f6a044d5..000000000 --- a/Cantera/ext/math/gmres.h +++ /dev/null @@ -1,144 +0,0 @@ -// -*- 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/Cantera/ext/math/idamax.f b/Cantera/ext/math/idamax.f deleted file mode 100755 index eb0de47a7..000000000 --- a/Cantera/ext/math/idamax.f +++ /dev/null @@ -1,39 +0,0 @@ - - integer function idamax(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c - double precision dx(1),dmax - integer i,incx,ix,n -c - idamax = 0 - if( n.lt.1 .or. incx.le.0 ) return - idamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).le.dmax) go to 5 - idamax = i - dmax = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).le.dmax) go to 30 - idamax = i - dmax = dabs(dx(i)) - 30 continue - return - end diff --git a/Cantera/ext/math/j4save.f b/Cantera/ext/math/j4save.f deleted file mode 100644 index 46b42a7b8..000000000 --- a/Cantera/ext/math/j4save.f +++ /dev/null @@ -1,65 +0,0 @@ -*DECK J4SAVE - FUNCTION J4SAVE (IWHICH, IVALUE, ISET) -C***BEGIN PROLOGUE J4SAVE -C***SUBSIDIARY -C***PURPOSE Save or recall global variables needed by error -C handling routines. -C***LIBRARY SLATEC (XERROR) -C***TYPE INTEGER (J4SAVE-I) -C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C J4SAVE saves and recalls several global variables needed -C by the library error handling routines. -C -C Description of Parameters -C --Input-- -C IWHICH - Index of item desired. -C = 1 Refers to current error number. -C = 2 Refers to current error control flag. -C = 3 Refers to current unit number to which error -C messages are to be sent. (0 means use standard.) -C = 4 Refers to the maximum number of times any -C message is to be printed (as set by XERMAX). -C = 5 Refers to the total number of units to which -C each error message is to be written. -C = 6 Refers to the 2nd unit for error messages -C = 7 Refers to the 3rd unit for error messages -C = 8 Refers to the 4th unit for error messages -C = 9 Refers to the 5th unit for error messages -C IVALUE - The value to be set for the IWHICH-th parameter, -C if ISET is .TRUE. . -C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE -C given the value, IVALUE. If ISET=.FALSE., the -C IWHICH-th parameter will be unchanged, and IVALUE -C is a dummy parameter. -C --Output-- -C The (old) value of the IWHICH-th parameter will be returned -C in the function value, J4SAVE. -C -C***SEE ALSO XERMSG -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900205 Minor modifications to prologue. (WRB) -C 900402 Added TYPE section. (WRB) -C 910411 Added KEYWORDS section. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE J4SAVE - LOGICAL ISET - INTEGER IPARAM(9) -c SAVE IPARAM - DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ - DATA IPARAM(5)/1/ - DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ -C***FIRST EXECUTABLE STATEMENT J4SAVE - J4SAVE = IPARAM(IWHICH) - IF (ISET) IPARAM(IWHICH) = IVALUE - RETURN - END diff --git a/Cantera/ext/math/mach.cpp b/Cantera/ext/math/mach.cpp deleted file mode 100755 index 7718be97a..000000000 --- a/Cantera/ext/math/mach.cpp +++ /dev/null @@ -1,60 +0,0 @@ - - /* 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/Cantera/ext/math/mkl_cblas.h b/Cantera/ext/math/mkl_cblas.h deleted file mode 100755 index dc5b45a71..000000000 --- a/Cantera/ext/math/mkl_cblas.h +++ /dev/null @@ -1,644 +0,0 @@ -/* -// 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/Cantera/ext/math/pcoef.f b/Cantera/ext/math/pcoef.f deleted file mode 100644 index 28fe548ff..000000000 --- a/Cantera/ext/math/pcoef.f +++ /dev/null @@ -1,712 +0,0 @@ -*DECK PCOEF - SUBROUTINE PCOEF (L, C, TC, A) -C***BEGIN PROLOGUE PCOEF -C***PURPOSE Convert the POLFIT coefficients to Taylor series form. -C***LIBRARY SLATEC -C***CATEGORY K1A1A2 -C***TYPE SINGLE PRECISION (PCOEF-S, DPCOEF-D) -C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C***DESCRIPTION -C -C Written BY L. F. Shampine and S. M. Davenport. -C -C Abstract -C -C POLFIT computes the least squares polynomial fit of degree L as -C a sum of orthogonal polynomials. PCOEF changes this fit to its -C Taylor expansion about any point C , i.e. writes the polynomial -C as a sum of powers of (X-C). Taking C=0. gives the polynomial -C in powers of X, but a suitable non-zero C often leads to -C polynomials which are better scaled and more accurately evaluated. -C -C The parameters for PCOEF are -C -C INPUT -- -C L - Indicates the degree of polynomial to be changed to -C its Taylor expansion. To obtain the Taylor -C coefficients in reverse order, input L as the -C negative of the degree desired. The absolute value -C of L must be less than or equal to NDEG, the highest -C degree polynomial fitted by POLFIT . -C C - The point about which the Taylor expansion is to be -C made. -C A - Work and output array containing values from last -C call to POLFIT . -C -C OUTPUT -- -C TC - Vector containing the first LL+1 Taylor coefficients -C where LL=ABS(L). If L.GT.0 , the coefficients are -C in the usual Taylor series order, i.e. -C P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N -C If L .LT. 0, the coefficients are in reverse order, -C i.e. -C P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED PVALUE -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE PCOEF -C - DIMENSION A(*), TC(*) -C***FIRST EXECUTABLE STATEMENT PCOEF - LL = ABS(L) - LLP1 = LL + 1 - CALL PVALUE (LL,LL,C,TC(1),TC(2),A) - IF (LL .LT. 2) GO TO 2 - FAC = 1.0 - DO 1 I = 3,LLP1 - FAC = FAC*(I-1) - 1 TC(I) = TC(I)/FAC - 2 IF (L .GE. 0) GO TO 4 - NR = LLP1/2 - LLP2 = LL + 2 - DO 3 I = 1,NR - SAVE = TC(I) - NEW = LLP2 - I - TC(I) = TC(NEW) - 3 TC(NEW) = SAVE - 4 RETURN - END -c$$$ -c$$$ subroutine dscal(n,da,dx,incx) -c$$$c -c$$$c scales a vector by a constant. -c$$$c uses unrolled loops for increment equal to one. -c$$$c jack dongarra, linpack, 3/11/78. -c$$$c modified 3/93 to return if incx .le. 0. -c$$$c -c$$$ double precision da,dx(1) -c$$$ integer i,incx,m,mp1,n,nincx -c$$$c -c$$$ if( n.le.0 .or. incx.le.0 )return -c$$$ if(incx.eq.1)go to 20 -c$$$c -c$$$c code for increment not equal to 1 -c$$$c -c$$$ nincx = n*incx -c$$$ do 10 i = 1,nincx,incx -c$$$ dx(i) = da*dx(i) -c$$$ 10 continue -c$$$ return -c$$$c -c$$$c code for increment equal to 1 -c$$$c -c$$$c -c$$$c clean-up loop -c$$$c -c$$$ 20 m = mod(n,5) -c$$$ if( m .eq. 0 ) go to 40 -c$$$ do 30 i = 1,m -c$$$ dx(i) = da*dx(i) -c$$$ 30 continue -c$$$ if( n .lt. 5 ) return -c$$$ 40 mp1 = m + 1 -c$$$ do 50 i = mp1,n,5 -c$$$ dx(i) = da*dx(i) -c$$$ dx(i + 1) = da*dx(i + 1) -c$$$ dx(i + 2) = da*dx(i + 2) -c$$$ dx(i + 3) = da*dx(i + 3) -c$$$ dx(i + 4) = da*dx(i + 4) -c$$$ 50 continue -c$$$ return -c$$$ end - - subroutine dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) - integer lda,n,ml,mu,ipvt(1) - double precision abd(lda,1),z(1) - double precision rcond -c -c dgbco factors a double precision band matrix by gaussian -c elimination and estimates the condition of the matrix. -c -c if rcond is not needed, dgbfa is slightly faster. -c to solve a*x = b , follow dgbco by dgbsl. -c to compute inverse(a)*c , follow dgbco by dgbsl. -c to compute determinant(a) , follow dgbco by dgbdi. -c -c on entry -c -c abd double precision(lda, n) -c contains the matrix in band storage. the columns -c of the matrix are stored in the columns of abd and -c the diagonals of the matrix are stored in rows -c ml+1 through 2*ml+mu+1 of abd . -c see the comments below for details. -c -c lda integer -c the leading dimension of the array abd . -c lda must be .ge. 2*ml + mu + 1 . -c -c n integer -c the order of the original matrix. -c -c ml integer -c number of diagonals below the main diagonal. -c 0 .le. ml .lt. n . -c -c mu integer -c number of diagonals above the main diagonal. -c 0 .le. mu .lt. n . -c more efficient if ml .le. mu . -c -c on return -c -c abd an upper triangular matrix in band storage and -c the multipliers which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c rcond double precision -c an estimate of the reciprocal condition of a . -c for the system a*x = b , relative perturbations -c in a and b of size epsilon may cause -c relative perturbations in x of size epsilon/rcond . -c if rcond is so small that the logical expression -c 1.0 + rcond .eq. 1.0 -c is true, then a may be singular to working -c precision. in particular, rcond is zero if -c exact singularity is detected or the estimate -c underflows. -c -c z double precision(n) -c a work vector whose contents are usually unimportant. -c if a is close to a singular matrix, then z is -c an approximate null vector in the sense that -c norm(a*z) = rcond*norm(a)*norm(z) . -c -c band storage -c -c if a is a band matrix, the following program segment -c will set up the input. -c -c ml = (band width below the diagonal) -c mu = (band width above the diagonal) -c m = ml + mu + 1 -c do 20 j = 1, n -c i1 = max0(1, j-mu) -c i2 = min0(n, j+ml) -c do 10 i = i1, i2 -c k = i - j + m -c abd(k,j) = a(i,j) -c 10 continue -c 20 continue -c -c this uses rows ml+1 through 2*ml+mu+1 of abd . -c in addition, the first ml rows in abd are used for -c elements generated during the triangularization. -c the total number of rows needed in abd is 2*ml+mu+1 . -c the ml+mu by ml+mu upper left triangle and the -c ml by ml lower right triangle are not referenced. -c -c example.. if the original matrix is -c -c 11 12 13 0 0 0 -c 21 22 23 24 0 0 -c 0 32 33 34 35 0 -c 0 0 43 44 45 46 -c 0 0 0 54 55 56 -c 0 0 0 0 65 66 -c -c then n = 6, ml = 1, mu = 2, lda .ge. 5 and abd should contain -c -c * * * + + + , * = not used -c * * 13 24 35 46 , + = used for pivoting -c * 12 23 34 45 56 -c 11 22 33 44 55 66 -c 21 32 43 54 65 * -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c linpack dgbfa -c blas daxpy,ddot,dscal,dasum -c fortran dabs,dmax1,max0,min0,dsign -c -c internal variables -c - double precision ddot,ek,t,wk,wkm - double precision anorm,s,dasum,sm,ynorm - integer is,info,j,ju,k,kb,kp1,l,la,lm,lz,m,mm -c -c -c compute 1-norm of a -c - anorm = 0.0d0 - l = ml + 1 - is = l + mu - do 10 j = 1, n - anorm = dmax1(anorm,dasum(l,abd(is,j),1)) - if (is .gt. ml + 1) is = is - 1 - if (j .le. mu) l = l + 1 - if (j .ge. n - ml) l = l - 1 - 10 continue -c -c factor -c - call dgbfa(abd,lda,n,ml,mu,ipvt,info) -c -c rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) . -c estimate = norm(z)/norm(y) where a*z = y and trans(a)*y = e . -c trans(a) is the transpose of a . the components of e are -c chosen to cause maximum local growth in the elements of w where -c trans(u)*w = e . the vectors are frequently rescaled to avoid -c overflow. -c -c solve trans(u)*w = e -c - ek = 1.0d0 - do 20 j = 1, n - z(j) = 0.0d0 - 20 continue - m = ml + mu + 1 - ju = 0 - do 100 k = 1, n - if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k)) - if (dabs(ek-z(k)) .le. dabs(abd(m,k))) go to 30 - s = dabs(abd(m,k))/dabs(ek-z(k)) - call dscal(n,s,z,1) - ek = s*ek - 30 continue - wk = ek - z(k) - wkm = -ek - z(k) - s = dabs(wk) - sm = dabs(wkm) - if (abd(m,k) .eq. 0.0d0) go to 40 - wk = wk/abd(m,k) - wkm = wkm/abd(m,k) - go to 50 - 40 continue - wk = 1.0d0 - wkm = 1.0d0 - 50 continue - kp1 = k + 1 - ju = min0(max0(ju,mu+ipvt(k)),n) - mm = m - if (kp1 .gt. ju) go to 90 - do 60 j = kp1, ju - mm = mm - 1 - sm = sm + dabs(z(j)+wkm*abd(mm,j)) - z(j) = z(j) + wk*abd(mm,j) - s = s + dabs(z(j)) - 60 continue - if (s .ge. sm) go to 80 - t = wkm - wk - wk = wkm - mm = m - do 70 j = kp1, ju - mm = mm - 1 - z(j) = z(j) + t*abd(mm,j) - 70 continue - 80 continue - 90 continue - z(k) = wk - 100 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) -c -c solve trans(l)*y = w -c - do 120 kb = 1, n - k = n + 1 - kb - lm = min0(ml,n-k) - if (k .lt. n) z(k) = z(k) + ddot(lm,abd(m+1,k),1,z(k+1),1) - if (dabs(z(k)) .le. 1.0d0) go to 110 - s = 1.0d0/dabs(z(k)) - call dscal(n,s,z,1) - 110 continue - l = ipvt(k) - t = z(l) - z(l) = z(k) - z(k) = t - 120 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) -c - ynorm = 1.0d0 -c -c solve l*v = y -c - do 140 k = 1, n - l = ipvt(k) - t = z(l) - z(l) = z(k) - z(k) = t - lm = min0(ml,n-k) - if (k .lt. n) call daxpy(lm,t,abd(m+1,k),1,z(k+1),1) - if (dabs(z(k)) .le. 1.0d0) go to 130 - s = 1.0d0/dabs(z(k)) - call dscal(n,s,z,1) - ynorm = s*ynorm - 130 continue - 140 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) - ynorm = s*ynorm -c -c solve u*z = w -c - do 160 kb = 1, n - k = n + 1 - kb - if (dabs(z(k)) .le. dabs(abd(m,k))) go to 150 - s = dabs(abd(m,k))/dabs(z(k)) - call dscal(n,s,z,1) - ynorm = s*ynorm - 150 continue - if (abd(m,k) .ne. 0.0d0) z(k) = z(k)/abd(m,k) - if (abd(m,k) .eq. 0.0d0) z(k) = 1.0d0 - lm = min0(k,m) - 1 - la = m - lm - lz = k - lm - t = -z(k) - call daxpy(lm,t,abd(la,k),1,z(lz),1) - 160 continue -c make znorm = 1.0 - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) - ynorm = s*ynorm -c - if (anorm .ne. 0.0d0) rcond = ynorm/anorm - if (anorm .eq. 0.0d0) rcond = 0.0d0 - return - end - - subroutine dgeco(a,lda,n,ipvt,rcond,z) - integer lda,n,ipvt(1) - double precision a(lda,1),z(1) - double precision rcond -c -c dgeco factors a double precision matrix by gaussian elimination -c and estimates the condition of the matrix. -c -c if rcond is not needed, dgefa is slightly faster. -c to solve a*x = b , follow dgeco by dgesl. -c to compute inverse(a)*c , follow dgeco by dgesl. -c to compute determinant(a) , follow dgeco by dgedi. -c to compute inverse(a) , follow dgeco by dgedi. -c -c on entry -c -c a double precision(lda, n) -c the matrix to be factored. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c on return -c -c a an upper triangular matrix and the multipliers -c which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c rcond double precision -c an estimate of the reciprocal condition of a . -c for the system a*x = b , relative perturbations -c in a and b of size epsilon may cause -c relative perturbations in x of size epsilon/rcond . -c if rcond is so small that the logical expression -c 1.0 + rcond .eq. 1.0 -c is true, then a may be singular to working -c precision. in particular, rcond is zero if -c exact singularity is detected or the estimate -c underflows. -c -c z double precision(n) -c a work vector whose contents are usually unimportant. -c if a is close to a singular matrix, then z is -c an approximate null vector in the sense that -c norm(a*z) = rcond*norm(a)*norm(z) . -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c linpack dgefa -c blas daxpy,ddot,dscal,dasum -c fortran dabs,dmax1,dsign -c -c internal variables -c - double precision ddot,ek,t,wk,wkm - double precision anorm,s,dasum,sm,ynorm - integer info,j,k,kb,kp1,l -c -c -c compute 1-norm of a -c - anorm = 0.0d0 - do 10 j = 1, n - anorm = dmax1(anorm,dasum(n,a(1,j),1)) - 10 continue -c -c factor -c - call dgefa(a,lda,n,ipvt,info) -c -c rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) . -c estimate = norm(z)/norm(y) where a*z = y and trans(a)*y = e . -c trans(a) is the transpose of a . the components of e are -c chosen to cause maximum local growth in the elements of w where -c trans(u)*w = e . the vectors are frequently rescaled to avoid -c overflow. -c -c solve trans(u)*w = e -c - ek = 1.0d0 - do 20 j = 1, n - z(j) = 0.0d0 - 20 continue - do 100 k = 1, n - if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k)) - if (dabs(ek-z(k)) .le. dabs(a(k,k))) go to 30 - s = dabs(a(k,k))/dabs(ek-z(k)) - call dscal(n,s,z,1) - ek = s*ek - 30 continue - wk = ek - z(k) - wkm = -ek - z(k) - s = dabs(wk) - sm = dabs(wkm) - if (a(k,k) .eq. 0.0d0) go to 40 - wk = wk/a(k,k) - wkm = wkm/a(k,k) - go to 50 - 40 continue - wk = 1.0d0 - wkm = 1.0d0 - 50 continue - kp1 = k + 1 - if (kp1 .gt. n) go to 90 - do 60 j = kp1, n - sm = sm + dabs(z(j)+wkm*a(k,j)) - z(j) = z(j) + wk*a(k,j) - s = s + dabs(z(j)) - 60 continue - if (s .ge. sm) go to 80 - t = wkm - wk - wk = wkm - do 70 j = kp1, n - z(j) = z(j) + t*a(k,j) - 70 continue - 80 continue - 90 continue - z(k) = wk - 100 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) -c -c solve trans(l)*y = w -c - do 120 kb = 1, n - k = n + 1 - kb - if (k .lt. n) z(k) = z(k) + ddot(n-k,a(k+1,k),1,z(k+1),1) - if (dabs(z(k)) .le. 1.0d0) go to 110 - s = 1.0d0/dabs(z(k)) - call dscal(n,s,z,1) - 110 continue - l = ipvt(k) - t = z(l) - z(l) = z(k) - z(k) = t - 120 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) -c - ynorm = 1.0d0 -c -c solve l*v = y -c - do 140 k = 1, n - l = ipvt(k) - t = z(l) - z(l) = z(k) - z(k) = t - if (k .lt. n) call daxpy(n-k,t,a(k+1,k),1,z(k+1),1) - if (dabs(z(k)) .le. 1.0d0) go to 130 - s = 1.0d0/dabs(z(k)) - call dscal(n,s,z,1) - ynorm = s*ynorm - 130 continue - 140 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) - ynorm = s*ynorm -c -c solve u*z = v -c - do 160 kb = 1, n - k = n + 1 - kb - if (dabs(z(k)) .le. dabs(a(k,k))) go to 150 - s = dabs(a(k,k))/dabs(z(k)) - call dscal(n,s,z,1) - ynorm = s*ynorm - 150 continue - if (a(k,k) .ne. 0.0d0) z(k) = z(k)/a(k,k) - if (a(k,k) .eq. 0.0d0) z(k) = 1.0d0 - t = -z(k) - call daxpy(k-1,t,a(1,k),1,z(1),1) - 160 continue -c make znorm = 1.0 - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) - ynorm = s*ynorm -c - if (anorm .ne. 0.0d0) rcond = ynorm/anorm - if (anorm .eq. 0.0d0) rcond = 0.0d0 - return - end - - - subroutine dgedi(a,lda,n,ipvt,det,work,job) - integer lda,n,ipvt(1),job - double precision a(lda,1),det(2),work(1) -c -c dgedi computes the determinant and inverse of a matrix -c using the factors computed by dgeco or dgefa. -c -c on entry -c -c a double precision(lda, n) -c the output from dgeco or dgefa. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c ipvt integer(n) -c the pivot vector from dgeco or dgefa. -c -c work double precision(n) -c work vector. contents destroyed. -c -c job integer -c = 11 both determinant and inverse. -c = 01 inverse only. -c = 10 determinant only. -c -c on return -c -c a inverse of original matrix if requested. -c otherwise unchanged. -c -c det double precision(2) -c determinant of original matrix if requested. -c otherwise not referenced. -c determinant = det(1) * 10.0**det(2) -c with 1.0 .le. dabs(det(1)) .lt. 10.0 -c or det(1) .eq. 0.0 . -c -c error condition -c -c a division by zero will occur if the input factor contains -c a zero on the diagonal and the inverse is requested. -c it will not occur if the subroutines are called correctly -c and if dgeco has set rcond .gt. 0.0 or dgefa has set -c info .eq. 0 . -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,dscal,dswap -c fortran dabs,mod -c -c internal variables -c - double precision t - double precision ten - integer i,j,k,kb,kp1,l,nm1 -c -c -c compute determinant -c - if (job/10 .eq. 0) go to 70 - det(1) = 1.0d0 - det(2) = 0.0d0 - ten = 10.0d0 - do 50 i = 1, n - if (ipvt(i) .ne. i) det(1) = -det(1) - det(1) = a(i,i)*det(1) -c ...exit - if (det(1) .eq. 0.0d0) go to 60 - 10 if (dabs(det(1)) .ge. 1.0d0) go to 20 - det(1) = ten*det(1) - det(2) = det(2) - 1.0d0 - go to 10 - 20 continue - 30 if (dabs(det(1)) .lt. ten) go to 40 - det(1) = det(1)/ten - det(2) = det(2) + 1.0d0 - go to 30 - 40 continue - 50 continue - 60 continue - 70 continue -c -c compute inverse(u) -c - if (mod(job,10) .eq. 0) go to 150 - do 100 k = 1, n - a(k,k) = 1.0d0/a(k,k) - t = -a(k,k) - call dscal(k-1,t,a(1,k),1) - kp1 = k + 1 - if (n .lt. kp1) go to 90 - do 80 j = kp1, n - t = a(k,j) - a(k,j) = 0.0d0 - call daxpy(k,t,a(1,k),1,a(1,j),1) - 80 continue - 90 continue - 100 continue -c -c form inverse(u)*inverse(l) -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 140 - do 130 kb = 1, nm1 - k = n - kb - kp1 = k + 1 - do 110 i = kp1, n - work(i) = a(i,k) - a(i,k) = 0.0d0 - 110 continue - do 120 j = kp1, n - t = work(j) - call daxpy(n,t,a(1,j),1,a(1,k),1) - 120 continue - l = ipvt(k) - if (l .ne. k) call dswap(n,a(1,k),1,a(1,l),1) - 130 continue - 140 continue - 150 continue - return - end - - diff --git a/Cantera/ext/math/polfit.f b/Cantera/ext/math/polfit.f deleted file mode 100644 index 08bdd98a2..000000000 --- a/Cantera/ext/math/polfit.f +++ /dev/null @@ -1,289 +0,0 @@ -*DECK POLFIT - SUBROUTINE POLFIT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A) -C***BEGIN PROLOGUE POLFIT -C***PURPOSE Fit discrete data in a least squares sense by polynomials -C in one variable. -C***LIBRARY SLATEC -C***CATEGORY K1A1A2 -C***TYPE SINGLE PRECISION (POLFIT-S, DPOLFT-D) -C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C Huddleston, R. E., (SNLL) -C***DESCRIPTION -C -C Abstract -C -C Given a collection of points X(I) and a set of values Y(I) which -C correspond to some function or measurement at each of the X(I), -C subroutine POLFIT computes the weighted least-squares polynomial -C fits of all degrees up to some degree either specified by the user -C or determined by the routine. The fits thus obtained are in -C orthogonal polynomial form. Subroutine PVALUE may then be -C called to evaluate the fitted polynomials and any of their -C derivatives at any point. The subroutine PCOEF may be used to -C express the polynomial fits as powers of (X-C) for any specified -C point C. -C -C The parameters for POLFIT are -C -C Input -- -C N - the number of data points. The arrays X, Y and W -C must be dimensioned at least N (N .GE. 1). -C X - array of values of the independent variable. These -C values may appear in any order and need not all be -C distinct. -C Y - array of corresponding function values. -C W - array of positive values to be used as weights. If -C W(1) is negative, POLFIT will set all the weights -C to 1.0, which means unweighted least squares error -C will be minimized. To minimize relative error, the -C user should set the weights to: W(I) = 1.0/Y(I)**2, -C I = 1,...,N . -C MAXDEG - maximum degree to be allowed for polynomial fit. -C MAXDEG may be any non-negative integer less than N. -C Note -- MAXDEG cannot be equal to N-1 when a -C statistical test is to be used for degree selection, -C i.e., when input value of EPS is negative. -C EPS - specifies the criterion to be used in determining -C the degree of fit to be computed. -C (1) If EPS is input negative, POLFIT chooses the -C degree based on a statistical F test of -C significance. One of three possible -C significance levels will be used: .01, .05 or -C .10. If EPS=-1.0 , the routine will -C automatically select one of these levels based -C on the number of data points and the maximum -C degree to be considered. If EPS is input as -C -.01, -.05, or -.10, a significance level of -C .01, .05, or .10, respectively, will be used. -C (2) If EPS is set to 0., POLFIT computes the -C polynomials of degrees 0 through MAXDEG . -C (3) If EPS is input positive, EPS is the RMS -C error tolerance which must be satisfied by the -C fitted polynomial. POLFIT will increase the -C degree of fit until this criterion is met or -C until the maximum degree is reached. -C -C Output -- -C NDEG - degree of the highest degree fit computed. -C EPS - RMS error of the polynomial of degree NDEG . -C R - vector of dimension at least NDEG containing values -C of the fit of degree NDEG at each of the X(I) . -C Except when the statistical test is used, these -C values are more accurate than results from subroutine -C PVALUE normally are. -C IERR - error flag with the following possible values. -C 1 -- indicates normal execution, i.e., either -C (1) the input value of EPS was negative, and the -C computed polynomial fit of degree NDEG -C satisfies the specified F test, or -C (2) the input value of EPS was 0., and the fits of -C all degrees up to MAXDEG are complete, or -C (3) the input value of EPS was positive, and the -C polynomial of degree NDEG satisfies the RMS -C error requirement. -C 2 -- invalid input parameter. At least one of the input -C parameters has an illegal value and must be corrected -C before POLFIT can proceed. Valid input results -C when the following restrictions are observed -C N .GE. 1 -C 0 .LE. MAXDEG .LE. N-1 for EPS .GE. 0. -C 0 .LE. MAXDEG .LE. N-2 for EPS .LT. 0. -C W(1)=-1.0 or W(I) .GT. 0., I=1,...,N . -C 3 -- cannot satisfy the RMS error requirement with a -C polynomial of degree no greater than MAXDEG . Best -C fit found is of degree MAXDEG . -C 4 -- cannot satisfy the test for significance using -C current value of MAXDEG . Statistically, the -C best fit found is of order NORD . (In this case, -C NDEG will have one of the values: MAXDEG-2, -C MAXDEG-1, or MAXDEG). Using a higher value of -C MAXDEG may result in passing the test. -C A - work and output array having at least 3N+3MAXDEG+3 -C locations -C -C Note - POLFIT calculates all fits of degrees up to and including -C NDEG . Any or all of these fits can be evaluated or -C expressed as powers of (X-C) using PVALUE and PCOEF -C after just one call to POLFIT . -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED PVALUE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920527 Corrected erroneous statements in DESCRIPTION. (WRB) -C***END PROLOGUE POLFIT - DOUBLE PRECISION TEMD1,TEMD2 - DIMENSION X(*), Y(*), W(*), R(*), A(*) - -c DIMENSION CO(4,3) -c SAVE CO -c DATA CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2), -c 1 CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3), -c 2 CO(4,3)/-13.086850,-2.4648165,-3.3846535,-1.2973162, -c 3 -3.3381146,-1.7812271,-3.2578406,-1.6589279, -c 4 -1.6282703,-1.3152745,-3.2640179,-1.9829776/ - -C***FIRST EXECUTABLE STATEMENT POLFIT - M = ABS(N) - IF (M .EQ. 0) GO TO 30 - IF (MAXDEG .LT. 0) GO TO 30 - A(1) = MAXDEG - MOP1 = MAXDEG + 1 - IF (M .LT. MOP1) GO TO 30 - IF (EPS .LT. 0.0 .AND. M .EQ. MOP1) GO TO 30 - - J = 0 -C -C SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION -C - IF (EPS) 24,26,27 -C -C INCREMENT DEGREE -C - 16 J = J + 1 - JP1 = J + 1 - K1PJ = K1 + J - K2PJ = K2 + J - SIGJM1 = SIGJ -C -C COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 -C - IF (J .GT. 1) A(K1PJ) = W11/W1 -C -C COMPUTE NEW A COEFFICIENT -C - TEMD1 = 0.0D0 - DO 18 I = 1,M - K4PI = K4 + I - TEMD2 = A(K4PI) - TEMD1 = TEMD1 + DBLE(X(I))*DBLE(W(I))*TEMD2*TEMD2 - 18 CONTINUE - A(JP1) = TEMD1/DBLE(W11) -C -C EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS -C - W1 = W11 - W11 = 0.0 - DO 19 I = 1,M - K3PI = K3 + I - K4PI = K4 + I - TEMP = A(K3PI) - A(K3PI) = A(K4PI) - A(K4PI) = (X(I)-A(JP1))*A(K3PI) - A(K1PJ)*TEMP - 19 W11 = W11 + W(I)*A(K4PI)**2 -C -C GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE -C PRECISION -C - TEMD1 = 0.0D0 - DO 20 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = DBLE(W(I))*DBLE((Y(I)-R(I))-A(K5PI))*DBLE(A(K4PI)) - 20 TEMD1 = TEMD1 + TEMD2 - TEMD1 = TEMD1/DBLE(W11) - A(K2PJ+1) = TEMD1 -C -C UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND -C ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE -C COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, -C THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST -C SIGNIFICANT BITS ARE IN A(K5PI) . -C - SIGJ = 0.0 - DO 21 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = DBLE(R(I)) + DBLE(A(K5PI)) + TEMD1*DBLE(A(K4PI)) - R(I) = TEMD2 - A(K5PI) = TEMD2 - DBLE(R(I)) - 21 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 -C -C SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE -C MAXDEG HAS BEEN REACHED -C - IF (EPS) 23,26,27 -C -C COMPUTE F STATISTICS (INPUT EPS .LT. 0.) -C - 23 IF (SIGJ .EQ. 0.0) GO TO 29 -c DEGF = M - J - 1 -c DEN = (CO(4,KSIG)*DEGF + 1.0)*DEGF -c FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN -c FCRIT = FCRIT*FCRIT -c F = (SIGJM1 - SIGJ)*DEGF/SIGJ -c IF (F .LT. FCRIT) GO TO 25 - -C -C POLYNOMIAL OF DEGREE J SATISFIES F TEST -C - 24 SIGPAS = SIGJ - JPAS = J - NFAIL = 0 - IF (MAXDEG .EQ. J) GO TO 32 - GO TO 16 -C -C POLYNOMIAL OF DEGREE J FAILS F TEST. IF THERE HAVE BEEN THREE -C SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. -C - 25 NFAIL = NFAIL + 1 - IF (NFAIL .GE. 3) GO TO 29 - IF (MAXDEG .EQ. J) GO TO 32 - GO TO 16 -C -C RAISE THE DEGREE IF DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT -C EPS = 0.) -C - 26 IF (MAXDEG .EQ. J) GO TO 28 - GO TO 16 -C -C SEE IF RMS ERROR CRITERION IS SATISFIED (INPUT EPS .GT. 0.) -C - 27 IF (SIGJ .LE. ETST) GO TO 28 - IF (MAXDEG .EQ. J) GO TO 31 - GO TO 16 -C -C RETURNS -C - 28 IERR = 1 - NDEG = J - SIG = SIGJ - GO TO 33 - 29 IERR = 1 - NDEG = JPAS - SIG = SIGPAS - GO TO 33 - 30 IERR = 2 -c CALL XERMSG ('SLATEC', 'POLFIT', 'INVALID INPUT PARAMETER.', 2, -c + 1) - GO TO 37 - 31 IERR = 3 - NDEG = MAXDEG - SIG = SIGJ - GO TO 33 - 32 IERR = 4 - NDEG = JPAS - SIG = SIGPAS -C - 33 A(K3) = NDEG -C -C WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT -C ALL THE DATA POINTS IF R DOES NOT ALREADY CONTAIN THESE VALUES -C - IF(EPS .GE. 0.0 .OR. NDEG .EQ. MAXDEG) GO TO 36 - NDER = 0 - DO 35 I = 1,M - CALL PVALUE (NDEG,NDER,X(I),R(I),YP,A) - 35 CONTINUE - 36 EPS = SQRT(SIG/XM) - 37 RETURN - END diff --git a/Cantera/ext/math/printstring.c b/Cantera/ext/math/printstring.c deleted file mode 100644 index f4c8cdde1..000000000 --- a/Cantera/ext/math/printstring.c +++ /dev/null @@ -1,15 +0,0 @@ -#include -#include "config.h" - -typedef int ftnlen; - -#ifdef __cplusplus -extern "C" { -#endif -void printstring_(char* s, ftnlen ls) -{ - printf("%s",s); -} -#ifdef __cplusplus -} -#endif diff --git a/Cantera/ext/math/pvalue.f b/Cantera/ext/math/pvalue.f deleted file mode 100644 index 506a76ba6..000000000 --- a/Cantera/ext/math/pvalue.f +++ /dev/null @@ -1,150 +0,0 @@ -*DECK PVALUE - SUBROUTINE PVALUE (L, NDER, X, YFIT, YP, A) -C***BEGIN PROLOGUE PVALUE -C***PURPOSE Use the coefficients generated by POLFIT to evaluate the -C polynomial fit of degree L, along with the first NDER of -C its derivatives, at a specified point. -C***LIBRARY SLATEC -C***CATEGORY K6 -C***TYPE SINGLE PRECISION (PVALUE-S, DP1VLU-D) -C***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C***DESCRIPTION -C -C Written by L. F. Shampine and S. M. Davenport. -C -C Abstract -C -C The subroutine PVALUE uses the coefficients generated by POLFIT -C to evaluate the polynomial fit of degree L , along with the first -C NDER of its derivatives, at a specified point. Computationally -C stable recurrence relations are used to perform this task. -C -C The parameters for PVALUE are -C -C Input -- -C L - the degree of polynomial to be evaluated. L may be -C any non-negative integer which is less than or equal -C to NDEG , the highest degree polynomial provided -C by POLFIT . -C NDER - the number of derivatives to be evaluated. NDER -C may be 0 or any positive value. If NDER is less -C than 0, it will be treated as 0. -C X - the argument at which the polynomial and its -C derivatives are to be evaluated. -C A - work and output array containing values from last -C call to POLFIT . -C -C Output -- -C YFIT - value of the fitting polynomial of degree L at X -C YP - array containing the first through NDER derivatives -C of the polynomial of degree L . YP must be -C dimensioned at least NDER in the calling program. -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE PVALUE - DIMENSION YP(*),A(*) - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT PVALUE - IF (L .LT. 0) GO TO 12 - NDO = MAX(NDER,0) - NDO = MIN(NDO,L) - MAXORD = A(1) + 0.5 - K1 = MAXORD + 1 - K2 = K1 + MAXORD - K3 = K2 + MAXORD + 2 - NORD = A(K3) + 0.5 - IF (L .GT. NORD) GO TO 11 - K4 = K3 + L + 1 - IF (NDER .LT. 1) GO TO 2 - DO 1 I = 1,NDER - 1 YP(I) = 0.0 - 2 IF (L .GE. 2) GO TO 4 - IF (L .EQ. 1) GO TO 3 -C -C L IS 0 -C - VAL = A(K2+1) - GO TO 10 -C -C L IS 1 -C - 3 CC = A(K2+2) - VAL = A(K2+1) + (X-A(2))*CC - IF (NDER .GE. 1) YP(1) = CC - GO TO 10 -C -C L IS GREATER THAN 1 -C - 4 NDP1 = NDO + 1 - K3P1 = K3 + 1 - K4P1 = K4 + 1 - LP1 = L + 1 - LM1 = L - 1 - ILO = K3 + 3 - IUP = K4 + NDP1 - DO 5 I = ILO,IUP - 5 A(I) = 0.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) -C -C EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES -C - DO 9 I = 1,LM1 - 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 .LE. 0) GO TO 8 - DO 6 N = 1,NDO - K3PN = K3P1 + N - K4PN = K4P1 + N - 6 YP(N) = DIF*A(K3PN) + N*A(K3PN-1) - A(K1I)*A(K4PN) -C -C SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS -C - DO 7 N = 1,NDO - K3PN = K3P1 + N - K4PN = K4P1 + N - A(K4PN) = A(K3PN) - 7 A(K3PN) = YP(N) - 8 A(K4P1) = A(K3P1) - 9 A(K3P1) = VAL -C -C NORMAL RETURN OR ABORT DUE TO ERROR -C - 10 YFIT = VAL - RETURN -C - 11 return -cWRITE (XERN1, '(I8)') L -c WRITE (XERN2, '(I8)') NORD -c CALL XERMSG ('SLATEC', 'PVALUE', -c * 'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 // -c * ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 // -c * ', COMPUTED BY POLFIT -- EXECUTION TERMINATED.', 8, 2) -c RETURN -C - 12 return -c CALL XERMSG ('SLATEC', 'PVALUE', -c + 'INVALID INPUT PARAMETER. ORDER OF POLYNOMIAL EVALUATION ' // -c + 'REQUESTED IS NEGATIVE -- EXECUTION TERMINATED.', 2, 2) -c RETURN - END diff --git a/Cantera/ext/math/xercnt.f b/Cantera/ext/math/xercnt.f deleted file mode 100644 index 06c82ab18..000000000 --- a/Cantera/ext/math/xercnt.f +++ /dev/null @@ -1,60 +0,0 @@ -*DECK XERCNT - SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) -C***BEGIN PROLOGUE XERCNT -C***SUBSIDIARY -C***PURPOSE Allow user control over handling of errors. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERCNT-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C Allows user control over handling of individual errors. -C Just after each message is recorded, but before it is -C processed any further (i.e., before it is printed or -C a decision to abort is made), a call is made to XERCNT. -C If the user has provided his own version of XERCNT, he -C can then override the value of KONTROL used in processing -C this message by redefining its value. -C KONTRL may be set to any value from -2 to 2. -C The meanings for KONTRL are the same as in XSETF, except -C that the value of KONTRL changes only for this message. -C If KONTRL is set to a value outside the range from -2 to 2, -C it will be moved back into that range. -C -C Description of Parameters -C -C --Input-- -C LIBRAR - the library that the routine is in. -C SUBROU - the subroutine that XERMSG is being called from -C MESSG - the first 20 characters of the error message. -C NERR - same as in the call to XERMSG. -C LEVEL - same as in the call to XERMSG. -C KONTRL - the current value of the control flag as set -C by a call to XSETF. -C -C --Output-- -C KONTRL - the new value of KONTRL. If KONTRL is not -C defined, it will remain at its original value. -C This changed value of control affects only -C the current occurrence of the current message. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE -C names, changed routine name from XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERCNT - CHARACTER*(*) LIBRAR, SUBROU, MESSG -C***FIRST EXECUTABLE STATEMENT XERCNT - RETURN - END diff --git a/Cantera/ext/math/xerhlt.f b/Cantera/ext/math/xerhlt.f deleted file mode 100644 index 052092940..000000000 --- a/Cantera/ext/math/xerhlt.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK XERHLT - SUBROUTINE XERHLT (MESSG) -C***BEGIN PROLOGUE XERHLT -C***SUBSIDIARY -C***PURPOSE Abort program execution and print error message. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERHLT-A) -C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C ***Note*** machine dependent routine -C XERHLT aborts the execution of the program. -C The error message causing the abort is given in the calling -C sequence, in case one needs it for printing on a dayfile, -C for example. -C -C Description of Parameters -C MESSG is as in XERMSG. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to delete length of character -C and changed routine name from XERABT to XERHLT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERHLT - CHARACTER*(*) MESSG -C***FIRST EXECUTABLE STATEMENT XERHLT - write(*,*) 'stopping...' - STOP - END diff --git a/Cantera/ext/math/xermsg.f b/Cantera/ext/math/xermsg.f deleted file mode 100755 index 46c83ec07..000000000 --- a/Cantera/ext/math/xermsg.f +++ /dev/null @@ -1,364 +0,0 @@ -*DECK XERMSG - SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) -C***BEGIN PROLOGUE XERMSG -C***PURPOSE Process error messages for SLATEC and other libraries. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERMSG-A) -C***KEYWORDS ERROR MESSAGE, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C XERMSG processes a diagnostic message in a manner determined by the -C value of LEVEL and the current value of the library error control -C flag, KONTRL. See subroutine XSETF for details. -C -C LIBRAR A character constant (or character variable) with the name -C of the library. This will be 'SLATEC' for the SLATEC -C Common Math Library. The error handling package is -C general enough to be used by many libraries -C simultaneously, so it is desirable for the routine that -C detects and reports an error to identify the library name -C as well as the routine name. -C -C SUBROU A character constant (or character variable) with the name -C of the routine that detected the error. Usually it is the -C name of the routine that is calling XERMSG. There are -C some instances where a user callable library routine calls -C lower level subsidiary routines where the error is -C detected. In such cases it may be more informative to -C supply the name of the routine the user called rather than -C the name of the subsidiary routine that detected the -C error. -C -C MESSG A character constant (or character variable) with the text -C of the error or warning message. In the example below, -C the message is a character constant that contains a -C generic message. -C -C CALL XERMSG ('SLATEC', 'MMPY', -C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', -C *3, 1) -C -C It is possible (and is sometimes desirable) to generate a -C specific message--e.g., one that contains actual numeric -C values. Specific numeric values can be converted into -C character strings using formatted WRITE statements into -C character variables. This is called standard Fortran -C internal file I/O and is exemplified in the first three -C lines of the following example. You can also catenate -C substrings of characters to construct the error message. -C Here is an example showing the use of both writing to -C an internal file and catenating character strings. -C -C CHARACTER*5 CHARN, CHARL -C WRITE (CHARN,10) N -C WRITE (CHARL,10) LDA -C 10 FORMAT(I5) -C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// -C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// -C * CHARL, 3, 1) -C -C There are two subtleties worth mentioning. One is that -C the // for character catenation is used to construct the -C error message so that no single character constant is -C continued to the next line. This avoids confusion as to -C whether there are trailing blanks at the end of the line. -C The second is that by catenating the parts of the message -C as an actual argument rather than encoding the entire -C message into one large character variable, we avoid -C having to know how long the message will be in order to -C declare an adequate length for that large character -C variable. XERMSG calls XERPRN to print the message using -C multiple lines if necessary. If the message is very long, -C XERPRN will break it into pieces of 72 characters (as -C requested by XERMSG) for printing on multiple lines. -C Also, XERMSG asks XERPRN to prefix each line with ' * ' -C so that the total line length could be 76 characters. -C Note also that XERPRN scans the error message backwards -C to ignore trailing blanks. Another feature is that -C the substring '$$' is treated as a new line sentinel -C by XERPRN. If you want to construct a multiline -C message without having to count out multiples of 72 -C characters, just use '$$' as a separator. '$$' -C obviously must occur within 72 characters of the -C start of each line to have its intended effect since -C XERPRN is asked to wrap around at 72 characters in -C addition to looking for '$$'. -C -C NERR An integer value that is chosen by the library routine's -C author. It must be in the range -99 to 999 (three -C printable digits). Each distinct error should have its -C own error number. These error numbers should be described -C in the machine readable documentation for the routine. -C The error numbers need be unique only within each routine, -C so it is reasonable for each routine to start enumerating -C errors from 1 and proceeding to the next integer. -C -C LEVEL An integer value in the range 0 to 2 that indicates the -C level (severity) of the error. Their meanings are -C -C -1 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. An attempt is made to only print this -C message once. -C -C 0 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. -C -C 1 A recoverable error. This is used even if the error is -C so serious that the routine cannot return any useful -C answer. If the user has told the error package to -C return after recoverable errors, then XERMSG will -C return to the Library routine which can then return to -C the user's routine. The user may also permit the error -C package to terminate the program upon encountering a -C recoverable error. -C -C 2 A fatal error. XERMSG will not return to its caller -C after it receives a fatal error. This level should -C hardly ever be used; it is much better to allow the -C user a chance to recover. An example of one of the few -C cases in which it is permissible to declare a level 2 -C error is a reverse communication Library routine that -C is likely to be called repeatedly until it integrates -C across some interval. If there is a serious error in -C the input such that another step cannot be taken and -C the Library routine is called again without the input -C error having been corrected by the caller, the Library -C routine will probably be called forever with improper -C input. In this case, it is reasonable to declare the -C error to be fatal. -C -C Each of the arguments to XERMSG is input; none will be modified by -C XERMSG. A routine may make multiple calls to XERMSG with warning -C level messages; however, after a call to XERMSG with a recoverable -C error, the routine should return to the user. Do not try to call -C XERMSG with a second recoverable error after the first recoverable -C error because the error package saves the error number. The user -C can retrieve this error number by calling another entry point in -C the error handling package and then clear the error number when -C recovering from the error. Calling XERMSG in succession causes the -C old error number to be overwritten by the latest error number. -C This is considered harmless for error numbers associated with -C warning messages but must not be done for error numbers of serious -C errors. After a call to XERMSG with a recoverable error, the user -C must be given a chance to call NUMXER or XERCLR to retrieve or -C clear the error number. -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE -C***REVISION HISTORY (YYMMDD) -C 880101 DATE WRITTEN -C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. -C THERE ARE TWO BASIC CHANGES. -C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO -C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES -C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS -C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE -C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER -C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY -C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE -C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. -C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE -C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE -C OF LOWER CASE. -C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. -C THE PRINCIPAL CHANGES ARE -C 1. CLARIFY COMMENTS IN THE PROLOGUES -C 2. RENAME XRPRNT TO XERPRN -C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES -C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / -C CHARACTER FOR NEW RECORDS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C CLEAN UP THE CODING. -C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN -C PREFIX. -C 891013 REVISED TO CORRECT COMMENTS. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but -C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added -C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and -C XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERMSG - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 XLIBR, XSUBR - CHARACTER*72 TEMP - CHARACTER*20 LFIRST -C***FIRST EXECUTABLE STATEMENT XERMSG - LKNTRL = J4SAVE (2, 0, .FALSE.) - MAXMES = J4SAVE (4, 0, .FALSE.) -C -C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. -C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE -C SHOULD BE PRINTED. -C -C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN -C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, -C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. -C - IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. - * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN - CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // - * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// - * 'JOB ABORT DUE TO FATAL ERROR.', 72) - CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) - CALL XERHLT (' ***XERMSG -- INVALID INPUT') - RETURN - ENDIF -C -C RECORD THE MESSAGE. -C - I = J4SAVE (1, NERR, .TRUE.) - CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) -C -C HANDLE PRINT-ONCE WARNING MESSAGES. -C - IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN -C -C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. -C - XLIBR = LIBRAR - XSUBR = SUBROU - LFIRST = MESSG - LERR = NERR - LLEVEL = LEVEL - CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) -C - LKNTRL = MAX(-2, MIN(2,LKNTRL)) - MKNTRL = ABS(LKNTRL) -C -C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS -C ZERO AND THE ERROR IS NOT FATAL. -C - IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 - IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 - IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 - IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 -C -C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A -C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) -C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG -C IS NOT ZERO. -C - IF (LKNTRL .NE. 0) THEN - TEMP(1:21) = 'MESSAGE FROM ROUTINE ' - I = MIN(LEN(SUBROU), 16) - TEMP(22:21+I) = SUBROU(1:I) - TEMP(22+I:33+I) = ' IN LIBRARY ' - LTEMP = 33 + I - I = MIN(LEN(LIBRAR), 16) - TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) - TEMP(LTEMP+I+1:LTEMP+I+1) = '.' - LTEMP = LTEMP + I + 1 - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE -C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE -C FROM EACH OF THE FOLLOWING THREE OPTIONS. -C 1. LEVEL OF THE MESSAGE -C 'INFORMATIVE MESSAGE' -C 'POTENTIALLY RECOVERABLE ERROR' -C 'FATAL ERROR' -C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE -C 'PROG CONTINUES' -C 'PROG ABORTED' -C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK -C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS -C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) -C 'TRACEBACK REQUESTED' -C 'TRACEBACK NOT REQUESTED' -C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT -C EXCEED 74 CHARACTERS. -C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. -C - IF (LKNTRL .GT. 0) THEN -C -C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. -C - IF (LEVEL .LE. 0) THEN - TEMP(1:20) = 'INFORMATIVE MESSAGE,' - LTEMP = 20 - ELSEIF (LEVEL .EQ. 1) THEN - TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' - LTEMP = 30 - ELSE - TEMP(1:12) = 'FATAL ERROR,' - LTEMP = 12 - ENDIF -C -C THEN WHETHER THE PROGRAM WILL CONTINUE. -C - IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. - * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN - TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' - LTEMP = LTEMP + 14 - ELSE - TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' - LTEMP = LTEMP + 16 - ENDIF -C -C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' - LTEMP = LTEMP + 20 - ELSE - TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' - LTEMP = LTEMP + 24 - ENDIF - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C NOW SEND OUT THE MESSAGE. -C - CALL XERPRN (' * ', -1, MESSG, 72) -C -C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A -C TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR - DO 10 I=16,22 - IF (TEMP(I:I) .NE. ' ') GO TO 20 - 10 CONTINUE -C - 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) - CALL FDUMP - ENDIF -C -C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. -C - IF (LKNTRL .NE. 0) THEN - CALL XERPRN (' * ', -1, ' ', 72) - CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) - CALL XERPRN (' ', 0, ' ', 72) - ENDIF -C -C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE -C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. -C - 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN -C -C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A -C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR -C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. -C - IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN - IF (LEVEL .EQ. 1) THEN - CALL XERPRN - * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) - ELSE - CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) - ENDIF - CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) - CALL XERHLT (' ') - ELSE - CALL XERHLT (MESSG) - ENDIF - RETURN - END diff --git a/Cantera/ext/math/xerprn.f b/Cantera/ext/math/xerprn.f deleted file mode 100644 index 24099ce47..000000000 --- a/Cantera/ext/math/xerprn.f +++ /dev/null @@ -1,230 +0,0 @@ -*DECK XERPRN - SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) -C***BEGIN PROLOGUE XERPRN -C***SUBSIDIARY -C***PURPOSE Print error messages processed by XERMSG. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERPRN-A) -C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C This routine sends one or more lines to each of the (up to five) -C logical units to which error messages are to be sent. This routine -C is called several times by XERMSG, sometimes with a single line to -C print and sometimes with a (potentially very long) message that may -C wrap around into multiple lines. -C -C PREFIX Input argument of type CHARACTER. This argument contains -C characters to be put at the beginning of each line before -C the body of the message. No more than 16 characters of -C PREFIX will be used. -C -C NPREF Input argument of type INTEGER. This argument is the number -C of characters to use from PREFIX. If it is negative, the -C intrinsic function LEN is used to determine its length. If -C it is zero, PREFIX is not used. If it exceeds 16 or if -C LEN(PREFIX) exceeds 16, only the first 16 characters will be -C used. If NPREF is positive and the length of PREFIX is less -C than NPREF, a copy of PREFIX extended with blanks to length -C NPREF will be used. -C -C MESSG Input argument of type CHARACTER. This is the text of a -C message to be printed. If it is a long message, it will be -C broken into pieces for printing on multiple lines. Each line -C will start with the appropriate prefix and be followed by a -C piece of the message. NWRAP is the number of characters per -C piece; that is, after each NWRAP characters, we break and -C start a new line. In addition the characters '$$' embedded -C in MESSG are a sentinel for a new line. The counting of -C characters up to NWRAP starts over for each new line. The -C value of NWRAP typically used by XERMSG is 72 since many -C older error messages in the SLATEC Library are laid out to -C rely on wrap-around every 72 characters. -C -C NWRAP Input argument of type INTEGER. This gives the maximum size -C piece into which to break MESSG for printing on multiple -C lines. An embedded '$$' ends a line, and the count restarts -C at the following character. If a line break does not occur -C on a blank (it would split a word) that word is moved to the -C next line. Values of NWRAP less than 16 will be treated as -C 16. Values of NWRAP greater than 132 will be treated as 132. -C The actual line length will be NPREF + NWRAP after NPREF has -C been adjusted to fall between 0 and 16 and NWRAP has been -C adjusted to fall between 16 and 132. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 880621 DATE WRITTEN -C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF -C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK -C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE -C SLASH CHARACTER IN FORMAT STATEMENTS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK -C LINES TO BE PRINTED. -C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF -C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. -C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Added code to break messages between words. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERPRN - CHARACTER*(*) PREFIX, MESSG - INTEGER NPREF, NWRAP - CHARACTER*148 CBUFF - INTEGER IU(5), NUNIT - CHARACTER*2 NEWLIN - PARAMETER (NEWLIN = '$$') -C***FIRST EXECUTABLE STATEMENT XERPRN - CALL XGETUA(IU,NUNIT) -C -C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD -C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD -C ERROR MESSAGE UNIT. -C - N = I1MACH(4) - DO 10 I=1,NUNIT - IF (IU(I) .EQ. 0) IU(I) = N - 10 CONTINUE -C -C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE -C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING -C THE REST OF THIS ROUTINE. -C - IF ( NPREF .LT. 0 ) THEN - LPREF = LEN(PREFIX) - ELSE - LPREF = NPREF - ENDIF - LPREF = MIN(16, LPREF) - IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX -C -C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE -C TIME FROM MESSG TO PRINT ON ONE LINE. -C - LWRAP = MAX(16, MIN(132, NWRAP)) -C -C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. -C - LENMSG = LEN(MESSG) - N = LENMSG - DO 20 I=1,N - IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 - LENMSG = LENMSG - 1 - 20 CONTINUE - 30 CONTINUE -C -C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. -C - IF (LENMSG .EQ. 0) THEN - CBUFF(LPREF+1:LPREF+1) = ' ' - call printstring(cbuff) -c DO 40 I=1,NUNIT -c WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) -c 40 CONTINUE - RETURN - ENDIF -C -C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING -C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. -C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. -C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. -C -C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE -C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE -C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH -C OF THE SECOND ARGUMENT. -C -C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE -C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER -C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT -C POSITION NEXTC. -C -C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE -C REMAINDER OF THE CHARACTER STRING. LPIECE -C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, -C WHICHEVER IS LESS. -C -C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: -C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE -C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY -C BLANK LINES. THIS TAKES CARE OF THE SITUATION -C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF -C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE -C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC -C SHOULD BE INCREMENTED BY 2. -C -C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. -C -C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 -C RESET LPIECE = LPIECE-1. NOTE THAT THIS -C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. -C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY -C AT THE END OF A LINE. -C - NEXTC = 1 - 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) - IF (LPIECE .EQ. 0) THEN -C -C THERE WAS NO NEW LINE SENTINEL FOUND. -C - IDELTA = 0 - LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) - IF (LPIECE .LT. LENMSG+1-NEXTC) THEN - DO 52 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 54 - ENDIF - 52 CONTINUE - ENDIF - 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSEIF (LPIECE .EQ. 1) THEN -C -C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). -C DON'T PRINT A BLANK LINE. -C - NEXTC = NEXTC + 2 - GO TO 50 - ELSEIF (LPIECE .GT. LWRAP+1) THEN -C -C LPIECE SHOULD BE SET DOWN TO LWRAP. -C - IDELTA = 0 - LPIECE = LWRAP - DO 56 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 58 - ENDIF - 56 CONTINUE - 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSE -C -C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. -C WE SHOULD DECREMENT LPIECE BY ONE. -C - LPIECE = LPIECE - 1 - CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + 2 - ENDIF -C -C PRINT -C - call printstring(cbuff) -c DO 60 I=1,NUNIT -c WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) -c 60 CONTINUE -C - IF (NEXTC .LE. LENMSG) GO TO 50 - RETURN - END diff --git a/Cantera/ext/math/xersve.f b/Cantera/ext/math/xersve.f deleted file mode 100644 index 6bd2a4f7a..000000000 --- a/Cantera/ext/math/xersve.f +++ /dev/null @@ -1,155 +0,0 @@ -*DECK XERSVE - SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, - + ICOUNT) -C***BEGIN PROLOGUE XERSVE -C***SUBSIDIARY -C***PURPOSE Record that an error has occurred. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3 -C***TYPE ALL (XERSVE-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C *Usage: -C -C INTEGER KFLAG, NERR, LEVEL, ICOUNT -C CHARACTER * (len) LIBRAR, SUBROU, MESSG -C -C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) -C -C *Arguments: -C -C LIBRAR :IN is the library that the message is from. -C SUBROU :IN is the subroutine that the message is from. -C MESSG :IN is the message to be saved. -C KFLAG :IN indicates the action to be performed. -C when KFLAG > 0, the message in MESSG is saved. -C when KFLAG=0 the tables will be dumped and -C cleared. -C when KFLAG < 0, the tables will be dumped and -C not cleared. -C NERR :IN is the error number. -C LEVEL :IN is the error severity. -C ICOUNT :OUT the number of times this message has been seen, -C or zero if the table has overflowed and does not -C contain this message specifically. When KFLAG=0, -C ICOUNT will not be altered. -C -C *Description: -C -C Record that this error occurred and possibly dump and clear the -C tables. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 800319 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900413 Routine modified to remove reference to KFLAG. (WRB) -C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling -C sequence, use IF-THEN-ELSE, make number of saved entries -C easily changeable, changed routine name from XERSAV to -C XERSVE. (RWC) -C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERSVE - PARAMETER (LENTAB=10) - INTEGER LUN(5) - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB - CHARACTER*20 MESTAB(LENTAB), MES - DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) - SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG - DATA KOUNTX/0/, NMSG/0/ -C***FIRST EXECUTABLE STATEMENT XERSVE -C - IF (KFLAG.LE.0) THEN -C -C Dump the table. -C - IF (NMSG.EQ.0) RETURN -C -C Print to each unit. -C - CALL XGETUA (LUN, NUNIT) - DO 20 KUNIT = 1,NUNIT - IUNIT = LUN(KUNIT) - IF (IUNIT.EQ.0) IUNIT = I1MACH(4) -C -C Print the table header. -C - WRITE (IUNIT,9000) -C -C Print body of table. -C - DO 10 I = 1,NMSG - WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), - * NERTAB(I),LEVTAB(I),KOUNT(I) - 10 CONTINUE -C -C Print number of other errors. -C - IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX - WRITE (IUNIT,9030) - 20 CONTINUE -C -C Clear the error tables. -C - IF (KFLAG.EQ.0) THEN - NMSG = 0 - KOUNTX = 0 - ENDIF - ELSE -C -C PROCESS A MESSAGE... -C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, -C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. -C - LIB = LIBRAR - SUB = SUBROU - MES = MESSG - DO 30 I = 1,NMSG - IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. - * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. - * LEVEL.EQ.LEVTAB(I)) THEN - KOUNT(I) = KOUNT(I) + 1 - ICOUNT = KOUNT(I) - RETURN - ENDIF - 30 CONTINUE -C - IF (NMSG.LT.LENTAB) THEN -C -C Empty slot found for new message. -C - NMSG = NMSG + 1 - LIBTAB(I) = LIB - SUBTAB(I) = SUB - MESTAB(I) = MES - NERTAB(I) = NERR - LEVTAB(I) = LEVEL - KOUNT (I) = 1 - ICOUNT = 1 - ELSE -C -C Table is full. -C - KOUNTX = KOUNTX+1 - ICOUNT = 0 - ENDIF - ENDIF - RETURN -C -C Formats. -C - 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / - + ' LIBRARY SUBROUTINE MESSAGE START NERR', - + ' LEVEL COUNT') - 9010 FORMAT (1X,A,3X,A,3X,A,3I10) - 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) - 9030 FORMAT (1X) - END diff --git a/Cantera/ext/math/xgetua.f b/Cantera/ext/math/xgetua.f deleted file mode 100644 index 2e7db0212..000000000 --- a/Cantera/ext/math/xgetua.f +++ /dev/null @@ -1,51 +0,0 @@ -*DECK XGETUA - SUBROUTINE XGETUA (IUNITA, N) -C***BEGIN PROLOGUE XGETUA -C***PURPOSE Return unit number(s) to which error messages are being -C sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XGETUA-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XGETUA may be called to determine the unit number or numbers -C to which error messages are being sent. -C These unit numbers may have been set by a call to XSETUN, -C or a call to XSETUA, or may be a default value. -C -C Description of Parameters -C --Output-- -C IUNIT - an array of one to five unit numbers, depending -C on the value of N. A value of zero refers to the -C default unit, as defined by the I1MACH machine -C constant routine. Only IUNIT(1),...,IUNIT(N) are -C defined by XGETUA. The values of IUNIT(N+1),..., -C IUNIT(5) are not defined (for N .LT. 5) or altered -C in any way by XGETUA. -C N - the number of units to which copies of the -C error messages are being sent. N will be in the -C range from 1 to 5. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED J4SAVE -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XGETUA - DIMENSION IUNITA(5) -C***FIRST EXECUTABLE STATEMENT XGETUA - N = J4SAVE(5,0,.FALSE.) - DO 30 I=1,N - INDEX = I+4 - IF (I.EQ.1) INDEX = 3 - IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) - 30 CONTINUE - RETURN - END