commit d40505e161255758999e96b87db49def1b0d9c27 Author: James Kolpack Date: Wed Feb 3 18:52:05 2016 +0000 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..d3632ff --- /dev/null +++ b/.gitignore @@ -0,0 +1,32 @@ +# Compiled Object files +*.slo +*.lo +*.o +*.obj + +# Precompiled Headers +*.gch +*.pch + +# Compiled Dynamic libraries +*.so +*.dylib +*.dll + +# Fortran module files +*.mod + +# Compiled Static libraries +*.lai +*.la +*.a +*.lib + +# Executables +*.exe +*.out +*.app + +# editor and mac files +*~ +.DS_Store diff --git a/dataassim/math/algebra/DSYEV_plus.f b/dataassim/math/algebra/DSYEV_plus.f new file mode 100644 index 0000000..74a703b --- /dev/null +++ b/dataassim/math/algebra/DSYEV_plus.f @@ -0,0 +1,10106 @@ + SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) +* +* -- LAPACK driver routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DSYEV computes all eigenvalues and, optionally, eigenvectors of a +* real symmetric matrix A. +* +* Arguments +* ========= +* +* JOBZ (input) CHARACTER*1 +* = 'N': Compute eigenvalues only; +* = 'V': Compute eigenvalues and eigenvectors. +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) +* On entry, the symmetric matrix A. If UPLO = 'U', the +* leading N-by-N upper triangular part of A contains the +* upper triangular part of the matrix A. If UPLO = 'L', +* the leading N-by-N lower triangular part of A contains +* the lower triangular part of the matrix A. +* On exit, if JOBZ = 'V', then if INFO = 0, A contains the +* orthonormal eigenvectors of the matrix A. +* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') +* or the upper triangle (if UPLO='U') of A, including the +* diagonal, is destroyed. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* W (output) DOUBLE PRECISION array, dimension (N) +* If INFO = 0, the eigenvalues in ascending order. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The length of the array WORK. LWORK >= max(1,3*N-1). +* For optimal efficiency, LWORK >= (NB+2)*N, +* where NB is the blocksize for DSYTRD returned by ILAENV. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the algorithm failed to converge; i +* off-diagonal elements of an intermediate tridiagonal +* form did not converge to zero. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LOWER, LQUERY, WANTZ + INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE, + $ LLWORK, LWKOPT, NB + DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, + $ SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD, + $ XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + WANTZ = LSAME( JOBZ, 'V' ) + LOWER = LSAME( UPLO, 'L' ) + LQUERY = ( LWORK.EQ.-1 ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = MAX( 1, ( NB+2 )*N ) + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY ) + $ INFO = -8 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEV ', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + RETURN + END IF +* + IF( N.EQ.1 ) THEN + W( 1 ) = A( 1, 1 ) + WORK( 1 ) = 2 + IF( WANTZ ) + $ A( 1, 1 ) = ONE + RETURN + END IF +* +* Get machine constants. +* + SAFMIN = DLAMCH( 'Safe minimum' ) + EPS = DLAMCH( 'Precision' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = SQRT( BIGNUM ) +* +* Scale matrix to allowable range, if necessary. +* + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + ISCALE = 0 + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) + $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO ) +* +* Call DSYTRD to reduce symmetric matrix to tridiagonal form. +* + INDE = 1 + INDTAU = INDE + N + INDWRK = INDTAU + N + LLWORK = LWORK - INDWRK + 1 + CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) +* +* For eigenvalues only, call DSTERF. For eigenvectors, first call +* DORGTR to generate the orthogonal matrix, then call DSTEQR. +* + IF( .NOT.WANTZ ) THEN + CALL DSTERF( N, W, WORK( INDE ), INFO ) + ELSE + CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ), + $ LLWORK, IINFO ) + CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ), + $ INFO ) + END IF +* +* If matrix was scaled, then rescale eigenvalues appropriately. +* + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = N + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* Set WORK(1) to optimal workspace size. +* + WORK( 1 ) = LWKOPT +* + RETURN +* +* End of DSYEV +* + END + + subroutine daxpy(n,da,dx,incx,dy,incy) +c +c constant times a vector plus a vector. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),da + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if (da .eq. 0.0d0) return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dy(iy) + da*dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,4) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dy(i) + da*dx(i) + 30 continue + if( n .lt. 4 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,4 + dy(i) = dy(i) + da*dx(i) + dy(i + 1) = dy(i + 1) + da*dx(i + 1) + dy(i + 2) = dy(i + 2) + da*dx(i + 2) + dy(i + 3) = dy(i + 3) + da*dx(i + 3) + 50 continue + return + end + subroutine dcopy(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end + double precision function ddot(n,dx,incx,dy,incy) +c +c forms the dot product of two vectors. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddot = dtemp + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + 50 continue + 60 ddot = dtemp + return + end + SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 TRANSA, TRANSB + INTEGER M, N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* Purpose +* ======= +* +* DGEMM performs one of the matrix-matrix operations +* +* C := alpha*op( A )*op( B ) + beta*C, +* +* where op( X ) is one of +* +* op( X ) = X or op( X ) = X', +* +* alpha and beta are scalars, and A, B and C are matrices, with op( A ) +* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +* +* Parameters +* ========== +* +* TRANSA - CHARACTER*1. +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n', op( A ) = A. +* +* TRANSA = 'T' or 't', op( A ) = A'. +* +* TRANSA = 'C' or 'c', op( A ) = A'. +* +* Unchanged on exit. +* +* TRANSB - CHARACTER*1. +* On entry, TRANSB specifies the form of op( B ) to be used in +* the matrix multiplication as follows: +* +* TRANSB = 'N' or 'n', op( B ) = B. +* +* TRANSB = 'T' or 't', op( B ) = B'. +* +* TRANSB = 'C' or 'c', op( B ) = B'. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of the matrix +* op( A ) and of the matrix C. M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix +* op( B ) and the number of columns of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - INTEGER. +* On entry, K specifies the number of columns of the matrix +* op( A ) and the number of rows of the matrix op( B ). K must +* be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +* k when TRANSA = 'N' or 'n', and is m otherwise. +* Before entry with TRANSA = 'N' or 'n', the leading m by k +* part of the array A must contain the matrix A, otherwise +* the leading k by m part of the array A must contain the +* matrix A. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANSA = 'N' or 'n' then +* LDA must be at least max( 1, m ), otherwise LDA must be at +* least max( 1, k ). +* Unchanged on exit. +* +* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is +* n when TRANSB = 'N' or 'n', and is k otherwise. +* Before entry with TRANSB = 'N' or 'n', the leading k by n +* part of the array B must contain the matrix B, otherwise +* the leading n by k part of the array B must contain the +* matrix B. +* Unchanged on exit. +* +* LDB - INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. When TRANSB = 'N' or 'n' then +* LDB must be at least max( 1, k ), otherwise LDB must be at +* least max( 1, n ). +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then C need not be set on input. +* Unchanged on exit. +* +* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). +* Before entry, the leading m by n part of the array C must +* contain the matrix C, except when beta is zero, in which +* case C need not be set on entry. +* On exit, the array C is overwritten by the m by n matrix +* ( alpha*op( A )*op( B ) + beta*C ). +* +* LDC - INTEGER. +* On entry, LDC specifies the first dimension of C as declared +* in the calling (sub) program. LDC must be at least +* max( 1, m ). +* Unchanged on exit. +* +* +* Level 3 Blas routine. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Local Scalars .. + LOGICAL NOTA, NOTB + INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA, NCOLA and NROWB as the number of rows +* and columns of A and the number of rows of B respectively. +* + NOTA = LSAME( TRANSA, 'N' ) + NOTB = LSAME( TRANSB, 'N' ) + IF( NOTA )THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF( NOTB )THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF( ( .NOT.NOTA ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.NOTB ).AND. + $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. + $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN + INFO = 2 + ELSE IF( M .LT.0 )THEN + INFO = 3 + ELSE IF( N .LT.0 )THEN + INFO = 4 + ELSE IF( K .LT.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 8 + ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN + INFO = 10 + ELSE IF( LDC.LT.MAX( 1, M ) )THEN + INFO = 13 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGEMM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And if alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, M + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF( NOTB )THEN + IF( NOTA )THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 50, I = 1, M + C( I, J ) = ZERO + 50 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 60, I = 1, M + C( I, J ) = BETA*C( I, J ) + 60 CONTINUE + END IF + DO 80, L = 1, K + IF( B( L, J ).NE.ZERO )THEN + TEMP = ALPHA*B( L, J ) + DO 70, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 70 CONTINUE + END IF + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A'*B + beta*C +* + DO 120, J = 1, N + DO 110, I = 1, M + TEMP = ZERO + DO 100, L = 1, K + TEMP = TEMP + A( L, I )*B( L, J ) + 100 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF( NOTA )THEN +* +* Form C := alpha*A*B' + beta*C +* + DO 170, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 130, I = 1, M + C( I, J ) = ZERO + 130 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 140, I = 1, M + C( I, J ) = BETA*C( I, J ) + 140 CONTINUE + END IF + DO 160, L = 1, K + IF( B( J, L ).NE.ZERO )THEN + TEMP = ALPHA*B( J, L ) + DO 150, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 150 CONTINUE + END IF + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A'*B' + beta*C +* + DO 200, J = 1, N + DO 190, I = 1, M + TEMP = ZERO + DO 180, L = 1, K + TEMP = TEMP + A( L, I )*B( J, L ) + 180 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM . +* + END + SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, M, N + CHARACTER*1 TRANS +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DGEMV performs one of the matrix-vector operations +* +* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* Parameters +* ========== +* +* TRANS - CHARACTER*1. +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +* +* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. +* +* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGEMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( LSAME( TRANS, 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, LENY + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, LENY + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, LENY + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, LENY + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF( INCY.EQ.1 )THEN + DO 60, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + DO 50, I = 1, M + Y( I ) = Y( I ) + TEMP*A( I, J ) + 50 CONTINUE + END IF + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IY = KY + DO 70, I = 1, M + Y( IY ) = Y( IY ) + TEMP*A( I, J ) + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A'*x + y. +* + JY = KY + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = ZERO + DO 90, I = 1, M + TEMP = TEMP + A( I, J )*X( I ) + 90 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120, J = 1, N + TEMP = ZERO + IX = KX + DO 110, I = 1, M + TEMP = TEMP + A( I, J )*X( IX ) + IX = IX + INCX + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMV . +* + END + SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, INCY, LDA, M, N +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DGER performs the rank 1 operation +* +* A := alpha*x*y' + A, +* +* where alpha is a scalar, x is an m element vector, y is an n element +* vector and A is an m by n matrix. +* +* Parameters +* ========== +* +* M - INTEGER. +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of dimension at least +* ( 1 + ( m - 1 )*abs( INCX ) ). +* Before entry, the incremented array X must contain the m +* element vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCY ) ). +* Before entry, the incremented array Y must contain the n +* element vector y. +* Unchanged on exit. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. On exit, A is +* overwritten by the updated matrix. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JY, KX +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( M.LT.0 )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( INCY.EQ.0 )THEN + INFO = 7 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGER ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF( INCY.GT.0 )THEN + JY = 1 + ELSE + JY = 1 - ( N - 1 )*INCY + END IF + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( Y( JY ).NE.ZERO )THEN + TEMP = ALPHA*Y( JY ) + DO 10, I = 1, M + A( I, J ) = A( I, J ) + X( I )*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( M - 1 )*INCX + END IF + DO 40, J = 1, N + IF( Y( JY ).NE.ZERO )THEN + TEMP = ALPHA*Y( JY ) + IX = KX + DO 30, I = 1, M + A( I, J ) = A( I, J ) + X( IX )*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of DGER . +* + END + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK auxiliary routine (version 1.1) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + CHARACTER CMACH +* .. +* +* Purpose +* ======= +* +* DLAMCH determines double precision machine parameters. +* +* Arguments +* ========= +* +* CMACH (input) CHARACTER*1 +* Specifies the value to be returned by DLAMCH: +* = 'E' or 'e', DLAMCH := eps +* = 'S' or 's , DLAMCH := sfmin +* = 'B' or 'b', DLAMCH := base +* = 'P' or 'p', DLAMCH := eps*base +* = 'N' or 'n', DLAMCH := t +* = 'R' or 'r', DLAMCH := rnd +* = 'M' or 'm', DLAMCH := emin +* = 'U' or 'u', DLAMCH := rmin +* = 'L' or 'l', DLAMCH := emax +* = 'O' or 'o', DLAMCH := rmax +* +* where +* +* eps = relative machine precision +* sfmin = safe minimum, such that 1/sfmin does not overflow +* base = base of the machine +* prec = eps*base +* t = number of (base) digits in the mantissa +* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise +* emin = minimum exponent before (gradual) underflow +* rmin = underflow threshold - base**(emin-1) +* emax = largest exponent before overflow +* rmax = overflow threshold - (base**emax)*(1-eps) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL FIRST, LRND + INTEGER BETA, IMAX, IMIN, IT + DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, + $ RND, SFMIN, SMALL, T +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLAMC2 +* .. +* .. Save statement .. + SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, + $ EMAX, RMAX, PREC +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) + BASE = BETA + T = IT + IF( LRND ) THEN + RND = ONE + EPS = ( BASE**( 1-IT ) ) / 2 + ELSE + RND = ZERO + EPS = BASE**( 1-IT ) + END IF + PREC = EPS*BASE + EMIN = IMIN + EMAX = IMAX + SFMIN = RMIN + SMALL = ONE / RMAX + IF( SMALL.GE.SFMIN ) THEN +* +* Use SMALL plus a bit, to avoid the possibility of rounding +* causing overflow when computing 1/sfmin. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = BASE + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = PREC + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = T + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = EMIN + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = RMIN + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = EMAX + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = RMAX + END IF +* + DLAMCH = RMACH + RETURN +* +* End of DLAMCH +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) +* +* -- LAPACK auxiliary routine (version 1.1) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL IEEE1, RND + INTEGER BETA, T +* .. +* +* Purpose +* ======= +* +* DLAMC1 determines the machine parameters given by BETA, T, RND, and +* IEEE1. +* +* Arguments +* ========= +* +* BETA (output) INTEGER +* The base of the machine. +* +* T (output) INTEGER +* The number of ( BETA ) digits in the mantissa. +* +* RND (output) LOGICAL +* Specifies whether proper rounding ( RND = .TRUE. ) or +* chopping ( RND = .FALSE. ) occurs in addition. This may not +* be a reliable guide to the way in which the machine performs +* its arithmetic. +* +* IEEE1 (output) LOGICAL +* Specifies whether rounding appears to be done in the IEEE +* 'round to nearest' style. +* +* Further Details +* =============== +* +* The routine is based on the routine ENVRON by Malcolm and +* incorporates suggestions by Gentleman and Marovich. See +* +* Malcolm M. A. (1972) Algorithms to reveal properties of +* floating-point arithmetic. Comms. of the ACM, 15, 949-951. +* +* Gentleman W. M. and Marovich S. B. (1974) More on algorithms +* that reveal properties of floating point arithmetic units. +* Comms. of the ACM, 17, 276-277. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, LIEEE1, LRND + INTEGER LBETA, LT + DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Save statement .. + SAVE FIRST, LIEEE1, LBETA, LRND, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ONE = 1 +* +* LBETA, LIEEE1, LT and LRND are the local values of BETA, +* IEEE1, T and RND. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* Compute a = 2.0**m with the smallest positive integer m such +* that +* +* fl( a + 1.0 ) = a. +* + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 10 CONTINUE + IF( C.EQ.ONE ) THEN + A = 2*A + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 10 + END IF +*+ END WHILE +* +* Now compute b = 2.0**m with the smallest positive integer m +* such that +* +* fl( a + b ) .gt. a. +* + B = 1 + C = DLAMC3( A, B ) +* +*+ WHILE( C.EQ.A )LOOP + 20 CONTINUE + IF( C.EQ.A ) THEN + B = 2*B + C = DLAMC3( A, B ) + GO TO 20 + END IF +*+ END WHILE +* +* Now compute the base. a and c are neighbouring floating point +* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so +* their difference is beta. Adding 0.25 to c is to ensure that it +* is truncated to beta and not ( beta - 1 ). +* + QTR = ONE / 4 + SAVEC = C + C = DLAMC3( C, -A ) + LBETA = C + QTR +* +* Now determine whether rounding or chopping occurs, by adding a +* bit less than beta/2 and a bit more than beta/2 to a. +* + B = LBETA + F = DLAMC3( B / 2, -B / 100 ) + C = DLAMC3( F, A ) + IF( C.EQ.A ) THEN + LRND = .TRUE. + ELSE + LRND = .FALSE. + END IF + F = DLAMC3( B / 2, B / 100 ) + C = DLAMC3( F, A ) + IF( ( LRND ) .AND. ( C.EQ.A ) ) + $ LRND = .FALSE. +* +* Try and decide whether rounding is done in the IEEE 'round to +* nearest' style. B/2 is half a unit in the last place of the two +* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit +* zero, and SAVEC is odd. Thus adding B/2 to A should not change +* A, but adding B/2 to SAVEC should change SAVEC. +* + T1 = DLAMC3( B / 2, A ) + T2 = DLAMC3( B / 2, SAVEC ) + LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND +* +* Now find the mantissa, t. It should be the integer part of +* log to the base beta of a, however it is safer to determine t +* by powering. So we find t as the smallest positive integer for +* which +* +* fl( beta**t + 1.0 ) = 1.0. +* + LT = 0 + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 30 CONTINUE + IF( C.EQ.ONE ) THEN + LT = LT + 1 + A = A*LBETA + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 30 + END IF +*+ END WHILE +* + END IF +* + BETA = LBETA + T = LT + RND = LRND + IEEE1 = LIEEE1 + RETURN +* +* End of DLAMC1 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 1.1) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL RND + INTEGER BETA, EMAX, EMIN, T + DOUBLE PRECISION EPS, RMAX, RMIN +* .. +* +* Purpose +* ======= +* +* DLAMC2 determines the machine parameters specified in its argument +* list. +* +* Arguments +* ========= +* +* BETA (output) INTEGER +* The base of the machine. +* +* T (output) INTEGER +* The number of ( BETA ) digits in the mantissa. +* +* RND (output) LOGICAL +* Specifies whether proper rounding ( RND = .TRUE. ) or +* chopping ( RND = .FALSE. ) occurs in addition. This may not +* be a reliable guide to the way in which the machine performs +* its arithmetic. +* +* EPS (output) DOUBLE PRECISION +* The smallest positive number such that +* +* fl( 1.0 - EPS ) .LT. 1.0, +* +* where fl denotes the computed value. +* +* EMIN (output) INTEGER +* The minimum exponent before (gradual) underflow occurs. +* +* RMIN (output) DOUBLE PRECISION +* The smallest normalized number for the machine, given by +* BASE**( EMIN - 1 ), where BASE is the floating point value +* of BETA. +* +* EMAX (output) INTEGER +* The maximum exponent before overflow occurs. +* +* RMAX (output) DOUBLE PRECISION +* The largest positive number for the machine, given by +* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point +* value of BETA. +* +* Further Details +* =============== +* +* The computation of EPS is based on a routine PARANOIA by +* W. Kahan of the University of California at Berkeley. +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND + INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, + $ NGNMIN, NGPMIN + DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, + $ SIXTH, SMALL, THIRD, TWO, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. External Subroutines .. + EXTERNAL DLAMC1, DLAMC4, DLAMC5 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. Save statement .. + SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, + $ LRMIN, LT +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / , IWARN / .FALSE. / +* .. +* .. Executable Statements .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ZERO = 0 + ONE = 1 + TWO = 2 +* +* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of +* BETA, T, RND, EPS, EMIN and RMIN. +* +* Throughout this routine we use the function DLAMC3 to ensure +* that relevant values are stored and not held in registers, or +* are not affected by optimizers. +* +* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. +* + CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) +* +* Start to find EPS. +* + B = LBETA + A = B**( -LT ) + LEPS = A +* +* Try some tricks to see whether or not this is the correct EPS. +* + B = TWO / 3 + HALF = ONE / 2 + SIXTH = DLAMC3( B, -HALF ) + THIRD = DLAMC3( SIXTH, SIXTH ) + B = DLAMC3( THIRD, -HALF ) + B = DLAMC3( B, SIXTH ) + B = ABS( B ) + IF( B.LT.LEPS ) + $ B = LEPS +* + LEPS = 1 +* +*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP + 10 CONTINUE + IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN + LEPS = B + C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) + C = DLAMC3( HALF, -C ) + B = DLAMC3( HALF, C ) + C = DLAMC3( HALF, -B ) + B = DLAMC3( HALF, C ) + GO TO 10 + END IF +*+ END WHILE +* + IF( A.LT.LEPS ) + $ LEPS = A +* +* Computation of EPS complete. +* +* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). +* Keep dividing A by BETA until (gradual) underflow occurs. This +* is detected when we cannot recover the previous A. +* + RBASE = ONE / LBETA + SMALL = ONE + DO 20 I = 1, 3 + SMALL = DLAMC3( SMALL*RBASE, ZERO ) + 20 CONTINUE + A = DLAMC3( ONE, SMALL ) + CALL DLAMC4( NGPMIN, ONE, LBETA ) + CALL DLAMC4( NGNMIN, -ONE, LBETA ) + CALL DLAMC4( GPMIN, A, LBETA ) + CALL DLAMC4( GNMIN, -A, LBETA ) + IEEE = .FALSE. +* + IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN + IF( NGPMIN.EQ.GPMIN ) THEN + LEMIN = NGPMIN +* ( Non twos-complement machines, no gradual underflow; +* e.g., VAX ) + ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN + LEMIN = NGPMIN - 1 + LT + IEEE = .TRUE. +* ( Non twos-complement machines, with gradual underflow; +* e.g., IEEE standard followers ) + ELSE + LEMIN = MIN( NGPMIN, GPMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN + IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) +* ( Twos-complement machines, no gradual underflow; +* e.g., CYBER 205 ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. + $ ( GPMIN.EQ.GNMIN ) ) THEN + IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT +* ( Twos-complement machines with gradual underflow; +* no known machine ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +* + ELSE + LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) +* ( A guess; no known machine ) + IWARN = .TRUE. + END IF +*** +* Comment out this if block if EMIN is ok + IF( IWARN ) THEN + FIRST = .TRUE. + WRITE( 6, FMT = 9999 )LEMIN + END IF +*** +* +* Assume IEEE arithmetic if we found denormalised numbers above, +* or if arithmetic seems to round in the IEEE style, determined +* in routine DLAMC1. A true IEEE machine should have both things +* true; however, faulty machines may have one or the other. +* + IEEE = IEEE .OR. LIEEE1 +* +* Compute RMIN by successive division by BETA. We could compute +* RMIN as BASE**( EMIN - 1 ), but some machines underflow during +* this computation. +* + LRMIN = 1 + DO 30 I = 1, 1 - LEMIN + LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) + 30 CONTINUE +* +* Finally, call DLAMC5 to compute EMAX and RMAX. +* + CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) + END IF +* + BETA = LBETA + T = LT + RND = LRND + EPS = LEPS + EMIN = LEMIN + RMIN = LRMIN + EMAX = LEMAX + RMAX = LRMAX +* + RETURN +* + 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', + $ ' EMIN = ', I8, / + $ ' If, after inspection, the value EMIN looks', + $ ' acceptable please comment out ', + $ / ' the IF block as marked within the code of routine', + $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) +* +* End of DLAMC2 +* + END +* +************************************************************************ +* + DOUBLE PRECISION FUNCTION DLAMC3( A, B ) +* +* -- LAPACK auxiliary routine (version 1.1) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B +* .. +* +* Purpose +* ======= +* +* DLAMC3 is intended to force A and B to be stored prior to doing +* the addition of A and B , for use in situations where optimizers +* might hold one of these in a register. +* +* Arguments +* ========= +* +* A, B (input) DOUBLE PRECISION +* The values A and B. +* +* ===================================================================== +* +* .. Executable Statements .. +* + DLAMC3 = A + B +* + RETURN +* +* End of DLAMC3 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC4( EMIN, START, BASE ) +* +* -- LAPACK auxiliary routine (version 1.1) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + INTEGER BASE, EMIN + DOUBLE PRECISION START +* .. +* +* Purpose +* ======= +* +* DLAMC4 is a service routine for DLAMC2. +* +* Arguments +* ========= +* +* EMIN (output) EMIN +* The minimum exponent before (gradual) underflow, computed by +* setting A = START and dividing by BASE until the previous A +* can not be recovered. +* +* START (input) DOUBLE PRECISION +* The starting point for determining EMIN. +* +* BASE (input) INTEGER +* The base of the machine. +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Executable Statements .. +* + A = START + ONE = 1 + RBASE = ONE / BASE + ZERO = 0 + EMIN = 1 + B1 = DLAMC3( A*RBASE, ZERO ) + C1 = A + C2 = A + D1 = A + D2 = A +*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. +* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP + 10 CONTINUE + IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. + $ ( D2.EQ.A ) ) THEN + EMIN = EMIN - 1 + A = B1 + B1 = DLAMC3( A / BASE, ZERO ) + C1 = DLAMC3( B1*BASE, ZERO ) + D1 = ZERO + DO 20 I = 1, BASE + D1 = D1 + B1 + 20 CONTINUE + B2 = DLAMC3( A*RBASE, ZERO ) + C2 = DLAMC3( B2 / RBASE, ZERO ) + D2 = ZERO + DO 30 I = 1, BASE + D2 = D2 + B2 + 30 CONTINUE + GO TO 10 + END IF +*+ END WHILE +* + RETURN +* +* End of DLAMC4 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) +* +* -- LAPACK auxiliary routine (version 1.1) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* October 31, 1992 +* +* .. Scalar Arguments .. + LOGICAL IEEE + INTEGER BETA, EMAX, EMIN, P + DOUBLE PRECISION RMAX +* .. +* +* Purpose +* ======= +* +* DLAMC5 attempts to compute RMAX, the largest machine floating-point +* number, without overflow. It assumes that EMAX + abs(EMIN) sum +* approximately to a power of 2. It will fail on machines where this +* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, +* EMAX = 28718). It will also fail if the value supplied for EMIN is +* too large (i.e. too close to zero), probably with overflow. +* +* Arguments +* ========= +* +* BETA (input) INTEGER +* The base of floating-point arithmetic. +* +* P (input) INTEGER +* The number of base BETA digits in the mantissa of a +* floating-point value. +* +* EMIN (input) INTEGER +* The minimum exponent before (gradual) underflow. +* +* IEEE (input) LOGICAL +* A logical flag specifying whether or not the arithmetic +* system is thought to comply with the IEEE standard. +* +* EMAX (output) INTEGER +* The largest exponent before overflow +* +* RMAX (output) DOUBLE PRECISION +* The largest machine floating-point number. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP + DOUBLE PRECISION OLDY, RECBAS, Y, Z +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. Intrinsic Functions .. + INTRINSIC MOD +* .. +* .. Executable Statements .. +* +* First compute LEXP and UEXP, two powers of 2 that bound +* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum +* approximately to the bound that is closest to abs(EMIN). +* (EMAX is the exponent of the required number RMAX). +* + LEXP = 1 + EXBITS = 1 + 10 CONTINUE + TRY = LEXP*2 + IF( TRY.LE.( -EMIN ) ) THEN + LEXP = TRY + EXBITS = EXBITS + 1 + GO TO 10 + END IF + IF( LEXP.EQ.-EMIN ) THEN + UEXP = LEXP + ELSE + UEXP = TRY + EXBITS = EXBITS + 1 + END IF +* +* Now -LEXP is less than or equal to EMIN, and -UEXP is greater +* than or equal to EMIN. EXBITS is the number of bits needed to +* store the exponent. +* + IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN + EXPSUM = 2*LEXP + ELSE + EXPSUM = 2*UEXP + END IF +* +* EXPSUM is the exponent range, approximately equal to +* EMAX - EMIN + 1 . +* + EMAX = EXPSUM + EMIN - 1 + NBITS = 1 + EXBITS + P +* +* NBITS is the total number of bits needed to store a +* floating-point number. +* + IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN +* +* Either there are an odd number of bits used to store a +* floating-point number, which is unlikely, or some bits are +* not used in the representation of numbers, which is possible, +* (e.g. Cray machines) or the mantissa has an implicit bit, +* (e.g. IEEE machines, Dec Vax machines), which is perhaps the +* most likely. We have to assume the last alternative. +* If this is true, then we need to reduce EMAX by one because +* there must be some way of representing zero in an implicit-bit +* system. On machines like Cray, we are reducing EMAX by one +* unnecessarily. +* + EMAX = EMAX - 1 + END IF +* + IF( IEEE ) THEN +* +* Assume we are on an IEEE machine which reserves one exponent +* for infinity and NaN. +* + EMAX = EMAX - 1 + END IF +* +* Now create RMAX, the largest machine number, which should +* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . +* +* First compute 1.0 - BETA**(-P), being careful that the +* result is less than 1.0 . +* + RECBAS = ONE / BETA + Z = BETA - ONE + Y = ZERO + DO 20 I = 1, P + Z = Z*RECBAS + IF( Y.LT.ONE ) + $ OLDY = Y + Y = DLAMC3( Y, Z ) + 20 CONTINUE + IF( Y.GE.ONE ) + $ Y = OLDY +* +* Now multiply by BETA**EMAX to get RMAX. +* + DO 30 I = 1, EMAX + Y = DLAMC3( Y*BETA, ZERO ) + 30 CONTINUE +* + RMAX = Y + RETURN +* +* End of DLAMC5 +* + END + DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, N +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* DNRM2 returns the euclidean norm of a vector via the function +* name, so that +* +* DNRM2 := sqrt( x'*x ) +* +* +* +* -- This version written on 25-October-1982. +* Modified on 14-October-1993 to inline the call to DLASSQ. +* Sven Hammarling, Nag Ltd. +* +* +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. + IF( N.LT.1 .OR. INCX.LT.1 )THEN + NORM = ZERO + ELSE IF( N.EQ.1 )THEN + NORM = ABS( X( 1 ) ) + ELSE + SCALE = ZERO + SSQ = ONE +* The following loop is equivalent to this call to the LAPACK +* auxiliary routine: +* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) +* + DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX + IF( X( IX ).NE.ZERO )THEN + ABSXI = ABS( X( IX ) ) + IF( SCALE.LT.ABSXI )THEN + SSQ = ONE + SSQ*( SCALE/ABSXI )**2 + SCALE = ABSXI + ELSE + SSQ = SSQ + ( ABSXI/SCALE )**2 + END IF + END IF + 10 CONTINUE + NORM = SCALE * SQRT( SSQ ) + END IF +* + DNRM2 = NORM + RETURN +* +* End of DNRM2. +* + END + subroutine dscal(n,da,dx,incx) +c +c scales a vector by a constant. +c uses unrolled loops for increment equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision da,dx(*) + integer i,incx,m,mp1,n,nincx +c + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dx(i) = da*dx(i) + 10 continue + return +c +c code for increment equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dx(i) = da*dx(i) + 30 continue + if( n .lt. 5 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dx(i) = da*dx(i) + dx(i + 1) = da*dx(i + 1) + dx(i + 2) = da*dx(i + 2) + dx(i + 3) = da*dx(i + 3) + dx(i + 4) = da*dx(i + 4) + 50 continue + return + end + subroutine dswap (n,dx,incx,dy,incy) +c +c interchanges two vectors. +c uses unrolled loops for increments equal one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal +c to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dx(ix) + dx(ix) = dy(iy) + dy(iy) = dtemp + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,3) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + 30 continue + if( n .lt. 3 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,3 + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + dtemp = dx(i + 1) + dx(i + 1) = dy(i + 1) + dy(i + 1) = dtemp + dtemp = dx(i + 2) + dx(i + 2) = dy(i + 2) + dy(i + 2) = dtemp + 50 continue + return + end + SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DSYMV performs the matrix-vector operation +* +* y := alpha*A*x + beta*y, +* +* where alpha and beta are scalars, x and y are n element vectors and +* A is an n by n symmetric matrix. +* +* Parameters +* ========== +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array A is to be referenced as +* follows: +* +* UPLO = 'U' or 'u' Only the upper triangular part of A +* is to be referenced. +* +* UPLO = 'L' or 'l' Only the lower triangular part of A +* is to be referenced. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the order of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). +* Before entry with UPLO = 'U' or 'u', the leading n by n +* upper triangular part of the array A must contain the upper +* triangular part of the symmetric matrix and the strictly +* lower triangular part of A is not referenced. +* Before entry with UPLO = 'L' or 'l', the leading n by n +* lower triangular part of the array A must contain the lower +* triangular part of the symmetric matrix and the strictly +* upper triangular part of A is not referenced. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, n ). +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ). +* Before entry, the incremented array X must contain the n +* element vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCY ) ). +* Before entry, the incremented array Y must contain the n +* element vector y. On exit, Y is overwritten by the updated +* vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set up the start points in X and Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* +* First form y := beta*y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, N + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, N + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, N + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, N + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form y when A is stored in upper triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + DO 50, I = 1, J - 1 + Y( I ) = Y( I ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( I ) + 50 CONTINUE + Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70, I = 1, J - 1 + Y( IY ) = Y( IY ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( IX ) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +* +* Form y when A is stored in lower triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 100, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + Y( J ) = Y( J ) + TEMP1*A( J, J ) + DO 90, I = J + 1, N + Y( I ) = Y( I ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( I ) + 90 CONTINUE + Y( J ) = Y( J ) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + IX = JX + IY = JY + DO 110, I = J + 1, N + IX = IX + INCX + IY = IY + INCY + Y( IY ) = Y( IY ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( IX ) + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYMV . +* + END + SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, INCY, LDA, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DSYR2 performs the symmetric rank 2 operation +* +* A := alpha*x*y' + alpha*y*x' + A, +* +* where alpha is a scalar, x and y are n element vectors and A is an n +* by n symmetric matrix. +* +* Parameters +* ========== +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array A is to be referenced as +* follows: +* +* UPLO = 'U' or 'u' Only the upper triangular part of A +* is to be referenced. +* +* UPLO = 'L' or 'l' Only the lower triangular part of A +* is to be referenced. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the order of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ). +* Before entry, the incremented array X must contain the n +* element vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCY ) ). +* Before entry, the incremented array Y must contain the n +* element vector y. +* Unchanged on exit. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). +* Before entry with UPLO = 'U' or 'u', the leading n by n +* upper triangular part of the array A must contain the upper +* triangular part of the symmetric matrix and the strictly +* lower triangular part of A is not referenced. On exit, the +* upper triangular part of the array A is overwritten by the +* upper triangular part of the updated matrix. +* Before entry with UPLO = 'L' or 'l', the leading n by n +* lower triangular part of the array A must contain the lower +* triangular part of the symmetric matrix and the strictly +* upper triangular part of A is not referenced. On exit, the +* lower triangular part of the array A is overwritten by the +* lower triangular part of the updated matrix. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, n ). +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( INCY.EQ.0 )THEN + INFO = 7 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYR2 ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* Set up the start points in X and Y if the increments are not both +* unity. +* + IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF + JX = KX + JY = KY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through the triangular part +* of A. +* + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form A when A is stored in the upper triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 20, J = 1, N + IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( J ) + TEMP2 = ALPHA*X( J ) + DO 10, I = 1, J + A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40, J = 1, N + IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( JY ) + TEMP2 = ALPHA*X( JX ) + IX = KX + IY = KY + DO 30, I = 1, J + A( I, J ) = A( I, J ) + X( IX )*TEMP1 + $ + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +* +* Form A when A is stored in the lower triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( J ) + TEMP2 = ALPHA*X( J ) + DO 50, I = J, N + A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80, J = 1, N + IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( JY ) + TEMP2 = ALPHA*X( JX ) + IX = JX + IY = JY + DO 70, I = J, N + A( I, J ) = A( I, J ) + X( IX )*TEMP1 + $ + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYR2 . +* + END + SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 UPLO, TRANS + INTEGER N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* Purpose +* ======= +* +* DSYR2K performs one of the symmetric rank 2k operations +* +* C := alpha*A*B' + alpha*B*A' + beta*C, +* +* or +* +* C := alpha*A'*B + alpha*B'*A + beta*C, +* +* where alpha and beta are scalars, C is an n by n symmetric matrix +* and A and B are n by k matrices in the first case and k by n +* matrices in the second case. +* +* Parameters +* ========== +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array C is to be referenced as +* follows: +* +* UPLO = 'U' or 'u' Only the upper triangular part of C +* is to be referenced. +* +* UPLO = 'L' or 'l' Only the lower triangular part of C +* is to be referenced. +* +* Unchanged on exit. +* +* TRANS - CHARACTER*1. +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + +* beta*C. +* +* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + +* beta*C. +* +* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + +* beta*C. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the order of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - INTEGER. +* On entry with TRANS = 'N' or 'n', K specifies the number +* of columns of the matrices A and B, and on entry with +* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number +* of rows of the matrices A and B. K must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +* k when TRANS = 'N' or 'n', and is n otherwise. +* Before entry with TRANS = 'N' or 'n', the leading n by k +* part of the array A must contain the matrix A, otherwise +* the leading k by n part of the array A must contain the +* matrix A. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANS = 'N' or 'n' +* then LDA must be at least max( 1, n ), otherwise LDA must +* be at least max( 1, k ). +* Unchanged on exit. +* +* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is +* k when TRANS = 'N' or 'n', and is n otherwise. +* Before entry with TRANS = 'N' or 'n', the leading n by k +* part of the array B must contain the matrix B, otherwise +* the leading k by n part of the array B must contain the +* matrix B. +* Unchanged on exit. +* +* LDB - INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. When TRANS = 'N' or 'n' +* then LDB must be at least max( 1, n ), otherwise LDB must +* be at least max( 1, k ). +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. +* Unchanged on exit. +* +* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). +* Before entry with UPLO = 'U' or 'u', the leading n by n +* upper triangular part of the array C must contain the upper +* triangular part of the symmetric matrix and the strictly +* lower triangular part of C is not referenced. On exit, the +* upper triangular part of the array C is overwritten by the +* upper triangular part of the updated matrix. +* Before entry with UPLO = 'L' or 'l', the leading n by n +* lower triangular part of the array C must contain the lower +* triangular part of the symmetric matrix and the strictly +* upper triangular part of C is not referenced. On exit, the +* lower triangular part of the array C is overwritten by the +* lower triangular part of the updated matrix. +* +* LDC - INTEGER. +* On entry, LDC specifies the first dimension of C as declared +* in the calling (sub) program. LDC must be at least +* max( 1, n ). +* Unchanged on exit. +* +* +* Level 3 Blas routine. +* +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, INFO, J, L, NROWA + DOUBLE PRECISION TEMP1, TEMP2 +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IF( LSAME( TRANS, 'N' ) )THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN + INFO = 2 + ELSE IF( N .LT.0 )THEN + INFO = 3 + ELSE IF( K .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN + INFO = 9 + ELSE IF( LDC.LT.MAX( 1, N ) )THEN + INFO = 12 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYR2K', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( UPPER )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, J + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, J + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF( BETA.EQ.ZERO )THEN + DO 60, J = 1, N + DO 50, I = J, N + C( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80, J = 1, N + DO 70, I = J, N + C( I, J ) = BETA*C( I, J ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form C := alpha*A*B' + alpha*B*A' + C. +* + IF( UPPER )THEN + DO 130, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 90, I = 1, J + C( I, J ) = ZERO + 90 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 100, I = 1, J + C( I, J ) = BETA*C( I, J ) + 100 CONTINUE + END IF + DO 120, L = 1, K + IF( ( A( J, L ).NE.ZERO ).OR. + $ ( B( J, L ).NE.ZERO ) )THEN + TEMP1 = ALPHA*B( J, L ) + TEMP2 = ALPHA*A( J, L ) + DO 110, I = 1, J + C( I, J ) = C( I, J ) + + $ A( I, L )*TEMP1 + B( I, L )*TEMP2 + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 140, I = J, N + C( I, J ) = ZERO + 140 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 150, I = J, N + C( I, J ) = BETA*C( I, J ) + 150 CONTINUE + END IF + DO 170, L = 1, K + IF( ( A( J, L ).NE.ZERO ).OR. + $ ( B( J, L ).NE.ZERO ) )THEN + TEMP1 = ALPHA*B( J, L ) + TEMP2 = ALPHA*A( J, L ) + DO 160, I = J, N + C( I, J ) = C( I, J ) + + $ A( I, L )*TEMP1 + B( I, L )*TEMP2 + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A'*B + alpha*B'*A + C. +* + IF( UPPER )THEN + DO 210, J = 1, N + DO 200, I = 1, J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190, L = 1, K + TEMP1 = TEMP1 + A( L, I )*B( L, J ) + TEMP2 = TEMP2 + B( L, I )*A( L, J ) + 190 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ ALPHA*TEMP1 + ALPHA*TEMP2 + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240, J = 1, N + DO 230, I = J, N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220, L = 1, K + TEMP1 = TEMP1 + A( L, I )*B( L, J ) + TEMP2 = TEMP2 + B( L, I )*A( L, J ) + 220 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ ALPHA*TEMP1 + ALPHA*TEMP2 + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYR2K. +* + END + SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, + $ B, LDB ) +* .. Scalar Arguments .. + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + DOUBLE PRECISION ALPHA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DTRMM performs one of the matrix-matrix operations +* +* B := alpha*op( A )*B, or B := alpha*B*op( A ), +* +* where alpha is a scalar, B is an m by n matrix, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = A'. +* +* Parameters +* ========== +* +* SIDE - CHARACTER*1. +* On entry, SIDE specifies whether op( A ) multiplies B from +* the left or right as follows: +* +* SIDE = 'L' or 'l' B := alpha*op( A )*B. +* +* SIDE = 'R' or 'r' B := alpha*B*op( A ). +* +* Unchanged on exit. +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the matrix A is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* Unchanged on exit. +* +* TRANSA - CHARACTER*1. +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n' op( A ) = A. +* +* TRANSA = 'T' or 't' op( A ) = A'. +* +* TRANSA = 'C' or 'c' op( A ) = A'. +* +* Unchanged on exit. +* +* DIAG - CHARACTER*1. +* On entry, DIAG specifies whether or not A is unit triangular +* as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m +* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. +* Before entry with UPLO = 'U' or 'u', the leading k by k +* upper triangular part of the array A must contain the upper +* triangular matrix and the strictly lower triangular part of +* A is not referenced. +* Before entry with UPLO = 'L' or 'l', the leading k by k +* lower triangular part of the array A must contain the lower +* triangular matrix and the strictly upper triangular part of +* A is not referenced. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced either, but are assumed to be unity. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When SIDE = 'L' or 'l' then +* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +* then LDA must be at least max( 1, n ). +* Unchanged on exit. +* +* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). +* Before entry, the leading m by n part of the array B must +* contain the matrix B, and on exit is overwritten by the +* transformed matrix. +* +* LDB - INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* Unchanged on exit. +* +* +* Level 3 Blas routine. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Local Scalars .. + LOGICAL LSIDE, NOUNIT, UPPER + INTEGER I, INFO, J, K, NROWA + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + LSIDE = LSAME( SIDE , 'L' ) + IF( LSIDE )THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME( DIAG , 'N' ) + UPPER = LSAME( UPLO , 'U' ) +* + INFO = 0 + IF( ( .NOT.LSIDE ).AND. + $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 2 + ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN + INFO = 3 + ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. + $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN + INFO = 4 + ELSE IF( M .LT.0 )THEN + INFO = 5 + ELSE IF( N .LT.0 )THEN + INFO = 6 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 9 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTRMM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF( LSIDE )THEN + IF( LSAME( TRANSA, 'N' ) )THEN +* +* Form B := alpha*A*B. +* + IF( UPPER )THEN + DO 50, J = 1, N + DO 40, K = 1, M + IF( B( K, J ).NE.ZERO )THEN + TEMP = ALPHA*B( K, J ) + DO 30, I = 1, K - 1 + B( I, J ) = B( I, J ) + TEMP*A( I, K ) + 30 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP*A( K, K ) + B( K, J ) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80, J = 1, N + DO 70 K = M, 1, -1 + IF( B( K, J ).NE.ZERO )THEN + TEMP = ALPHA*B( K, J ) + B( K, J ) = TEMP + IF( NOUNIT ) + $ B( K, J ) = B( K, J )*A( K, K ) + DO 60, I = K + 1, M + B( I, J ) = B( I, J ) + TEMP*A( I, K ) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* Form B := alpha*A'*B. +* + IF( UPPER )THEN + DO 110, J = 1, N + DO 100, I = M, 1, -1 + TEMP = B( I, J ) + IF( NOUNIT ) + $ TEMP = TEMP*A( I, I ) + DO 90, K = 1, I - 1 + TEMP = TEMP + A( K, I )*B( K, J ) + 90 CONTINUE + B( I, J ) = ALPHA*TEMP + 100 CONTINUE + 110 CONTINUE + ELSE + DO 140, J = 1, N + DO 130, I = 1, M + TEMP = B( I, J ) + IF( NOUNIT ) + $ TEMP = TEMP*A( I, I ) + DO 120, K = I + 1, M + TEMP = TEMP + A( K, I )*B( K, J ) + 120 CONTINUE + B( I, J ) = ALPHA*TEMP + 130 CONTINUE + 140 CONTINUE + END IF + END IF + ELSE + IF( LSAME( TRANSA, 'N' ) )THEN +* +* Form B := alpha*B*A. +* + IF( UPPER )THEN + DO 180, J = N, 1, -1 + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 150, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 150 CONTINUE + DO 170, K = 1, J - 1 + IF( A( K, J ).NE.ZERO )THEN + TEMP = ALPHA*A( K, J ) + DO 160, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + ELSE + DO 220, J = 1, N + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 190, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 190 CONTINUE + DO 210, K = J + 1, N + IF( A( K, J ).NE.ZERO )THEN + TEMP = ALPHA*A( K, J ) + DO 200, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 200 CONTINUE + END IF + 210 CONTINUE + 220 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*A'. +* + IF( UPPER )THEN + DO 260, K = 1, N + DO 240, J = 1, K - 1 + IF( A( J, K ).NE.ZERO )THEN + TEMP = ALPHA*A( J, K ) + DO 230, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 230 CONTINUE + END IF + 240 CONTINUE + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*A( K, K ) + IF( TEMP.NE.ONE )THEN + DO 250, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 250 CONTINUE + END IF + 260 CONTINUE + ELSE + DO 300, K = N, 1, -1 + DO 280, J = K + 1, N + IF( A( J, K ).NE.ZERO )THEN + TEMP = ALPHA*A( J, K ) + DO 270, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 270 CONTINUE + END IF + 280 CONTINUE + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*A( K, K ) + IF( TEMP.NE.ONE )THEN + DO 290, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 290 CONTINUE + END IF + 300 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMM . +* + END + SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* Purpose +* ======= +* +* DTRMV performs one of the matrix-vector operations +* +* x := A*x, or x := A'*x, +* +* where x is an n element vector and A is an n by n unit, or non-unit, +* upper or lower triangular matrix. +* +* Parameters +* ========== +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the matrix is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* Unchanged on exit. +* +* TRANS - CHARACTER*1. +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' x := A*x. +* +* TRANS = 'T' or 't' x := A'*x. +* +* TRANS = 'C' or 'c' x := A'*x. +* +* Unchanged on exit. +* +* DIAG - CHARACTER*1. +* On entry, DIAG specifies whether or not A is unit +* triangular as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the order of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). +* Before entry with UPLO = 'U' or 'u', the leading n by n +* upper triangular part of the array A must contain the upper +* triangular matrix and the strictly lower triangular part of +* A is not referenced. +* Before entry with UPLO = 'L' or 'l', the leading n by n +* lower triangular part of the array A must contain the lower +* triangular matrix and the strictly upper triangular part of +* A is not referenced. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced either, but are assumed to be unity. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, n ). +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ). +* Before entry, the incremented array X must contain the n +* element vector x. On exit, X is overwritten with the +* tranformed vector x. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, KX + LOGICAL NOUNIT +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTRMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +* +* Set up the start point in X if the increment is not unity. This +* will be ( N - 1 )*INCX too small for descending loops. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form x := A*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + DO 10, I = 1, J - 1 + X( I ) = X( I ) + TEMP*A( I, J ) + 10 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( J, J ) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 30, I = 1, J - 1 + X( IX ) = X( IX ) + TEMP*A( I, J ) + IX = IX + INCX + 30 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( J, J ) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 60, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + DO 50, I = N, J + 1, -1 + X( I ) = X( I ) + TEMP*A( I, J ) + 50 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( J, J ) + END IF + 60 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 80, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 70, I = N, J + 1, -1 + X( IX ) = X( IX ) + TEMP*A( I, J ) + IX = IX - INCX + 70 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( J, J ) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* Form x := A'*x. +* + IF( LSAME( UPLO, 'U' ) )THEN + IF( INCX.EQ.1 )THEN + DO 100, J = N, 1, -1 + TEMP = X( J ) + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 90, I = J - 1, 1, -1 + TEMP = TEMP + A( I, J )*X( I ) + 90 CONTINUE + X( J ) = TEMP + 100 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 120, J = N, 1, -1 + TEMP = X( JX ) + IX = JX + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 110, I = J - 1, 1, -1 + IX = IX - INCX + TEMP = TEMP + A( I, J )*X( IX ) + 110 CONTINUE + X( JX ) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 140, J = 1, N + TEMP = X( J ) + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 130, I = J + 1, N + TEMP = TEMP + A( I, J )*X( I ) + 130 CONTINUE + X( J ) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160, J = 1, N + TEMP = X( JX ) + IX = JX + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 150, I = J + 1, N + IX = IX + INCX + TEMP = TEMP + A( I, J )*X( IX ) + 150 CONTINUE + X( JX ) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRMV . +* + END + LOGICAL FUNCTION LSAME( CA, CB ) +* +* -- LAPACK auxiliary routine (version 2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* January 31, 1994 +* +* .. Scalar Arguments .. + CHARACTER CA, CB +* .. +* +* Purpose +* ======= +* +* LSAME returns .TRUE. if CA is the same letter as CB regardless of +* case. +* +* Arguments +* ========= +* +* CA (input) CHARACTER*1 +* CB (input) CHARACTER*1 +* CA and CB specify the single characters to be compared. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA, INTB, ZCODE +* .. +* .. Executable Statements .. +* +* Test if the characters are equal +* + LSAME = CA.EQ.CB + IF( LSAME ) + $ RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + ZCODE = ICHAR( 'Z' ) +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR( CA ) + INTB = ICHAR( CB ) +* + IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 + IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 +* + ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.129 .AND. INTA.LE.137 .OR. + $ INTA.GE.145 .AND. INTA.LE.153 .OR. + $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 + IF( INTB.GE.129 .AND. INTB.LE.137 .OR. + $ INTB.GE.145 .AND. INTB.LE.153 .OR. + $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 +* + ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 + IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 + END IF + LSAME = INTA.EQ.INTB +* +* RETURN +* +* End of LSAME +* + END + SUBROUTINE XERBLA( SRNAME, INFO ) +* +* -- LAPACK auxiliary routine (preliminary version) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. Scalar Arguments .. + CHARACTER*6 SRNAME + INTEGER INFO +* .. +* +* Purpose +* ======= +* +* XERBLA is an error handler for the LAPACK routines. +* It is called by an LAPACK routine if an input parameter has an +* invalid value. A message is printed and execution stops. +* +* Installers may consider modifying the STOP statement in order to +* call system-specific exception-handling facilities. +* +* Arguments +* ========= +* +* SRNAME (input) CHARACTER*6 +* The name of the routine which called XERBLA. +* +* INFO (input) INTEGER +* The position of the invalid parameter in the parameter list +* of the calling routine. +* +* + WRITE( *, FMT = 9999 )SRNAME, INFO +* + STOP +* + 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END + SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, RT1, RT2 +* .. +* +* Purpose +* ======= +* +* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix +* [ A B ] +* [ B C ]. +* On return, RT1 is the eigenvalue of larger absolute value, and RT2 +* is the eigenvalue of smaller absolute value. +* +* Arguments +* ========= +* +* A (input) DOUBLE PRECISION +* The (1,1) element of the 2-by-2 matrix. +* +* B (input) DOUBLE PRECISION +* The (1,2) and (2,1) elements of the 2-by-2 matrix. +* +* C (input) DOUBLE PRECISION +* The (2,2) element of the 2-by-2 matrix. +* +* RT1 (output) DOUBLE PRECISION +* The eigenvalue of larger absolute value. +* +* RT2 (output) DOUBLE PRECISION +* The eigenvalue of smaller absolute value. +* +* Further Details +* =============== +* +* RT1 is accurate to a few ulps barring over/underflow. +* +* RT2 may be inaccurate if there is massive cancellation in the +* determinant A*C-B*B; higher precision or correctly rounded or +* correctly truncated arithmetic would be needed to compute RT2 +* accurately in all cases. +* +* Overflow is possible only if RT1 is within a factor of 5 of overflow. +* Underflow is harmless if the input data is 0 or exceeds +* underflow_threshold / macheps. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* +* Compute the eigenvalues +* + SM = A + C + DF = A - C + ADF = ABS( DF ) + TB = B + B + AB = ABS( TB ) + IF( ABS( A ).GT.ABS( C ) ) THEN + ACMX = A + ACMN = C + ELSE + ACMX = C + ACMN = A + END IF + IF( ADF.GT.AB ) THEN + RT = ADF*SQRT( ONE+( AB / ADF )**2 ) + ELSE IF( ADF.LT.AB ) THEN + RT = AB*SQRT( ONE+( ADF / AB )**2 ) + ELSE +* +* Includes case AB=ADF=0 +* + RT = AB*SQRT( TWO ) + END IF + IF( SM.LT.ZERO ) THEN + RT1 = HALF*( SM-RT ) +* +* Order of execution important. +* To get fully accurate smaller eigenvalue, +* next line needs to be executed in higher precision. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE IF( SM.GT.ZERO ) THEN + RT1 = HALF*( SM+RT ) +* +* Order of execution important. +* To get fully accurate smaller eigenvalue, +* next line needs to be executed in higher precision. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE +* +* Includes case RT1 = RT2 = 0 +* + RT1 = HALF*RT + RT2 = -HALF*RT + END IF + RETURN +* +* End of DLAE2 +* + END + SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 +* .. +* +* Purpose +* ======= +* +* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix +* [ A B ] +* [ B C ]. +* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the +* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right +* eigenvector for RT1, giving the decomposition +* +* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] +* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. +* +* Arguments +* ========= +* +* A (input) DOUBLE PRECISION +* The (1,1) element of the 2-by-2 matrix. +* +* B (input) DOUBLE PRECISION +* The (1,2) element and the conjugate of the (2,1) element of +* the 2-by-2 matrix. +* +* C (input) DOUBLE PRECISION +* The (2,2) element of the 2-by-2 matrix. +* +* RT1 (output) DOUBLE PRECISION +* The eigenvalue of larger absolute value. +* +* RT2 (output) DOUBLE PRECISION +* The eigenvalue of smaller absolute value. +* +* CS1 (output) DOUBLE PRECISION +* SN1 (output) DOUBLE PRECISION +* The vector (CS1, SN1) is a unit right eigenvector for RT1. +* +* Further Details +* =============== +* +* RT1 is accurate to a few ulps barring over/underflow. +* +* RT2 may be inaccurate if there is massive cancellation in the +* determinant A*C-B*B; higher precision or correctly rounded or +* correctly truncated arithmetic would be needed to compute RT2 +* accurately in all cases. +* +* CS1 and SN1 are accurate to a few ulps barring over/underflow. +* +* Overflow is possible only if RT1 is within a factor of 5 of overflow. +* Underflow is harmless if the input data is 0 or exceeds +* underflow_threshold / macheps. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) +* .. +* .. Local Scalars .. + INTEGER SGN1, SGN2 + DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, + $ TB, TN +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. +* +* Compute the eigenvalues +* + SM = A + C + DF = A - C + ADF = ABS( DF ) + TB = B + B + AB = ABS( TB ) + IF( ABS( A ).GT.ABS( C ) ) THEN + ACMX = A + ACMN = C + ELSE + ACMX = C + ACMN = A + END IF + IF( ADF.GT.AB ) THEN + RT = ADF*SQRT( ONE+( AB / ADF )**2 ) + ELSE IF( ADF.LT.AB ) THEN + RT = AB*SQRT( ONE+( ADF / AB )**2 ) + ELSE +* +* Includes case AB=ADF=0 +* + RT = AB*SQRT( TWO ) + END IF + IF( SM.LT.ZERO ) THEN + RT1 = HALF*( SM-RT ) + SGN1 = -1 +* +* Order of execution important. +* To get fully accurate smaller eigenvalue, +* next line needs to be executed in higher precision. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE IF( SM.GT.ZERO ) THEN + RT1 = HALF*( SM+RT ) + SGN1 = 1 +* +* Order of execution important. +* To get fully accurate smaller eigenvalue, +* next line needs to be executed in higher precision. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE +* +* Includes case RT1 = RT2 = 0 +* + RT1 = HALF*RT + RT2 = -HALF*RT + SGN1 = 1 + END IF +* +* Compute the eigenvector +* + IF( DF.GE.ZERO ) THEN + CS = DF + RT + SGN2 = 1 + ELSE + CS = DF - RT + SGN2 = -1 + END IF + ACS = ABS( CS ) + IF( ACS.GT.AB ) THEN + CT = -TB / CS + SN1 = ONE / SQRT( ONE+CT*CT ) + CS1 = CT*SN1 + ELSE + IF( AB.EQ.ZERO ) THEN + CS1 = ONE + SN1 = ZERO + ELSE + TN = -CS / TB + CS1 = ONE / SQRT( ONE+TN*TN ) + SN1 = TN*CS1 + END IF + END IF + IF( SGN1.EQ.SGN2 ) THEN + TN = CS1 + CS1 = -SN1 + SN1 = TN + END IF + RETURN +* +* End of DLAEV2 +* + END + DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM + INTEGER N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* Purpose +* ======= +* +* DLANST returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* real symmetric tridiagonal matrix A. +* +* Description +* =========== +* +* DLANST returns the value +* +* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER*1 +* Specifies the value to be returned in DLANST as described +* above. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. When N = 0, DLANST is +* set to zero. +* +* D (input) DOUBLE PRECISION array, dimension (N) +* The diagonal elements of A. +* +* E (input) DOUBLE PRECISION array, dimension (N-1) +* The (n-1) sub-diagonal or super-diagonal elements of A. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I + DOUBLE PRECISION ANORM, SCALE, SUM +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.LE.0 ) THEN + ANORM = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + ANORM = ABS( D( N ) ) + DO 10 I = 1, N - 1 + ANORM = MAX( ANORM, ABS( D( I ) ) ) + ANORM = MAX( ANORM, ABS( E( I ) ) ) + 10 CONTINUE + ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR. + $ LSAME( NORM, 'I' ) ) THEN +* +* Find norm1(A). +* + IF( N.EQ.1 ) THEN + ANORM = ABS( D( 1 ) ) + ELSE + ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), + $ ABS( E( N-1 ) )+ABS( D( N ) ) ) + DO 20 I = 2, N - 1 + ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+ + $ ABS( E( I-1 ) ) ) + 20 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( N.GT.1 ) THEN + CALL DLASSQ( N-1, E, 1, SCALE, SUM ) + SUM = 2*SUM + END IF + CALL DLASSQ( N, D, 1, SCALE, SUM ) + ANORM = SCALE*SQRT( SUM ) + END IF +* + DLANST = ANORM + RETURN +* +* End of DLANST +* + END + DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER NORM, UPLO + INTEGER LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DLANSY returns the value of the one norm, or the Frobenius norm, or +* the infinity norm, or the element of largest absolute value of a +* real symmetric matrix A. +* +* Description +* =========== +* +* DLANSY returns the value +* +* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm' +* ( +* ( norm1(A), NORM = '1', 'O' or 'o' +* ( +* ( normI(A), NORM = 'I' or 'i' +* ( +* ( normF(A), NORM = 'F', 'f', 'E' or 'e' +* +* where norm1 denotes the one norm of a matrix (maximum column sum), +* normI denotes the infinity norm of a matrix (maximum row sum) and +* normF denotes the Frobenius norm of a matrix (square root of sum of +* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm. +* +* Arguments +* ========= +* +* NORM (input) CHARACTER*1 +* Specifies the value to be returned in DLANSY as described +* above. +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is to be referenced. +* = 'U': Upper triangular part of A is referenced +* = 'L': Lower triangular part of A is referenced +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. When N = 0, DLANSY is +* set to zero. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The symmetric matrix A. If UPLO = 'U', the leading n by n +* upper triangular part of A contains the upper triangular part +* of the matrix A, and the strictly lower triangular part of A +* is not referenced. If UPLO = 'L', the leading n by n lower +* triangular part of A contains the lower triangular part of +* the matrix A, and the strictly upper triangular part of A is +* not referenced. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(N,1). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), +* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, +* WORK is not referenced. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE +* .. +* .. External Subroutines .. + EXTERNAL DLASSQ +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* Find max(abs(A(i,j))). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + $ ( NORM.EQ.'1' ) ) THEN +* +* Find normI(A) ( = norm1(A), since A is symmetric). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + SUM = ZERO + DO 50 I = 1, J - 1 + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 50 CONTINUE + WORK( J ) = SUM + ABS( A( J, J ) ) + 60 CONTINUE + DO 70 I = 1, N + VALUE = MAX( VALUE, WORK( I ) ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + WORK( I ) = ZERO + 80 CONTINUE + DO 100 J = 1, N + SUM = WORK( J ) + ABS( A( J, J ) ) + DO 90 I = J + 1, N + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 90 CONTINUE + VALUE = MAX( VALUE, SUM ) + 100 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* Find normF(A). +* + SCALE = ZERO + SUM = ONE + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 2, N + CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) + 110 CONTINUE + ELSE + DO 120 J = 1, N - 1 + CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) + 120 CONTINUE + END IF + SUM = 2*SUM + CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANSY = VALUE + RETURN +* +* End of DLANSY +* + END + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION X, Y +* .. +* +* Purpose +* ======= +* +* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary +* overflow. +* +* Arguments +* ========= +* +* X (input) DOUBLE PRECISION +* Y (input) DOUBLE PRECISION +* X and Y specify the values x and y. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION W, XABS, YABS, Z +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + W = MAX( XABS, YABS ) + Z = MIN( XABS, YABS ) + IF( Z.EQ.ZERO ) THEN + DLAPY2 = W + ELSE + DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) + END IF + RETURN +* +* End of DLAPY2 +* + END + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DLARF applies a real elementary reflector H to a real m by n matrix +* C, from either the left or the right. H is represented in the form +* +* H = I - tau * v * v' +* +* where tau is a real scalar and v is a real vector. +* +* If tau = 0, then H is taken to be the unit matrix. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': form H * C +* = 'R': form C * H +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* V (input) DOUBLE PRECISION array, dimension +* (1 + (M-1)*abs(INCV)) if SIDE = 'L' +* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' +* The vector v in the representation of H. V is not used if +* TAU = 0. +* +* INCV (input) INTEGER +* The increment between elements of v. INCV <> 0. +* +* TAU (input) DOUBLE PRECISION +* The value tau in the representation of H. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by the matrix H * C if SIDE = 'L', +* or C * H if SIDE = 'R'. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDC >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (N) if SIDE = 'L' +* or (M) if SIDE = 'R' +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DGER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C +* + IF( TAU.NE.ZERO ) THEN +* +* w := C' * v +* + CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, + $ WORK, 1 ) +* +* C := C - v * w' +* + CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* Form C * H +* + IF( TAU.NE.ZERO ) THEN +* +* w := C * v +* + CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C := C - w * v' +* + CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* End of DLARF +* + END + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* Purpose +* ======= +* +* DLARFB applies a real block reflector H or its transpose H' to a +* real m by n matrix C, from either the left or the right. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* = 'L': apply H or H' from the Left +* = 'R': apply H or H' from the Right +* +* TRANS (input) CHARACTER*1 +* = 'N': apply H (No transpose) +* = 'T': apply H' (Transpose) +* +* DIRECT (input) CHARACTER*1 +* Indicates how H is formed from a product of elementary +* reflectors +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Indicates how the vectors which define the elementary +* reflectors are stored: +* = 'C': Columnwise +* = 'R': Rowwise +* +* M (input) INTEGER +* The number of rows of the matrix C. +* +* N (input) INTEGER +* The number of columns of the matrix C. +* +* K (input) INTEGER +* The order of the matrix T (= the number of elementary +* reflectors whose product defines the block reflector). +* +* V (input) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,M) if STOREV = 'R' and SIDE = 'L' +* (LDV,N) if STOREV = 'R' and SIDE = 'R' +* The matrix V. See further details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); +* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); +* if STOREV = 'R', LDV >= K. +* +* T (input) DOUBLE PRECISION array, dimension (LDT,K) +* The triangular k by k matrix T in the representation of the +* block reflector. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) +* On entry, the m by n matrix C. +* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. +* +* LDC (input) INTEGER +* The leading dimension of the array C. LDA >= max(1,M). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) +* +* LDWORK (input) INTEGER +* The leading dimension of the array WORK. +* If SIDE = 'L', LDWORK >= max(1,N); +* if SIDE = 'R', LDWORK >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + CHARACTER TRANST + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DGEMM, DTRMM +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 ) (first K rows) +* ( V2 ) +* where V1 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) +* +* W := C1' +* + DO 10 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2'*V2 +* + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W' +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2 * W' +* + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W' +* + DO 30 J = 1, K + DO 20 I = 1, N + C( J, I ) = C( J, I ) - WORK( I, J ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V' +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2' +* + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* Let V = ( V1 ) +* ( V2 ) (last K rows) +* where V2 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) +* +* W := C2' +* + DO 70 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1'*V1 +* + CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W' +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1 * W' +* + CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W' +* + DO 90 J = 1, K + DO 80 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (stored in WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V' +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1' +* + CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* Let V = ( V1 V2 ) (V1: first K columns) +* where V1 is unit upper triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) +* +* W := C1' +* + DO 130 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2'*V2' +* + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V' * W' +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2' * W' +* + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W' +* + DO 150 J = 1, K + DO 140 I = 1, N + C( J, I ) = C( J, I ) - WORK( I, J ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1' +* + CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2' +* + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* Let V = ( V1 V2 ) (V2: last K columns) +* where V2 is unit lower triangular. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form H * C or H' * C where C = ( C1 ) +* ( C2 ) +* +* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) +* +* W := C2' +* + DO 190 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, + $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1'*V1' +* + CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, + $ C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T' or W * T +* + CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V' * W' +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1' * W' +* + CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, + $ V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W' +* + DO 210 J = 1, K + DO 200 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form C * H or C * H' where C = ( C1 C2 ) +* +* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2' +* + CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, + $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1' +* + CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T or W * T' +* + CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* End of DLARFB +* + END + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* Purpose +* ======= +* +* DLARFG generates a real elementary reflector H of order n, such +* that +* +* H * ( alpha ) = ( beta ), H' * H = I. +* ( x ) ( 0 ) +* +* where alpha and beta are scalars, and x is an (n-1)-element real +* vector. H is represented in the form +* +* H = I - tau * ( 1 ) * ( 1 v' ) , +* ( v ) +* +* where tau is a real scalar and v is a real (n-1)-element +* vector. +* +* If the elements of x are all zero, then tau = 0 and H is taken to be +* the unit matrix. +* +* Otherwise 1 <= tau <= 2. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the elementary reflector. +* +* ALPHA (input/output) DOUBLE PRECISION +* On entry, the value alpha. +* On exit, it is overwritten with the value beta. +* +* X (input/output) DOUBLE PRECISION array, dimension +* (1+(N-2)*abs(INCX)) +* On entry, the vector x. +* On exit, it is overwritten with the vector v. +* +* INCX (input) INTEGER +* The increment between elements of X. INCX > 0. +* +* TAU (output) DOUBLE PRECISION +* The value tau. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, KNT + DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2 +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN +* .. +* .. External Subroutines .. + EXTERNAL DSCAL +* .. +* .. Executable Statements .. +* + IF( N.LE.1 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DNRM2( N-1, X, INCX ) +* + IF( XNORM.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* general case +* + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA may be inaccurate; scale X and recompute them +* + RSAFMN = ONE / SAFMIN + KNT = 0 + 10 CONTINUE + KNT = KNT + 1 + CALL DSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHA = ALPHA*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* New BETA is at most 1, at least SAFMIN +* + XNORM = DNRM2( N-1, X, INCX ) + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* If ALPHA is subnormal, it may lose relative accuracy +* + ALPHA = BETA + DO 20 J = 1, KNT + ALPHA = ALPHA*SAFMIN + 20 CONTINUE + ELSE + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) + ALPHA = BETA + END IF + END IF +* + RETURN +* +* End of DLARFG +* + END + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* Purpose +* ======= +* +* DLARFT forms the triangular factor T of a real block reflector H +* of order n, which is defined as a product of k elementary reflectors. +* +* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; +* +* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. +* +* If STOREV = 'C', the vector which defines the elementary reflector +* H(i) is stored in the i-th column of the array V, and +* +* H = I - V * T * V' +* +* If STOREV = 'R', the vector which defines the elementary reflector +* H(i) is stored in the i-th row of the array V, and +* +* H = I - V' * T * V +* +* Arguments +* ========= +* +* DIRECT (input) CHARACTER*1 +* Specifies the order in which the elementary reflectors are +* multiplied to form the block reflector: +* = 'F': H = H(1) H(2) . . . H(k) (Forward) +* = 'B': H = H(k) . . . H(2) H(1) (Backward) +* +* STOREV (input) CHARACTER*1 +* Specifies how the vectors which define the elementary +* reflectors are stored (see also Further Details): +* = 'C': columnwise +* = 'R': rowwise +* +* N (input) INTEGER +* The order of the block reflector H. N >= 0. +* +* K (input) INTEGER +* The order of the triangular factor T (= the number of +* elementary reflectors). K >= 1. +* +* V (input/output) DOUBLE PRECISION array, dimension +* (LDV,K) if STOREV = 'C' +* (LDV,N) if STOREV = 'R' +* The matrix V. See further details. +* +* LDV (input) INTEGER +* The leading dimension of the array V. +* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i). +* +* T (output) DOUBLE PRECISION array, dimension (LDT,K) +* The k by k triangular factor T of the block reflector. +* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is +* lower triangular. The rest of the array is not used. +* +* LDT (input) INTEGER +* The leading dimension of the array T. LDT >= K. +* +* Further Details +* =============== +* +* The shape of the matrix V and the storage of the vectors which define +* the H(i) is best illustrated by the following example with n = 5 and +* k = 3. The elements equal to 1 are not stored; the corresponding +* array elements are modified but restored on exit. The rest of the +* array is not used. +* +* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': +* +* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) +* ( v1 1 ) ( 1 v2 v2 v2 ) +* ( v1 v2 1 ) ( 1 v3 v3 ) +* ( v1 v2 v3 ) +* ( v1 v2 v3 ) +* +* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': +* +* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) +* ( v1 v2 v3 ) ( v2 v2 v2 1 ) +* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) +* ( 1 v3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J + DOUBLE PRECISION VII +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DTRMV +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 20 I = 1, K + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* general case +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +* +* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) +* + CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), + $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, + $ T( 1, I ), 1 ) + ELSE +* +* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' +* + CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + END IF + V( I, I ) = VII +* +* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) +* + CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + END IF + 20 CONTINUE + ELSE + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(i) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* general case +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +* +* T(i+1:k,i) := +* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) +* + CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), + $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, + $ T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +* +* T(i+1:k,i) := +* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' +* + CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, + $ T( I+1, I ), 1 ) + V( I, N-K+I ) = VII + END IF +* +* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) +* + CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* End of DLARFT +* + END + SUBROUTINE DLARTG( F, G, CS, SN, R ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + DOUBLE PRECISION CS, F, G, R, SN +* .. +* +* Purpose +* ======= +* +* DLARTG generate a plane rotation so that +* +* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. +* [ -SN CS ] [ G ] [ 0 ] +* +* This is a slower, more accurate version of the BLAS1 routine DROTG, +* with the following other differences: +* F and G are unchanged on return. +* If G=0, then CS=1 and SN=0. +* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any +* floating point operations (saves work in DBDSQR when +* there are zeros on the diagonal). +* +* If F exceeds G in magnitude, CS will be positive. +* +* Arguments +* ========= +* +* F (input) DOUBLE PRECISION +* The first component of vector to be rotated. +* +* G (input) DOUBLE PRECISION +* The second component of vector to be rotated. +* +* CS (output) DOUBLE PRECISION +* The cosine of the rotation. +* +* SN (output) DOUBLE PRECISION +* The sine of the rotation. +* +* R (output) DOUBLE PRECISION +* The nonzero component of the rotated vector. +* +* This version has a few statements commented out for thread safety +* (machine parameters are computed on each entry). 10 feb 03, SJH. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) +* .. +* .. Local Scalars .. +* LOGICAL FIRST + INTEGER COUNT, I + DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, INT, LOG, MAX, SQRT +* .. +* .. Save statement .. +* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 +* .. +* .. Data statements .. +* DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* +* IF( FIRST ) THEN + SAFMIN = DLAMCH( 'S' ) + EPS = DLAMCH( 'E' ) + SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / + $ LOG( DLAMCH( 'B' ) ) / TWO ) + SAFMX2 = ONE / SAFMN2 +* FIRST = .FALSE. +* END IF + IF( G.EQ.ZERO ) THEN + CS = ONE + SN = ZERO + R = F + ELSE IF( F.EQ.ZERO ) THEN + CS = ZERO + SN = ONE + R = G + ELSE + F1 = F + G1 = G + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.GE.SAFMX2 ) THEN + COUNT = 0 + 10 CONTINUE + COUNT = COUNT + 1 + F1 = F1*SAFMN2 + G1 = G1*SAFMN2 + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.GE.SAFMX2 ) + $ GO TO 10 + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + DO 20 I = 1, COUNT + R = R*SAFMX2 + 20 CONTINUE + ELSE IF( SCALE.LE.SAFMN2 ) THEN + COUNT = 0 + 30 CONTINUE + COUNT = COUNT + 1 + F1 = F1*SAFMX2 + G1 = G1*SAFMX2 + SCALE = MAX( ABS( F1 ), ABS( G1 ) ) + IF( SCALE.LE.SAFMN2 ) + $ GO TO 30 + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + DO 40 I = 1, COUNT + R = R*SAFMN2 + 40 CONTINUE + ELSE + R = SQRT( F1**2+G1**2 ) + CS = F1 / R + SN = G1 / R + END IF + IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN + CS = -CS + SN = -SN + R = -R + END IF + END IF + RETURN +* +* End of DLARTG +* + END + SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER TYPE + INTEGER INFO, KL, KU, LDA, M, N + DOUBLE PRECISION CFROM, CTO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DLASCL multiplies the M by N real matrix A by the real scalar +* CTO/CFROM. This is done without over/underflow as long as the final +* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that +* A may be full, upper triangular, lower triangular, upper Hessenberg, +* or banded. +* +* Arguments +* ========= +* +* TYPE (input) CHARACTER*1 +* TYPE indices the storage type of the input matrix. +* = 'G': A is a full matrix. +* = 'L': A is a lower triangular matrix. +* = 'U': A is an upper triangular matrix. +* = 'H': A is an upper Hessenberg matrix. +* = 'B': A is a symmetric band matrix with lower bandwidth KL +* and upper bandwidth KU and with the only the lower +* half stored. +* = 'Q': A is a symmetric band matrix with lower bandwidth KL +* and upper bandwidth KU and with the only the upper +* half stored. +* = 'Z': A is a band matrix with lower bandwidth KL and upper +* bandwidth KU. +* +* KL (input) INTEGER +* The lower bandwidth of A. Referenced only if TYPE = 'B', +* 'Q' or 'Z'. +* +* KU (input) INTEGER +* The upper bandwidth of A. Referenced only if TYPE = 'B', +* 'Q' or 'Z'. +* +* CFROM (input) DOUBLE PRECISION +* CTO (input) DOUBLE PRECISION +* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed +* without over/underflow if the final result CTO*A(I,J)/CFROM +* can be represented without over/underflow. CFROM must be +* nonzero. +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* The matrix to be multiplied by CTO/CFROM. See TYPE for the +* storage type. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* INFO (output) INTEGER +* 0 - successful exit +* <0 - if INFO = -i, the i-th argument had an illegal value. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL DONE + INTEGER I, ITYPE, J, K1, K2, K3, K4 + DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 +* + IF( LSAME( TYPE, 'G' ) ) THEN + ITYPE = 0 + ELSE IF( LSAME( TYPE, 'L' ) ) THEN + ITYPE = 1 + ELSE IF( LSAME( TYPE, 'U' ) ) THEN + ITYPE = 2 + ELSE IF( LSAME( TYPE, 'H' ) ) THEN + ITYPE = 3 + ELSE IF( LSAME( TYPE, 'B' ) ) THEN + ITYPE = 4 + ELSE IF( LSAME( TYPE, 'Q' ) ) THEN + ITYPE = 5 + ELSE IF( LSAME( TYPE, 'Z' ) ) THEN + ITYPE = 6 + ELSE + ITYPE = -1 + END IF +* + IF( ITYPE.EQ.-1 ) THEN + INFO = -1 + ELSE IF( CFROM.EQ.ZERO ) THEN + INFO = -4 + ELSE IF( M.LT.0 ) THEN + INFO = -6 + ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. + $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN + INFO = -7 + ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN + INFO = -9 + ELSE IF( ITYPE.GE.4 ) THEN + IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN + INFO = -2 + ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. + $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) + $ THEN + INFO = -3 + ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. + $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. + $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN + INFO = -9 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASCL', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. M.EQ.0 ) + $ RETURN +* +* Get machine parameters +* + SMLNUM = DLAMCH( 'S' ) + BIGNUM = ONE / SMLNUM +* + CFROMC = CFROM + CTOC = CTO +* + 10 CONTINUE + CFROM1 = CFROMC*SMLNUM + CTO1 = CTOC / BIGNUM + IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN + MUL = SMLNUM + DONE = .FALSE. + CFROMC = CFROM1 + ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN + MUL = BIGNUM + DONE = .FALSE. + CTOC = CTO1 + ELSE + MUL = CTOC / CFROMC + DONE = .TRUE. + END IF +* + IF( ITYPE.EQ.0 ) THEN +* +* Full matrix +* + DO 30 J = 1, N + DO 20 I = 1, M + A( I, J ) = A( I, J )*MUL + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( ITYPE.EQ.1 ) THEN +* +* Lower triangular matrix +* + DO 50 J = 1, N + DO 40 I = J, M + A( I, J ) = A( I, J )*MUL + 40 CONTINUE + 50 CONTINUE +* + ELSE IF( ITYPE.EQ.2 ) THEN +* +* Upper triangular matrix +* + DO 70 J = 1, N + DO 60 I = 1, MIN( J, M ) + A( I, J ) = A( I, J )*MUL + 60 CONTINUE + 70 CONTINUE +* + ELSE IF( ITYPE.EQ.3 ) THEN +* +* Upper Hessenberg matrix +* + DO 90 J = 1, N + DO 80 I = 1, MIN( J+1, M ) + A( I, J ) = A( I, J )*MUL + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( ITYPE.EQ.4 ) THEN +* +* Lower half of a symmetric band matrix +* + K3 = KL + 1 + K4 = N + 1 + DO 110 J = 1, N + DO 100 I = 1, MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 100 CONTINUE + 110 CONTINUE +* + ELSE IF( ITYPE.EQ.5 ) THEN +* +* Upper half of a symmetric band matrix +* + K1 = KU + 2 + K3 = KU + 1 + DO 130 J = 1, N + DO 120 I = MAX( K1-J, 1 ), K3 + A( I, J ) = A( I, J )*MUL + 120 CONTINUE + 130 CONTINUE +* + ELSE IF( ITYPE.EQ.6 ) THEN +* +* Band matrix +* + K1 = KL + KU + 2 + K2 = KL + 1 + K3 = 2*KL + KU + 1 + K4 = KL + KU + 1 + M + DO 150 J = 1, N + DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) + A( I, J ) = A( I, J )*MUL + 140 CONTINUE + 150 CONTINUE +* + END IF +* + IF( .NOT.DONE ) + $ GO TO 10 +* + RETURN +* +* End of DLASCL +* + END + SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, M, N + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DLASET initializes an m-by-n matrix A to BETA on the diagonal and +* ALPHA on the offdiagonals. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies the part of the matrix A to be set. +* = 'U': Upper triangular part is set; the strictly lower +* triangular part of A is not changed. +* = 'L': Lower triangular part is set; the strictly upper +* triangular part of A is not changed. +* Otherwise: All of the matrix A is set. +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* ALPHA (input) DOUBLE PRECISION +* The constant to which the offdiagonal elements are to be set. +* +* BETA (input) DOUBLE PRECISION +* The constant to which the diagonal elements are to be set. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On exit, the leading m-by-n submatrix of A is set as follows: +* +* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, +* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, +* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, +* +* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, J +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Set the strictly upper triangular or trapezoidal part of the +* array to ALPHA. +* + DO 20 J = 2, N + DO 10 I = 1, MIN( J-1, M ) + A( I, J ) = ALPHA + 10 CONTINUE + 20 CONTINUE +* + ELSE IF( LSAME( UPLO, 'L' ) ) THEN +* +* Set the strictly lower triangular or trapezoidal part of the +* array to ALPHA. +* + DO 40 J = 1, MIN( M, N ) + DO 30 I = J + 1, M + A( I, J ) = ALPHA + 30 CONTINUE + 40 CONTINUE +* + ELSE +* +* Set the leading m-by-n submatrix to ALPHA. +* + DO 60 J = 1, N + DO 50 I = 1, M + A( I, J ) = ALPHA + 50 CONTINUE + 60 CONTINUE + END IF +* +* Set the first min(M,N) diagonal elements to BETA. +* + DO 70 I = 1, MIN( M, N ) + A( I, I ) = BETA + 70 CONTINUE +* + RETURN +* +* End of DLASET +* + END + SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER DIRECT, PIVOT, SIDE + INTEGER LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) +* .. +* +* Purpose +* ======= +* +* DLASR applies a sequence of plane rotations to a real matrix A, +* from either the left or the right. +* +* When SIDE = 'L', the transformation takes the form +* +* A := P*A +* +* and when SIDE = 'R', the transformation takes the form +* +* A := A*P**T +* +* where P is an orthogonal matrix consisting of a sequence of z plane +* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', +* and P**T is the transpose of P. +* +* When DIRECT = 'F' (Forward sequence), then +* +* P = P(z-1) * ... * P(2) * P(1) +* +* and when DIRECT = 'B' (Backward sequence), then +* +* P = P(1) * P(2) * ... * P(z-1) +* +* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation +* +* R(k) = ( c(k) s(k) ) +* = ( -s(k) c(k) ). +* +* When PIVOT = 'V' (Variable pivot), the rotation is performed +* for the plane (k,k+1), i.e., P(k) has the form +* +* P(k) = ( 1 ) +* ( ... ) +* ( 1 ) +* ( c(k) s(k) ) +* ( -s(k) c(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* +* where R(k) appears as a rank-2 modification to the identity matrix in +* rows and columns k and k+1. +* +* When PIVOT = 'T' (Top pivot), the rotation is performed for the +* plane (1,k+1), so P(k) has the form +* +* P(k) = ( c(k) s(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* ( -s(k) c(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* +* where R(k) appears in rows and columns 1 and k+1. +* +* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is +* performed for the plane (k,z), giving P(k) the form +* +* P(k) = ( 1 ) +* ( ... ) +* ( 1 ) +* ( c(k) s(k) ) +* ( 1 ) +* ( ... ) +* ( 1 ) +* ( -s(k) c(k) ) +* +* where R(k) appears in rows and columns k and z. The rotations are +* performed without ever forming P(k) explicitly. +* +* Arguments +* ========= +* +* SIDE (input) CHARACTER*1 +* Specifies whether the plane rotation matrix P is applied to +* A on the left or the right. +* = 'L': Left, compute A := P*A +* = 'R': Right, compute A:= A*P**T +* +* PIVOT (input) CHARACTER*1 +* Specifies the plane for which P(k) is a plane rotation +* matrix. +* = 'V': Variable pivot, the plane (k,k+1) +* = 'T': Top pivot, the plane (1,k+1) +* = 'B': Bottom pivot, the plane (k,z) +* +* DIRECT (input) CHARACTER*1 +* Specifies whether P is a forward or backward sequence of +* plane rotations. +* = 'F': Forward, P = P(z-1)*...*P(2)*P(1) +* = 'B': Backward, P = P(1)*P(2)*...*P(z-1) +* +* M (input) INTEGER +* The number of rows of the matrix A. If m <= 1, an immediate +* return is effected. +* +* N (input) INTEGER +* The number of columns of the matrix A. If n <= 1, an +* immediate return is effected. +* +* C (input) DOUBLE PRECISION array, dimension +* (M-1) if SIDE = 'L' +* (N-1) if SIDE = 'R' +* The cosines c(k) of the plane rotations. +* +* S (input) DOUBLE PRECISION array, dimension +* (M-1) if SIDE = 'L' +* (N-1) if SIDE = 'R' +* The sines s(k) of the plane rotations. The 2-by-2 plane +* rotation part of the matrix P(k), R(k), has the form +* R(k) = ( c(k) s(k) ) +* ( -s(k) c(k) ). +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* The M-by-N matrix A. On exit, A is overwritten by P*A if +* SIDE = 'R' or by A*P**T if SIDE = 'L'. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION CTEMP, STEMP, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN + INFO = 1 + ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, + $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN + INFO = 2 + ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) + $ THEN + INFO = 3 + ELSE IF( M.LT.0 ) THEN + INFO = 4 + ELSE IF( N.LT.0 ) THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = 9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASR ', INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +* +* Form P * A +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 20 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 10 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 40 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 30 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 30 CONTINUE + END IF + 40 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 60 J = 2, M + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 50 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 80 J = M, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 70 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 70 CONTINUE + END IF + 80 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 100 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 90 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 90 CONTINUE + END IF + 100 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 120 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 110 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 110 CONTINUE + END IF + 120 CONTINUE + END IF + END IF + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* Form A * P' +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 140 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 130 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 130 CONTINUE + END IF + 140 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 160 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 150 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 150 CONTINUE + END IF + 160 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 180 J = 2, N + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 170 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 200 J = N, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 190 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 190 CONTINUE + END IF + 200 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 220 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 210 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 210 CONTINUE + END IF + 220 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 240 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 230 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 230 CONTINUE + END IF + 240 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DLASR +* + END + SUBROUTINE DLASRT( ID, N, D, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER ID + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ) +* .. +* +* Purpose +* ======= +* +* Sort the numbers in D in increasing order (if ID = 'I') or +* in decreasing order (if ID = 'D' ). +* +* Use Quick Sort, reverting to Insertion sort on arrays of +* size <= 20. Dimension of STACK limits N to about 2**32. +* +* Arguments +* ========= +* +* ID (input) CHARACTER*1 +* = 'I': sort D in increasing order; +* = 'D': sort D in decreasing order. +* +* N (input) INTEGER +* The length of the array D. +* +* D (input/output) DOUBLE PRECISION array, dimension (N) +* On entry, the array to be sorted. +* On exit, D has been sorted into increasing order +* (D(1) <= ... <= D(N) ) or into decreasing order +* (D(1) >= ... >= D(N) ), depending on ID. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + INTEGER SELECT + PARAMETER ( SELECT = 20 ) +* .. +* .. Local Scalars .. + INTEGER DIR, ENDD, I, J, START, STKPNT + DOUBLE PRECISION D1, D2, D3, DMNMX, TMP +* .. +* .. Local Arrays .. + INTEGER STACK( 2, 32 ) +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input paramters. +* + INFO = 0 + DIR = -1 + IF( LSAME( ID, 'D' ) ) THEN + DIR = 0 + ELSE IF( LSAME( ID, 'I' ) ) THEN + DIR = 1 + END IF + IF( DIR.EQ.-1 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASRT', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.1 ) + $ RETURN +* + STKPNT = 1 + STACK( 1, 1 ) = 1 + STACK( 2, 1 ) = N + 10 CONTINUE + START = STACK( 1, STKPNT ) + ENDD = STACK( 2, STKPNT ) + STKPNT = STKPNT - 1 + IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN +* +* Do Insertion sort on D( START:ENDD ) +* + IF( DIR.EQ.0 ) THEN +* +* Sort into decreasing order +* + DO 30 I = START + 1, ENDD + DO 20 J = I, START + 1, -1 + IF( D( J ).GT.D( J-1 ) ) THEN + DMNMX = D( J ) + D( J ) = D( J-1 ) + D( J-1 ) = DMNMX + ELSE + GO TO 30 + END IF + 20 CONTINUE + 30 CONTINUE +* + ELSE +* +* Sort into increasing order +* + DO 50 I = START + 1, ENDD + DO 40 J = I, START + 1, -1 + IF( D( J ).LT.D( J-1 ) ) THEN + DMNMX = D( J ) + D( J ) = D( J-1 ) + D( J-1 ) = DMNMX + ELSE + GO TO 50 + END IF + 40 CONTINUE + 50 CONTINUE +* + END IF +* + ELSE IF( ENDD-START.GT.SELECT ) THEN +* +* Partition D( START:ENDD ) and stack parts, largest one first +* +* Choose partition entry as median of 3 +* + D1 = D( START ) + D2 = D( ENDD ) + I = ( START+ENDD ) / 2 + D3 = D( I ) + IF( D1.LT.D2 ) THEN + IF( D3.LT.D1 ) THEN + DMNMX = D1 + ELSE IF( D3.LT.D2 ) THEN + DMNMX = D3 + ELSE + DMNMX = D2 + END IF + ELSE + IF( D3.LT.D2 ) THEN + DMNMX = D2 + ELSE IF( D3.LT.D1 ) THEN + DMNMX = D3 + ELSE + DMNMX = D1 + END IF + END IF +* + IF( DIR.EQ.0 ) THEN +* +* Sort into decreasing order +* + I = START - 1 + J = ENDD + 1 + 60 CONTINUE + 70 CONTINUE + J = J - 1 + IF( D( J ).LT.DMNMX ) + $ GO TO 70 + 80 CONTINUE + I = I + 1 + IF( D( I ).GT.DMNMX ) + $ GO TO 80 + IF( I.LT.J ) THEN + TMP = D( I ) + D( I ) = D( J ) + D( J ) = TMP + GO TO 60 + END IF + IF( J-START.GT.ENDD-J-1 ) THEN + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + ELSE + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + END IF + ELSE +* +* Sort into increasing order +* + I = START - 1 + J = ENDD + 1 + 90 CONTINUE + 100 CONTINUE + J = J - 1 + IF( D( J ).GT.DMNMX ) + $ GO TO 100 + 110 CONTINUE + I = I + 1 + IF( D( I ).LT.DMNMX ) + $ GO TO 110 + IF( I.LT.J ) THEN + TMP = D( I ) + D( I ) = D( J ) + D( J ) = TMP + GO TO 90 + END IF + IF( J-START.GT.ENDD-J-1 ) THEN + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + ELSE + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = J + 1 + STACK( 2, STKPNT ) = ENDD + STKPNT = STKPNT + 1 + STACK( 1, STKPNT ) = START + STACK( 2, STKPNT ) = J + END IF + END IF + END IF + IF( STKPNT.GT.0 ) + $ GO TO 10 + RETURN +* +* End of DLASRT +* + END + SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* Purpose +* ======= +* +* DLASSQ returns the values scl and smsq such that +* +* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, +* +* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is +* assumed to be non-negative and scl returns the value +* +* scl = max( scale, abs( x( i ) ) ). +* +* scale and sumsq must be supplied in SCALE and SUMSQ and +* scl and smsq are overwritten on SCALE and SUMSQ respectively. +* +* The routine makes only one pass through the vector x. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of elements to be used from the vector X. +* +* X (input) DOUBLE PRECISION array, dimension (N) +* The vector for which a scaled sum of squares is computed. +* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. +* +* INCX (input) INTEGER +* The increment between successive values of the vector X. +* INCX > 0. +* +* SCALE (input/output) DOUBLE PRECISION +* On entry, the value scale in the equation above. +* On exit, SCALE is overwritten with scl , the scaling factor +* for the sum of squares. +* +* SUMSQ (input/output) DOUBLE PRECISION +* On entry, the value sumsq in the equation above. +* On exit, SUMSQ is overwritten with smsq , the basic sum of +* squares from which scl has been factored out. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION ABSXI +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + IF( N.GT.0 ) THEN + DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX + IF( X( IX ).NE.ZERO ) THEN + ABSXI = ABS( X( IX ) ) + IF( SCALE.LT.ABSXI ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 + SCALE = ABSXI + ELSE + SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF + RETURN +* +* End of DLASSQ +* + END + SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDW, N, NB +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) +* .. +* +* Purpose +* ======= +* +* DLATRD reduces NB rows and columns of a real symmetric matrix A to +* symmetric tridiagonal form by an orthogonal similarity +* transformation Q' * A * Q, and returns the matrices V and W which are +* needed to apply the transformation to the unreduced part of A. +* +* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a +* matrix, of which the upper triangle is supplied; +* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a +* matrix, of which the lower triangle is supplied. +* +* This is an auxiliary routine called by DSYTRD. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored: +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. +* +* NB (input) INTEGER +* The number of rows and columns to be reduced. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n-by-n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n-by-n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* On exit: +* if UPLO = 'U', the last NB columns have been reduced to +* tridiagonal form, with the diagonal elements overwriting +* the diagonal elements of A; the elements above the diagonal +* with the array TAU, represent the orthogonal matrix Q as a +* product of elementary reflectors; +* if UPLO = 'L', the first NB columns have been reduced to +* tridiagonal form, with the diagonal elements overwriting +* the diagonal elements of A; the elements below the diagonal +* with the array TAU, represent the orthogonal matrix Q as a +* product of elementary reflectors. +* See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= (1,N). +* +* E (output) DOUBLE PRECISION array, dimension (N-1) +* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal +* elements of the last NB columns of the reduced matrix; +* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of +* the first NB columns of the reduced matrix. +* +* TAU (output) DOUBLE PRECISION array, dimension (N-1) +* The scalar factors of the elementary reflectors, stored in +* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. +* See Further Details. +* +* W (output) DOUBLE PRECISION array, dimension (LDW,NB) +* The n-by-nb matrix W required to update the unreduced part +* of A. +* +* LDW (input) INTEGER +* The leading dimension of the array W. LDW >= max(1,N). +* +* Further Details +* =============== +* +* If UPLO = 'U', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(n) H(n-1) . . . H(n-nb+1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v' +* +* where tau is a real scalar, and v is a real vector with +* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), +* and tau in TAU(i-1). +* +* If UPLO = 'L', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(1) H(2) . . . H(nb). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v' +* +* where tau is a real scalar, and v is a real vector with +* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), +* and tau in TAU(i). +* +* The elements of the vectors v together form the n-by-nb matrix V +* which is needed, with W, to apply the transformation to the unreduced +* part of the matrix, using a symmetric rank-2k update of the form: +* A := A - V*W' - W*V'. +* +* The contents of A on exit are illustrated by the following examples +* with n = 5 and nb = 2: +* +* if UPLO = 'U': if UPLO = 'L': +* +* ( a a a v4 v5 ) ( d ) +* ( a a v4 v5 ) ( 1 d ) +* ( a 1 v5 ) ( v1 1 a ) +* ( d 1 ) ( v1 v2 a a ) +* ( d ) ( v1 v2 a a a ) +* +* where d denotes a diagonal element of the reduced matrix, a denotes +* an element of the original matrix that is unchanged, and vi denotes +* an element of the vector defining H(i). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IW + DOUBLE PRECISION ALPHA +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC MIN +* .. +* .. Executable Statements .. +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* Reduce last NB columns of upper triangle +* + DO 10 I = N, N - NB + 1, -1 + IW = I - N + NB + IF( I.LT.N ) THEN +* +* Update A(1:i,i) +* + CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ), + $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) + CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ), + $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) + END IF + IF( I.GT.1 ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(1:i-2,i) +* + CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) + E( I-1 ) = A( I-1, I ) + A( I-1, I ) = ONE +* +* Compute W(1:i-1,i) +* + CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1, + $ ZERO, W( 1, IW ), 1 ) + IF( I.LT.N ) THEN + CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ), + $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, -ONE, + $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), + $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL DGEMV( 'No transpose', I-1, N-I, -ONE, + $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + END IF + CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) + ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, + $ A( 1, I ), 1 ) + CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) + END IF +* + 10 CONTINUE + ELSE +* +* Reduce first NB columns of lower triangle +* + DO 20 I = 1, NB +* +* Update A(i:n,i) +* + CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ), + $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) + CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ), + $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) + IF( I.LT.N ) THEN +* +* Generate elementary reflector H(i) to annihilate +* A(i+2:n,i) +* + CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) + E( I ) = A( I+1, I ) + A( I+1, I ) = ONE +* +* Compute W(i+1:n,i) +* + CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ), + $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ), + $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) + ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, + $ A( I+1, I ), 1 ) + CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) + END IF +* + 20 CONTINUE + END IF +* + RETURN +* +* End of DLATRD +* + END + SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORG2L generates an m by n real matrix Q with orthonormal columns, +* which is defined as the last n columns of a product of k elementary +* reflectors of order m +* +* Q = H(k) . . . H(2) H(1) +* +* as returned by DGEQLF. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix Q. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix Q. M >= N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines the +* matrix Q. N >= K >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the (n-k+i)-th column must contain the vector which +* defines the elementary reflector H(i), for i = 1,2,...,k, as +* returned by DGEQLF in the last k columns of its array +* argument A. +* On exit, the m by n matrix Q. +* +* LDA (input) INTEGER +* The first dimension of the array A. LDA >= max(1,M). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQLF. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument has an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, II, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2L', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns 1:n-k to columns of the unit matrix +* + DO 20 J = 1, N - K + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( M-N+J, J ) = ONE + 20 CONTINUE +* + DO 40 I = 1, K + II = N - K + I +* +* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left +* + A( M-N+II, II ) = ONE + CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, + $ LDA, WORK ) + CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) + A( M-N+II, II ) = ONE - TAU( I ) +* +* Set A(m-k+i+1:m,n-k+i) to zero +* + DO 30 L = M - N + II + 1, M + A( L, II ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORG2L +* + END + SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORG2R generates an m by n real matrix Q with orthonormal columns, +* which is defined as the first n columns of a product of k elementary +* reflectors of order m +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix Q. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix Q. M >= N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines the +* matrix Q. N >= K >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the i-th column must contain the vector which +* defines the elementary reflector H(i), for i = 1,2,...,k, as +* returned by DGEQRF in the first k columns of its array +* argument A. +* On exit, the m-by-n matrix Q. +* +* LDA (input) INTEGER +* The first dimension of the array A. LDA >= max(1,M). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument has an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, J, L +* .. +* .. External Subroutines .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2R', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* +* Initialise columns k+1:n to columns of the unit matrix +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* Apply H(i) to A(i:m,i:n) from the left +* + IF( I.LT.N ) THEN + A( I, I ) = ONE + CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* Set A(1:i-1,i) to zero +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* End of DORG2R +* + END + SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORGQL generates an M-by-N real matrix Q with orthonormal columns, +* which is defined as the last N columns of a product of K elementary +* reflectors of order M +* +* Q = H(k) . . . H(2) H(1) +* +* as returned by DGEQLF. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix Q. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix Q. M >= N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines the +* matrix Q. N >= K >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the (n-k+i)-th column must contain the vector which +* defines the elementary reflector H(i), for i = 1,2,...,k, as +* returned by DGEQLF in the last k columns of its array +* argument A. +* On exit, the M-by-N matrix Q. +* +* LDA (input) INTEGER +* The first dimension of the array A. LDA >= max(1,M). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQLF. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* For optimum performance LWORK >= N*NB, where NB is the +* optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument has an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT, + $ NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( N.EQ.0 ) THEN + LWKOPT = 1 + ELSE + NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) + LWKOPT = N*NB + END IF + WORK( 1 ) = LWKOPT +* + IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGQL', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the first block. +* The last kk columns are handled by the block method. +* + KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) +* +* Set A(m-kk+1:m,1:n-kk) to zero. +* + DO 20 J = 1, N - KK + DO 10 I = M - KK + 1, M + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the first or only block. +* + CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = K - KK + 1, K, NB + IB = MIN( NB, K-I+1 ) + IF( N-K+I.GT.1 ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i+ib-1) . . . H(i+1) H(i) +* + CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB, + $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left +* + CALL DLARFB( 'Left', 'No transpose', 'Backward', + $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB, + $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, + $ WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows 1:m-k+i+ib-1 of current block +* + CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, + $ TAU( I ), WORK, IINFO ) +* +* Set rows m-k+i+ib:m of current block to zero +* + DO 40 J = N - K + I, N - K + I + IB - 1 + DO 30 L = M - K + I + IB, M + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGQL +* + END + SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORGQR generates an M-by-N real matrix Q with orthonormal columns, +* which is defined as the first N columns of a product of K elementary +* reflectors of order M +* +* Q = H(1) H(2) . . . H(k) +* +* as returned by DGEQRF. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix Q. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix Q. M >= N >= 0. +* +* K (input) INTEGER +* The number of elementary reflectors whose product defines the +* matrix Q. N >= K >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the i-th column must contain the vector which +* defines the elementary reflector H(i), for i = 1,2,...,k, as +* returned by DGEQRF in the first k columns of its array +* argument A. +* On exit, the M-by-N matrix Q. +* +* LDA (input) INTEGER +* The first dimension of the array A. LDA >= max(1,M). +* +* TAU (input) DOUBLE PRECISION array, dimension (K) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DGEQRF. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N). +* For optimum performance LWORK >= N*NB, where NB is the +* optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument has an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, + $ LWKOPT, NB, NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) + LWKOPT = MAX( 1, N )*NB + WORK( 1 ) = LWKOPT + LQUERY = ( LWORK.EQ.-1 ) + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGQR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* Determine when to cross over from blocked to unblocked code. +* + NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: reduce NB and +* determine the minimum value of NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* Use blocked code after the last block. +* The first kk columns are handled by the block method. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* Set A(1:kk,kk+1:n) to zero. +* + DO 20 J = KK + 1, N + DO 10 I = 1, KK + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* Use unblocked code for the last or only block. +* + IF( KK.LT.N ) + $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* Use blocked code +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.N ) THEN +* +* Form the triangular factor of the block reflector +* H = H(i) H(i+1) . . . H(i+ib-1) +* + CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* Apply H to A(i:m,i+ib:n) from the left +* + CALL DLARFB( 'Left', 'No transpose', 'Forward', + $ 'Columnwise', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF +* +* Apply H to rows i:m of current block +* + CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* Set rows 1:i-1 of current block to zero +* + DO 40 J = I, I + IB - 1 + DO 30 L = 1, I - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* End of DORGQR +* + END + SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DORGTR generates a real orthogonal matrix Q which is defined as the +* product of n-1 elementary reflectors of order N, as returned by +* DSYTRD: +* +* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), +* +* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A contains elementary reflectors +* from DSYTRD; +* = 'L': Lower triangle of A contains elementary reflectors +* from DSYTRD. +* +* N (input) INTEGER +* The order of the matrix Q. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the vectors which define the elementary reflectors, +* as returned by DSYTRD. +* On exit, the N-by-N orthogonal matrix Q. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* TAU (input) DOUBLE PRECISION array, dimension (N-1) +* TAU(i) must contain the scalar factor of the elementary +* reflector H(i), as returned by DSYTRD. +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= max(1,N-1). +* For optimum performance LWORK >= (N-1)*NB, where NB is +* the optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, J, LWKOPT, NB +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. External Subroutines .. + EXTERNAL DORGQL, DORGQR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 ) + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( UPPER ) THEN + NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 ) + ELSE + NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 ) + END IF + LWKOPT = MAX( 1, N-1 )*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGTR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( UPPER ) THEN +* +* Q was determined by a call to DSYTRD with UPLO = 'U' +* +* Shift the vectors which define the elementary reflectors one +* column to the left, and set the last row and column of Q to +* those of the unit matrix +* + DO 20 J = 1, N - 1 + DO 10 I = 1, J - 1 + A( I, J ) = A( I, J+1 ) + 10 CONTINUE + A( N, J ) = ZERO + 20 CONTINUE + DO 30 I = 1, N - 1 + A( I, N ) = ZERO + 30 CONTINUE + A( N, N ) = ONE +* +* Generate Q(1:n-1,1:n-1) +* + CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) +* + ELSE +* +* Q was determined by a call to DSYTRD with UPLO = 'L'. +* +* Shift the vectors which define the elementary reflectors one +* column to the right, and set the first row and column of Q to +* those of the unit matrix +* + DO 50 J = N, 2, -1 + A( 1, J ) = ZERO + DO 40 I = J + 1, N + A( I, J ) = A( I, J-1 ) + 40 CONTINUE + 50 CONTINUE + A( 1, 1 ) = ONE + DO 60 I = 2, N + A( I, 1 ) = ZERO + 60 CONTINUE + IF( N.GT.1 ) THEN +* +* Generate Q(2:n,2:n) +* + CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + WORK( 1 ) = LWKOPT + RETURN +* +* End of DORGTR +* + END + SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER COMPZ + INTEGER INFO, LDZ, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* Purpose +* ======= +* +* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a +* symmetric tridiagonal matrix using the implicit QL or QR method. +* The eigenvectors of a full or band symmetric matrix can also be found +* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to +* tridiagonal form. +* +* Arguments +* ========= +* +* COMPZ (input) CHARACTER*1 +* = 'N': Compute eigenvalues only. +* = 'V': Compute eigenvalues and eigenvectors of the original +* symmetric matrix. On entry, Z must contain the +* orthogonal matrix used to reduce the original matrix +* to tridiagonal form. +* = 'I': Compute eigenvalues and eigenvectors of the +* tridiagonal matrix. Z is initialized to the identity +* matrix. +* +* N (input) INTEGER +* The order of the matrix. N >= 0. +* +* D (input/output) DOUBLE PRECISION array, dimension (N) +* On entry, the diagonal elements of the tridiagonal matrix. +* On exit, if INFO = 0, the eigenvalues in ascending order. +* +* E (input/output) DOUBLE PRECISION array, dimension (N-1) +* On entry, the (n-1) subdiagonal elements of the tridiagonal +* matrix. +* On exit, E has been destroyed. +* +* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N) +* On entry, if COMPZ = 'V', then Z contains the orthogonal +* matrix used in the reduction to tridiagonal form. +* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the +* orthonormal eigenvectors of the original symmetric matrix, +* and if COMPZ = 'I', Z contains the orthonormal eigenvectors +* of the symmetric tridiagonal matrix. +* If COMPZ = 'N', then Z is not referenced. +* +* LDZ (input) INTEGER +* The leading dimension of the array Z. LDZ >= 1, and if +* eigenvectors are desired, then LDZ >= max(1,N). +* +* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2)) +* If COMPZ = 'N', then WORK is not referenced. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: the algorithm has failed to find all the eigenvalues in +* a total of 30*N iterations; if INFO = i, then i +* elements of E have not converged to zero; on exit, D +* and E contain the elements of a symmetric tridiagonal +* matrix which is orthogonally similar to the original +* matrix. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. Local Scalars .. + INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND, + $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1, + $ NM1, NMAXIT + DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2, + $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 + EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR, + $ DLASRT, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ICOMPZ = 0 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ICOMPZ = 2 + ELSE + ICOMPZ = -1 + END IF + IF( ICOMPZ.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, + $ N ) ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEQR', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( ICOMPZ.EQ.2 ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* Determine the unit roundoff and over/underflow thresholds. +* + EPS = DLAMCH( 'E' ) + EPS2 = EPS**2 + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + SSFMAX = SQRT( SAFMAX ) / THREE + SSFMIN = SQRT( SAFMIN ) / EPS2 +* +* Compute the eigenvalues and eigenvectors of the tridiagonal +* matrix. +* + IF( ICOMPZ.EQ.2 ) + $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ ) +* + NMAXIT = N*MAXIT + JTOT = 0 +* +* Determine where the matrix splits and choose QL or QR iteration +* for each block, according to whether top or bottom diagonal +* element is smaller. +* + L1 = 1 + NM1 = N - 1 +* + 10 CONTINUE + IF( L1.GT.N ) + $ GO TO 160 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + IF( L1.LE.NM1 ) THEN + DO 20 M = L1, NM1 + TST = ABS( E( M ) ) + IF( TST.EQ.ZERO ) + $ GO TO 30 + IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ + $ 1 ) ) ) )*EPS ) THEN + E( M ) = ZERO + GO TO 30 + END IF + 20 CONTINUE + END IF + M = N +* + 30 CONTINUE + L = L1 + LSV = L + LEND = M + LENDSV = LEND + L1 = M + 1 + IF( LEND.EQ.L ) + $ GO TO 10 +* +* Scale submatrix in rows and columns L to LEND +* + ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) + ISCALE = 0 + IF( ANORM.EQ.ZERO ) + $ GO TO 10 + IF( ANORM.GT.SSFMAX ) THEN + ISCALE = 1 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, + $ INFO ) + ELSE IF( ANORM.LT.SSFMIN ) THEN + ISCALE = 2 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, + $ INFO ) + END IF +* +* Choose between QL and QR iteration +* + IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN + LEND = LSV + L = LENDSV + END IF +* + IF( LEND.GT.L ) THEN +* +* QL Iteration +* +* Look for small subdiagonal element. +* + 40 CONTINUE + IF( L.NE.LEND ) THEN + LENDM1 = LEND - 1 + DO 50 M = L, LENDM1 + TST = ABS( E( M ) )**2 + IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+ + $ SAFMIN )GO TO 60 + 50 CONTINUE + END IF +* + M = LEND +* + 60 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 80 +* +* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 +* to compute its eigensystem. +* + IF( M.EQ.L+1 ) THEN + IF( ICOMPZ.GT.0 ) THEN + CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) + WORK( L ) = C + WORK( N-1+L ) = S + CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), + $ WORK( N-1+L ), Z( 1, L ), LDZ ) + ELSE + CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) + END IF + D( L ) = RT1 + D( L+1 ) = RT2 + E( L ) = ZERO + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* Form shift. +* + G = ( D( L+1 )-P ) / ( TWO*E( L ) ) + R = DLAPY2( G, ONE ) + G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) +* + S = ONE + C = ONE + P = ZERO +* +* Inner loop +* + MM1 = M - 1 + DO 70 I = MM1, L, -1 + F = S*E( I ) + B = C*E( I ) + CALL DLARTG( G, F, C, S, R ) + IF( I.NE.M-1 ) + $ E( I+1 ) = R + G = D( I+1 ) - P + R = ( D( I )-G )*S + TWO*C*B + P = S*R + D( I+1 ) = G + P + G = C*R - B +* +* If eigenvectors are desired, then save rotations. +* + IF( ICOMPZ.GT.0 ) THEN + WORK( I ) = C + WORK( N-1+I ) = -S + END IF +* + 70 CONTINUE +* +* If eigenvectors are desired, then apply saved rotations. +* + IF( ICOMPZ.GT.0 ) THEN + MM = M - L + 1 + CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), + $ Z( 1, L ), LDZ ) + END IF +* + D( L ) = D( L ) - P + E( L ) = G + GO TO 40 +* +* Eigenvalue found. +* + 80 CONTINUE + D( L ) = P +* + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 140 +* + ELSE +* +* QR Iteration +* +* Look for small superdiagonal element. +* + 90 CONTINUE + IF( L.NE.LEND ) THEN + LENDP1 = LEND + 1 + DO 100 M = L, LENDP1, -1 + TST = ABS( E( M-1 ) )**2 + IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+ + $ SAFMIN )GO TO 110 + 100 CONTINUE + END IF +* + M = LEND +* + 110 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 130 +* +* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2 +* to compute its eigensystem. +* + IF( M.EQ.L-1 ) THEN + IF( ICOMPZ.GT.0 ) THEN + CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) + WORK( M ) = C + WORK( N-1+M ) = S + CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), + $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) + ELSE + CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) + END IF + D( L-1 ) = RT1 + D( L ) = RT2 + E( L-1 ) = ZERO + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* Form shift. +* + G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) + R = DLAPY2( G, ONE ) + G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) +* + S = ONE + C = ONE + P = ZERO +* +* Inner loop +* + LM1 = L - 1 + DO 120 I = M, LM1 + F = S*E( I ) + B = C*E( I ) + CALL DLARTG( G, F, C, S, R ) + IF( I.NE.M ) + $ E( I-1 ) = R + G = D( I ) - P + R = ( D( I+1 )-G )*S + TWO*C*B + P = S*R + D( I ) = G + P + G = C*R - B +* +* If eigenvectors are desired, then save rotations. +* + IF( ICOMPZ.GT.0 ) THEN + WORK( I ) = C + WORK( N-1+I ) = S + END IF +* + 120 CONTINUE +* +* If eigenvectors are desired, then apply saved rotations. +* + IF( ICOMPZ.GT.0 ) THEN + MM = L - M + 1 + CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), + $ Z( 1, M ), LDZ ) + END IF +* + D( L ) = D( L ) - P + E( LM1 ) = G + GO TO 90 +* +* Eigenvalue found. +* + 130 CONTINUE + D( L ) = P +* + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 140 +* + END IF +* +* Undo scaling if necessary +* + 140 CONTINUE + IF( ISCALE.EQ.1 ) THEN + CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ), + $ N, INFO ) + ELSE IF( ISCALE.EQ.2 ) THEN + CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ), + $ N, INFO ) + END IF +* +* Check for no convergence to an eigenvalue after a total +* of N*MAXIT iterations. +* + IF( JTOT.LT.NMAXIT ) + $ GO TO 10 + DO 150 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 150 CONTINUE + GO TO 190 +* +* Order eigenvalues and eigenvectors. +* + 160 CONTINUE + IF( ICOMPZ.EQ.0 ) THEN +* +* Use Quick Sort +* + CALL DLASRT( 'I', N, D, INFO ) +* + ELSE +* +* Use Selection Sort to minimize swaps of eigenvectors +* + DO 180 II = 2, N + I = II - 1 + K = I + P = D( I ) + DO 170 J = II, N + IF( D( J ).LT.P ) THEN + K = J + P = D( J ) + END IF + 170 CONTINUE + IF( K.NE.I ) THEN + D( K ) = D( I ) + D( I ) = P + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) + END IF + 180 CONTINUE + END IF +* + 190 CONTINUE + RETURN +* +* End of DSTEQR +* + END + SUBROUTINE DSTERF( N, D, E, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* Purpose +* ======= +* +* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix +* using the Pal-Walker-Kahan variant of the QL or QR algorithm. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The order of the matrix. N >= 0. +* +* D (input/output) DOUBLE PRECISION array, dimension (N) +* On entry, the n diagonal elements of the tridiagonal matrix. +* On exit, if INFO = 0, the eigenvalues in ascending order. +* +* E (input/output) DOUBLE PRECISION array, dimension (N-1) +* On entry, the (n-1) subdiagonal elements of the tridiagonal +* matrix. +* On exit, E has been destroyed. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: the algorithm failed to find all of the eigenvalues in +* a total of 30*N iterations; if INFO = i, then i +* elements of E have not converged to zero. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, TWO, THREE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ THREE = 3.0D0 ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. Local Scalars .. + INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M, + $ NMAXIT + DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC, + $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN, + $ SIGMA, SSFMAX, SSFMIN +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANST, DLAPY2 + EXTERNAL DLAMCH, DLANST, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 +* +* Quick return if possible +* + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DSTERF', -INFO ) + RETURN + END IF + IF( N.LE.1 ) + $ RETURN +* +* Determine the unit roundoff for this environment. +* + EPS = DLAMCH( 'E' ) + EPS2 = EPS**2 + SAFMIN = DLAMCH( 'S' ) + SAFMAX = ONE / SAFMIN + SSFMAX = SQRT( SAFMAX ) / THREE + SSFMIN = SQRT( SAFMIN ) / EPS2 +* +* Compute the eigenvalues of the tridiagonal matrix. +* + NMAXIT = N*MAXIT + SIGMA = ZERO + JTOT = 0 +* +* Determine where the matrix splits and choose QL or QR iteration +* for each block, according to whether top or bottom diagonal +* element is smaller. +* + L1 = 1 +* + 10 CONTINUE + IF( L1.GT.N ) + $ GO TO 170 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + DO 20 M = L1, N - 1 + IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+ + $ 1 ) ) ) )*EPS ) THEN + E( M ) = ZERO + GO TO 30 + END IF + 20 CONTINUE + M = N +* + 30 CONTINUE + L = L1 + LSV = L + LEND = M + LENDSV = LEND + L1 = M + 1 + IF( LEND.EQ.L ) + $ GO TO 10 +* +* Scale submatrix in rows and columns L to LEND +* + ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) ) + ISCALE = 0 + IF( ANORM.GT.SSFMAX ) THEN + ISCALE = 1 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N, + $ INFO ) + ELSE IF( ANORM.LT.SSFMIN ) THEN + ISCALE = 2 + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N, + $ INFO ) + CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N, + $ INFO ) + END IF +* + DO 40 I = L, LEND - 1 + E( I ) = E( I )**2 + 40 CONTINUE +* +* Choose between QL and QR iteration +* + IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN + LEND = LSV + L = LENDSV + END IF +* + IF( LEND.GE.L ) THEN +* +* QL Iteration +* +* Look for small subdiagonal element. +* + 50 CONTINUE + IF( L.NE.LEND ) THEN + DO 60 M = L, LEND - 1 + IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) ) + $ GO TO 70 + 60 CONTINUE + END IF + M = LEND +* + 70 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 90 +* +* If remaining matrix is 2 by 2, use DLAE2 to compute its +* eigenvalues. +* + IF( M.EQ.L+1 ) THEN + RTE = SQRT( E( L ) ) + CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) + D( L ) = RT1 + D( L+1 ) = RT2 + E( L ) = ZERO + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 50 + GO TO 150 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 150 + JTOT = JTOT + 1 +* +* Form shift. +* + RTE = SQRT( E( L ) ) + SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) + R = DLAPY2( SIGMA, ONE ) + SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) +* + C = ONE + S = ZERO + GAMMA = D( M ) - SIGMA + P = GAMMA*GAMMA +* +* Inner loop +* + DO 80 I = M - 1, L, -1 + BB = E( I ) + R = P + BB + IF( I.NE.M-1 ) + $ E( I+1 ) = S*R + OLDC = C + C = P / R + S = BB / R + OLDGAM = GAMMA + ALPHA = D( I ) + GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM + D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) + IF( C.NE.ZERO ) THEN + P = ( GAMMA*GAMMA ) / C + ELSE + P = OLDC*BB + END IF + 80 CONTINUE +* + E( L ) = S*P + D( L ) = SIGMA + GAMMA + GO TO 50 +* +* Eigenvalue found. +* + 90 CONTINUE + D( L ) = P +* + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 50 + GO TO 150 +* + ELSE +* +* QR Iteration +* +* Look for small superdiagonal element. +* + 100 CONTINUE + DO 110 M = L, LEND + 1, -1 + IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) ) + $ GO TO 120 + 110 CONTINUE + M = LEND +* + 120 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 140 +* +* If remaining matrix is 2 by 2, use DLAE2 to compute its +* eigenvalues. +* + IF( M.EQ.L-1 ) THEN + RTE = SQRT( E( L-1 ) ) + CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) + D( L ) = RT1 + D( L-1 ) = RT2 + E( L-1 ) = ZERO + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 100 + GO TO 150 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 150 + JTOT = JTOT + 1 +* +* Form shift. +* + RTE = SQRT( E( L-1 ) ) + SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) + R = DLAPY2( SIGMA, ONE ) + SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) +* + C = ONE + S = ZERO + GAMMA = D( M ) - SIGMA + P = GAMMA*GAMMA +* +* Inner loop +* + DO 130 I = M, L - 1 + BB = E( I ) + R = P + BB + IF( I.NE.M ) + $ E( I-1 ) = S*R + OLDC = C + C = P / R + S = BB / R + OLDGAM = GAMMA + ALPHA = D( I+1 ) + GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM + D( I ) = OLDGAM + ( ALPHA-GAMMA ) + IF( C.NE.ZERO ) THEN + P = ( GAMMA*GAMMA ) / C + ELSE + P = OLDC*BB + END IF + 130 CONTINUE +* + E( L-1 ) = S*P + D( L ) = SIGMA + GAMMA + GO TO 100 +* +* Eigenvalue found. +* + 140 CONTINUE + D( L ) = P +* + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 100 + GO TO 150 +* + END IF +* +* Undo scaling if necessary +* + 150 CONTINUE + IF( ISCALE.EQ.1 ) + $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) + IF( ISCALE.EQ.2 ) + $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1, + $ D( LSV ), N, INFO ) +* +* Check for no convergence to an eigenvalue after a total +* of N*MAXIT iterations. +* + IF( JTOT.LT.NMAXIT ) + $ GO TO 10 + DO 160 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 160 CONTINUE + GO TO 180 +* +* Sort eigenvalues in increasing order. +* + 170 CONTINUE + CALL DLASRT( 'I', N, D, INFO ) +* + 180 CONTINUE + RETURN +* +* End of DSTERF +* + END + + SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) +* .. +* +* Purpose +* ======= +* +* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal +* form T by an orthogonal similarity transformation: Q' * A * Q = T. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored: +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n-by-n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n-by-n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* On exit, if UPLO = 'U', the diagonal and first superdiagonal +* of A are overwritten by the corresponding elements of the +* tridiagonal matrix T, and the elements above the first +* superdiagonal, with the array TAU, represent the orthogonal +* matrix Q as a product of elementary reflectors; if UPLO +* = 'L', the diagonal and first subdiagonal of A are over- +* written by the corresponding elements of the tridiagonal +* matrix T, and the elements below the first subdiagonal, with +* the array TAU, represent the orthogonal matrix Q as a product +* of elementary reflectors. See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* D (output) DOUBLE PRECISION array, dimension (N) +* The diagonal elements of the tridiagonal matrix T: +* D(i) = A(i,i). +* +* E (output) DOUBLE PRECISION array, dimension (N-1) +* The off-diagonal elements of the tridiagonal matrix T: +* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. +* +* TAU (output) DOUBLE PRECISION array, dimension (N-1) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value. +* +* Further Details +* =============== +* +* If UPLO = 'U', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(n-1) . . . H(2) H(1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v' +* +* where tau is a real scalar, and v is a real vector with +* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in +* A(1:i-1,i+1), and tau in TAU(i). +* +* If UPLO = 'L', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(1) H(2) . . . H(n-1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v' +* +* where tau is a real scalar, and v is a real vector with +* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), +* and tau in TAU(i). +* +* The contents of A on exit are illustrated by the following examples +* with n = 5: +* +* if UPLO = 'U': if UPLO = 'L': +* +* ( d e v2 v3 v4 ) ( d ) +* ( d e v3 v4 ) ( e d ) +* ( d e v4 ) ( v1 e d ) +* ( d e ) ( v1 v2 e d ) +* ( d ) ( v1 v2 v3 e d ) +* +* where d and e denote diagonal and off-diagonal elements of T, and vi +* denotes an element of the vector defining H(i). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO, HALF + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, + $ HALF = 1.0D0 / 2.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I + DOUBLE PRECISION ALPHA, TAUI +* .. +* .. External Subroutines .. + EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTD2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.LE.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A +* + DO 10 I = N - 1, 1, -1 +* +* Generate elementary reflector H(i) = I - tau * v * v' +* to annihilate A(1:i-1,i+1) +* + CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) + E( I ) = A( I, I+1 ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(1:i,1:i) +* + A( I, I+1 ) = ONE +* +* Compute x := tau * A * v storing x in TAU(1:i) +* + CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, + $ TAU, 1 ) +* +* Compute w := x - 1/2 * tau * (x'*v) * v +* + ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) + CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A - v * w' - w * v' +* + CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, + $ LDA ) +* + A( I, I+1 ) = E( I ) + END IF + D( I+1 ) = A( I+1, I+1 ) + TAU( I ) = TAUI + 10 CONTINUE + D( 1 ) = A( 1, 1 ) + ELSE +* +* Reduce the lower triangle of A +* + DO 20 I = 1, N - 1 +* +* Generate elementary reflector H(i) = I - tau * v * v' +* to annihilate A(i+2:n,i) +* + CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAUI ) + E( I ) = A( I+1, I ) +* + IF( TAUI.NE.ZERO ) THEN +* +* Apply H(i) from both sides to A(i+1:n,i+1:n) +* + A( I+1, I ) = ONE +* +* Compute x := tau * A * v storing y in TAU(i:n-1) +* + CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) +* +* Compute w := x - 1/2 * tau * (x'*v) * v +* + ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), + $ 1 ) + CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) +* +* Apply the transformation as a rank-2 update: +* A := A - v * w' - w * v' +* + CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, + $ A( I+1, I+1 ), LDA ) +* + A( I+1, I ) = E( I ) + END IF + D( I ) = A( I, I ) + TAU( I ) = TAUI + 20 CONTINUE + D( N ) = A( N, N ) + END IF +* + RETURN +* +* End of DSYTD2 +* + END + SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), + $ WORK( * ) +* .. +* +* Purpose +* ======= +* +* DSYTRD reduces a real symmetric matrix A to real symmetric +* tridiagonal form T by an orthogonal similarity transformation: +* Q**T * A * Q = T. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* On exit, if UPLO = 'U', the diagonal and first superdiagonal +* of A are overwritten by the corresponding elements of the +* tridiagonal matrix T, and the elements above the first +* superdiagonal, with the array TAU, represent the orthogonal +* matrix Q as a product of elementary reflectors; if UPLO +* = 'L', the diagonal and first subdiagonal of A are over- +* written by the corresponding elements of the tridiagonal +* matrix T, and the elements below the first subdiagonal, with +* the array TAU, represent the orthogonal matrix Q as a product +* of elementary reflectors. See Further Details. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* D (output) DOUBLE PRECISION array, dimension (N) +* The diagonal elements of the tridiagonal matrix T: +* D(i) = A(i,i). +* +* E (output) DOUBLE PRECISION array, dimension (N-1) +* The off-diagonal elements of the tridiagonal matrix T: +* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. +* +* TAU (output) DOUBLE PRECISION array, dimension (N-1) +* The scalar factors of the elementary reflectors (see Further +* Details). +* +* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +* +* LWORK (input) INTEGER +* The dimension of the array WORK. LWORK >= 1. +* For optimum performance LWORK >= N*NB, where NB is the +* optimal blocksize. +* +* If LWORK = -1, then a workspace query is assumed; the routine +* only calculates the optimal size of the WORK array, returns +* this value as the first entry of the WORK array, and no error +* message related to LWORK is issued by XERBLA. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* Further Details +* =============== +* +* If UPLO = 'U', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(n-1) . . . H(2) H(1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v' +* +* where tau is a real scalar, and v is a real vector with +* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in +* A(1:i-1,i+1), and tau in TAU(i). +* +* If UPLO = 'L', the matrix Q is represented as a product of elementary +* reflectors +* +* Q = H(1) H(2) . . . H(n-1). +* +* Each H(i) has the form +* +* H(i) = I - tau * v * v' +* +* where tau is a real scalar, and v is a real vector with +* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), +* and tau in TAU(i). +* +* The contents of A on exit are illustrated by the following examples +* with n = 5: +* +* if UPLO = 'U': if UPLO = 'L': +* +* ( d e v2 v3 v4 ) ( d ) +* ( d e v3 v4 ) ( e d ) +* ( d e v4 ) ( v1 e d ) +* ( d e ) ( v1 v2 e d ) +* ( d ) ( v1 v2 v3 e d ) +* +* where d and e denote diagonal and off-diagonal elements of T, and vi +* denotes an element of the vector defining H(i). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, UPPER + INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB, + $ NBMIN, NX +* .. +* .. External Subroutines .. + EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. Executable Statements .. +* +* Test the input parameters +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + LQUERY = ( LWORK.EQ.-1 ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN + INFO = -9 + END IF +* + IF( INFO.EQ.0 ) THEN +* +* Determine the block size. +* + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + LWKOPT = N*NB + WORK( 1 ) = LWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + NX = N + IWS = 1 + IF( NB.GT.1 .AND. NB.LT.N ) THEN +* +* Determine when to cross over from blocked to unblocked code +* (last block is always handled by unblocked code). +* + NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) + IF( NX.LT.N ) THEN +* +* Determine if workspace is large enough for blocked code. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* Not enough workspace to use optimal NB: determine the +* minimum value of NB, and reduce NB or force use of +* unblocked code by setting NX = N. +* + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) + IF( NB.LT.NBMIN ) + $ NX = N + END IF + ELSE + NX = N + END IF + ELSE + NB = 1 + END IF +* + IF( UPPER ) THEN +* +* Reduce the upper triangle of A. +* Columns 1:kk are handled by the unblocked method. +* + KK = N - ( ( N-NX+NB-1 ) / NB )*NB + DO 20 I = N - NB + 1, KK + 1, -NB +* +* Reduce columns i:i+nb-1 to tridiagonal form and form the +* matrix W which is needed to update the unreduced part of +* the matrix +* + CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, + $ LDWORK ) +* +* Update the unreduced submatrix A(1:i-1,1:i-1), using an +* update of the form: A := A - V*W' - W*V' +* + CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ), + $ LDA, WORK, LDWORK, ONE, A, LDA ) +* +* Copy superdiagonal elements back into A, and diagonal +* elements into D +* + DO 10 J = I, I + NB - 1 + A( J-1, J ) = E( J-1 ) + D( J ) = A( J, J ) + 10 CONTINUE + 20 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) + ELSE +* +* Reduce the lower triangle of A +* + DO 40 I = 1, N - NX, NB +* +* Reduce columns i:i+nb-1 to tridiagonal form and form the +* matrix W which is needed to update the unreduced part of +* the matrix +* + CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), + $ TAU( I ), WORK, LDWORK ) +* +* Update the unreduced submatrix A(i+ib:n,i+ib:n), using +* an update of the form: A := A - V*W' - W*V' +* + CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE, + $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, + $ A( I+NB, I+NB ), LDA ) +* +* Copy subdiagonal elements back into A, and diagonal +* elements into D +* + DO 30 J = I, I + NB - 1 + A( J+1, J ) = E( J ) + D( J ) = A( J, J ) + 30 CONTINUE + 40 CONTINUE +* +* Use unblocked code to reduce the last or only block +* + CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), + $ TAU( I ), IINFO ) + END IF +* + WORK( 1 ) = LWKOPT + RETURN +* +* End of DSYTRD +* + END + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* Purpose +* ======= +* +* IEEECK is called from the ILAENV to verify that Infinity and +* possibly NaN arithmetic is safe (i.e. will not trap). +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies whether to test just for inifinity arithmetic +* or whether to test for infinity and NaN arithmetic. +* = 0: Verify infinity arithmetic only. +* = 1: Verify infinity and NaN arithmetic. +* +* ZERO (input) REAL +* Must contain the value 0.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* ONE (input) REAL +* Must contain the value 1.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* RETURN VALUE: INTEGER +* = 0: Arithmetic failed to produce the correct answers +* = 1: Arithmetic produced the correct answers +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*0.0 +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* Purpose +* ======= +* +* ILAENV is called from the LAPACK routines to choose problem-dependent +* parameters for the local environment. See ISPEC for a description of +* the parameters. +* +* This version provides a set of parameters which should give good, +* but not optimal, performance on many of the currently available +* computers. Users are encouraged to modify this subroutine to set +* the tuning parameters for their particular machine using the option +* and problem size information in the arguments. +* +* This routine will not function correctly if it is converted to all +* lower case. Converting it to all upper case is allowed. +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies the parameter to be returned as the value of +* ILAENV. +* = 1: the optimal blocksize; if this value is 1, an unblocked +* algorithm will give the best performance. +* = 2: the minimum block size for which the block routine +* should be used; if the usable block size is less than +* this value, an unblocked routine should be used. +* = 3: the crossover point (in a block routine, for N less +* than this value, an unblocked routine should be used) +* = 4: the number of shifts, used in the nonsymmetric +* eigenvalue routines (DEPRECATED) +* = 5: the minimum column dimension for blocking to be used; +* rectangular blocks must have dimension at least k by m, +* where k is given by ILAENV(2,...) and m by ILAENV(5,...) +* = 6: the crossover point for the SVD (when reducing an m by n +* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +* this value, a QR factorization is used first to reduce +* the matrix to a triangular form.) +* = 7: the number of processors +* = 8: the crossover point for the multishift QR method +* for nonsymmetric eigenvalue problems (DEPRECATED) +* = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* =10: ieee NaN arithmetic can be trusted not to trap +* =11: infinity arithmetic can be trusted not to trap +* 12 <= ISPEC <= 16: +* xHSEQR or one of its subroutines, +* see IPARMQ for detailed explanation +* +* NAME (input) CHARACTER*(*) +* The name of the calling subroutine, in either upper case or +* lower case. +* +* OPTS (input) CHARACTER*(*) +* The character options to the subroutine NAME, concatenated +* into a single character string. For example, UPLO = 'U', +* TRANS = 'T', and DIAG = 'N' for a triangular routine would +* be specified as OPTS = 'UTN'. +* +* N1 (input) INTEGER +* N2 (input) INTEGER +* N3 (input) INTEGER +* N4 (input) INTEGER +* Problem dimensions for the subroutine NAME; these may not all +* be required. +* +* (ILAENV) (output) INTEGER +* >= 0: the value of the parameter specified by ISPEC +* < 0: if ILAENV = -k, the k-th argument had an illegal value. +* +* Further Details +* =============== +* +* The following conventions have been used when calling ILAENV from the +* LAPACK routines: +* 1) OPTS is a concatenation of all of the character options to +* subroutine NAME, in the same order that they appear in the +* argument list for NAME, even if they are not used in determining +* the value of the parameter specified by ISPEC. +* 2) The problem dimensions N1, N2, N3, N4 are specified in the order +* that they appear in the argument list for NAME. N1 is used +* first, N2 second, and so on, and unused problem dimensions are +* passed a value of -1. +* 3) The parameter value returned by ILAENV is checked for validity in +* the calling subroutine. For example, ILAENV is used to retrieve +* the optimal blocksize for STRTRI as follows: +* +* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +* IF( NB.LE.1 ) NB = MAX( 1, N ) +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, IC, IZ, NB, NBMIN, NX + LOGICAL CNAME, SNAME + CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6 +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK, IPARMQ + EXTERNAL IEEECK, IPARMQ +* .. +* .. Executable Statements .. +* + GO TO ( 10, 10, 10, 80, 90, 100, 110, 120, + $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 10 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1: 1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1: 1 ) = CHAR( IC+64 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I: + $ I ) = CHAR( IC+64 ) + 30 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1: 1 ) = CHAR( IC-32 ) + DO 40 I = 2, 6 + IC = ICHAR( SUBNAM( I: I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I: I ) = CHAR( IC-32 ) + 40 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1: 1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2: 3 ) + C3 = SUBNAM( 4: 6 ) + C4 = C3( 2: 3 ) +* + GO TO ( 50, 60, 70 )ISPEC +* + 50 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + END IF + ILAENV = NB + RETURN +* + 60 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NBMIN = 2 + END IF + END IF + END IF + ILAENV = NBMIN + RETURN +* + 70 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ. + $ 'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1: 1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ. + $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' ) + $ THEN + NX = 128 + END IF + END IF + END IF + ILAENV = NX + RETURN +* + 80 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 90 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 100 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 110 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 120 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 130 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 140 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 150 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +* ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* + 160 CONTINUE +* +* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines. +* + ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) + RETURN +* +* End of ILAENV +* + END + INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) +* +* -- LAPACK auxiliary routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + INTEGER IHI, ILO, ISPEC, LWORK, N + CHARACTER NAME*( * ), OPTS*( * ) +* +* Purpose +* ======= +* +* This program sets problem and machine dependent parameters +* useful for xHSEQR and its subroutines. It is called whenever +* ILAENV is called with 12 <= ISPEC <= 16 +* +* Arguments +* ========= +* +* ISPEC (input) integer scalar +* ISPEC specifies which tunable parameter IPARMQ should +* return. +* +* ISPEC=12: (INMIN) Matrices of order nmin or less +* are sent directly to xLAHQR, the implicit +* double shift QR algorithm. NMIN must be +* at least 11. +* +* ISPEC=13: (INWIN) Size of the deflation window. +* This is best set greater than or equal to +* the number of simultaneous shifts NS. +* Larger matrices benefit from larger deflation +* windows. +* +* ISPEC=14: (INIBL) Determines when to stop nibbling and +* invest in an (expensive) multi-shift QR sweep. +* If the aggressive early deflation subroutine +* finds LD converged eigenvalues from an order +* NW deflation window and LD.GT.(NW*NIBBLE)/100, +* then the next QR sweep is skipped and early +* deflation is applied immediately to the +* remaining active diagonal block. Setting +* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a +* multi-shift QR sweep whenever early deflation +* finds a converged eigenvalue. Setting +* IPARMQ(ISPEC=14) greater than or equal to 100 +* prevents TTQRE from skipping a multi-shift +* QR sweep. +* +* ISPEC=15: (NSHFTS) The number of simultaneous shifts in +* a multi-shift QR iteration. +* +* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the +* following meanings. +* 0: During the multi-shift QR sweep, +* xLAQR5 does not accumulate reflections and +* does not use matrix-matrix multiply to +* update the far-from-diagonal matrix +* entries. +* 1: During the multi-shift QR sweep, +* xLAQR5 and/or xLAQRaccumulates reflections and uses +* matrix-matrix multiply to update the +* far-from-diagonal matrix entries. +* 2: During the multi-shift QR sweep. +* xLAQR5 accumulates reflections and takes +* advantage of 2-by-2 block structure during +* matrix-matrix multiplies. +* (If xTRMM is slower than xGEMM, then +* IPARMQ(ISPEC=16)=1 may be more efficient than +* IPARMQ(ISPEC=16)=2 despite the greater level of +* arithmetic work implied by the latter choice.) +* +* NAME (input) character string +* Name of the calling subroutine +* +* OPTS (input) character string +* This is a concatenation of the string arguments to +* TTQRE. +* +* N (input) integer scalar +* N is the order of the Hessenberg matrix H. +* +* ILO (input) INTEGER +* IHI (input) INTEGER +* It is assumed that H is already upper triangular +* in rows and columns 1:ILO-1 and IHI+1:N. +* +* LWORK (input) integer scalar +* The amount of workspace available. +* +* Further Details +* =============== +* +* Little is known about how best to choose these parameters. +* It is possible to use different values of the parameters +* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. +* +* It is probably best to choose different parameters for +* different matrices and different parameters at different +* times during the iteration, but this has not been +* implemented --- yet. +* +* +* The best choices of most of the parameters depend +* in an ill-understood way on the relative execution +* rate of xLAQR3 and xLAQR5 and on the nature of each +* particular eigenvalue problem. Experiment may be the +* only practical way to determine which choices are most +* effective. +* +* Following is a list of default values supplied by IPARMQ. +* These defaults may be adjusted in order to attain better +* performance in any particular computational environment. +* +* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. +* Default: 75. (Must be at least 11.) +* +* IPARMQ(ISPEC=13) Recommended deflation window size. +* This depends on ILO, IHI and NS, the +* number of simultaneous shifts returned +* by IPARMQ(ISPEC=15). The default for +* (IHI-ILO+1).LE.500 is NS. The default +* for (IHI-ILO+1).GT.500 is 3*NS/2. +* +* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. +* +* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. +* a multi-shift QR iteration. +* +* If IHI-ILO+1 is ... +* +* greater than ...but less ... the +* or equal to ... than default is +* +* 0 30 NS = 2+ +* 30 60 NS = 4+ +* 60 150 NS = 10 +* 150 590 NS = ** +* 590 3000 NS = 64 +* 3000 6000 NS = 128 +* 6000 infinity NS = 256 +* +* (+) By default matrices of this order are +* passed to the implicit double shift routine +* xLAHQR. See IPARMQ(ISPEC=12) above. These +* values of NS are used only in case of a rare +* xLAHQR failure. +* +* (**) The asterisks (**) indicate an ad-hoc +* function increasing from 10 to 64. +* +* IPARMQ(ISPEC=16) Select structured matrix multiply. +* (See ISPEC=16 above for details.) +* Default: 3. +* +* ================================================================ +* .. Parameters .. + INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22 + PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14, + $ ISHFTS = 15, IACC22 = 16 ) + INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP + PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14, + $ NIBBLE = 14, KNWSWP = 500 ) + REAL TWO + PARAMETER ( TWO = 2.0 ) +* .. +* .. Local Scalars .. + INTEGER NH, NS +* .. +* .. Intrinsic Functions .. + INTRINSIC LOG, MAX, MOD, NINT, REAL +* .. +* .. Executable Statements .. + IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR. + $ ( ISPEC.EQ.IACC22 ) ) THEN +* +* ==== Set the number simultaneous shifts ==== +* + NH = IHI - ILO + 1 + NS = 2 + IF( NH.GE.30 ) + $ NS = 4 + IF( NH.GE.60 ) + $ NS = 10 + IF( NH.GE.150 ) + $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) ) + IF( NH.GE.590 ) + $ NS = 64 + IF( NH.GE.3000 ) + $ NS = 128 + IF( NH.GE.6000 ) + $ NS = 256 + NS = MAX( 2, NS-MOD( NS, 2 ) ) + END IF +* + IF( ISPEC.EQ.INMIN ) THEN +* +* +* ===== Matrices of order smaller than NMIN get sent +* . to xLAHQR, the classic double shift algorithm. +* . This must be at least 11. ==== +* + IPARMQ = NMIN +* + ELSE IF( ISPEC.EQ.INIBL ) THEN +* +* ==== INIBL: skip a multi-shift qr iteration and +* . whenever aggressive early deflation finds +* . at least (NIBBLE*(window size)/100) deflations. ==== +* + IPARMQ = NIBBLE +* + ELSE IF( ISPEC.EQ.ISHFTS ) THEN +* +* ==== NSHFTS: The number of simultaneous shifts ===== +* + IPARMQ = NS +* + ELSE IF( ISPEC.EQ.INWIN ) THEN +* +* ==== NW: deflation window size. ==== +* + IF( NH.LE.KNWSWP ) THEN + IPARMQ = NS + ELSE + IPARMQ = 3*NS / 2 + END IF +* + ELSE IF( ISPEC.EQ.IACC22 ) THEN +* +* ==== IACC22: Whether to accumulate reflections +* . before updating the far-from-diagonal elements +* . and whether to use 2-by-2 block structure while +* . doing it. A small amount of work could be saved +* . by making this choice dependent also upon the +* . NH=IHI-ILO+1. +* + IPARMQ = 0 + IF( NS.GE.KACMIN ) + $ IPARMQ = 1 + IF( NS.GE.K22MIN ) + $ IPARMQ = 2 +* + ELSE +* ===== invalid value of ispec ===== + IPARMQ = -1 +* + END IF +* +* ==== End of IPARMQ ==== +* + END diff --git a/dataassim/math/algebra/adsor.f b/dataassim/math/algebra/adsor.f new file mode 100644 index 0000000..7907baf --- /dev/null +++ b/dataassim/math/algebra/adsor.f @@ -0,0 +1,520 @@ +C[BA*) +C[KA{F 5} +C[ {Iterative Methods for Linear Systems} +C[ {Iterative Methods for Linear Systems}*) +C[FE{F 5.4} +C[ {The Gau"s-Seidel Iteration} +C[ {The Gau"s-Seidel Iteration}*) +C[LE*) +c SUBROUTINE ADSOR(A,N,IA,B,X,KADAPT,EPS,KMAX,IMETH,ISWITC, +C[IX{ADSOR}*) +c * OMEGA,WORK,RES,ITNUMB,IERR) + SUBROUTINE ADSOR(A,N,IA,B,X,IERR) +C +C***************************************************************** +C * +C This program solves an inhomogeneous linear system AX = B of * +C equations with a nonsingular system matrix A. The method of * +C Jacobi is used jointly with relaxation, where the relaxation * +C parameter OMEGA is adjusted during the iteration (adaptive * +C SOR method). * +C[BE*) +C For a suitable choice of parameters (refer to the remark * +C below), this program can perform the Gauá-Seidel method or * +C a non-adaptive SOR method. * +C * +C * +C INPUT PARAMETERS: * +C ================= * +C A : 2-dimensional array A(1:IA,1:N), containing the * +C system matrix for the linear equations * +C N : size of the linear system * +C IA : leading dimension of A, as specified in the calling * +C program * +C B : N-vector B(1:N), the right hand side of the system * +C X : N-vector X(1:N) containing the starting value for * +C iteration * +C KADAPT : Number of iterations, after which the relaxation * +C parameter is to be redefined * +C EPS : desired accuracy; the iteration is stopped when the * +C maximum norm of the relative error does not exceed * +C EPS * +C KMAX : Maximal number of iterations allowed * +C IMETH : parameter that determines the method used: * +C = 0, adaptive SOR method * +C = 1, SOR method for a given relaxation parameter * +C = 2, Gauá-Seidel method * +C ISWITC : parameter that determines the convergence criterion * +C to be used: * +C = 0, none * +C = 1, row sum criterion * +C = 2, column sum criterion * +C = 3, criterion of Schmidt and v. Mises * +C OMEGA : in case IMETH=1, the optimal relaxation parameter * +C must be part of the input; otherwise only the name * +C must be declared in the callimng program. * +C * +C * +C REMARKS: * +C ======== * +C For the adaptive SOR method (IMETH=0) we recommend to set * +C KADAPT=4 or KADAPT=5. * +C If the optimal relaxationcoefficient Wopt is known for A, then* +C one should set IMETH=1 and OMEGA = Wopt, i.e., the SOR method * +C with given optimal relaxation coefficient should be used. * +C If IMETH=2, then the program performs the Gauá-Seidel method. * +C * +C * +C AUXILIARY PARAMETERS: * +C ===================== * +C WORK : 2-dim. array WORK(1:N,1:3) * +C * +C * +C OUTPUT PARAMETERS: * +C ================== * +C A : 2-dim. array A(1:IA,1:N), the input matrix A is over-* +C written by: A(I,J)=A(I,J)/A(I,I) for I,J=1, ..., N * +C B : N-vector B(1:N), the right hand side is replaced by * +C B(I)=B(I)/A(I,I); I=1,N * +C OMEGA : - if IMETH = 0, the program returns the adaptively * +C computed relaxations parameter. * +C - if IMETH = 1, the optimal relaxation parameter * +C is returned as put in externally. * +C - if IMETH = 2, then on output OMEGA = 1. * +C X : N-vector X(1:N) that contains the solution vector * +C RES : N-vector RES(1:N) containing the residuum B - AX; * +C the residuum is available even if the desired * +C accuracy EPS could not be achieved with the given * +C maximum number of iterations. * +C ITNUMB : num,bert of iterations actually performed * +C IERR : error parameter: * +C = 0, the desired convergence criterium has not been * +C met * +C = 1, the solution X has been found * +C = 2, the desired accuracy has not been achieved after* +C KMAX iterations * +C = 3, input data incorrect * +C = 4, system matrix A is numerically singular * +C * +C----------------------------------------------------------------* +C * +C Required subroutines: GAUSEI, MNORM, CONV, RESID, MACHPD * +C * +C***************************************************************** +C * +C Author : Gisela Engeln-Mllges * +C Date : 06.09.1992 * +C Source : FORTRAN 77 * +C * +C[BA*) +C***************************************************************** +C[BE*) +C +C Declarations +C + DOUBLE PRECISION A(1:IA,1:N),B(1:N),X(1:N),WORK(1:N,1:3), + * RES(1:N),EPS,OMEGA,FMACHP,HELP,DIFFN,Q, + * RELERR,SUM,XN +C +c The following 5 lines is added by GU + EPS=1.0D-06 + KADAPT=4 + KMAX=2000 + IMETH=2 + ISWITC=0 + OMEGA=1.0d0 +c +C Checking the inputs EPS, KMAX, IMETH and ISWITC +C + IF(EPS .LE. 0.0D0 .OR. KMAX .LT. 1 .OR. ISWITC .LT. 0 .OR. + * ISWITC .GT. 3 .OR. IMETH .LT. 0 .OR. IMETH .GT. 2) THEN + IERR=3 + RETURN + ENDIF +C +C Initialize the parameters KADAPT and OMEGA depending on the method +C + IF(IMETH .EQ. 0) THEN + OMEGA=1.0D0 + ELSE IF(IMETH .EQ. 1) THEN + KADAPT=KMAX + ELSE IF(IMETH .EQ. 2) THEN + KADAPT=KMAX + OMEGA=1.0D0 + ENDIF +C +C Compute the machine constant and initialize the relative error bound +C + FMACHP=1.0D0 + 10 FMACHP=0.5D0*FMACHP + IF(MACHPD(1.0D0+FMACHP) .EQ. 1) GOTO 10 + RELERR=FMACHP*8.0D0 +C +C Initialize +C + Q=1.0D0 + ITNUMB=0 +C +C Check whether A is singular; if so, set IERR = 4. +C + DO 20 I=1,N + SUM=DABS(A(I,1)) + DO 30 K=2,N + SUM=SUM+DABS(A(I,K)) + 30 CONTINUE + IF(SUM .EQ. 0.0D0) THEN + IERR=4 + RETURN + ELSE IF(DABS(A(I,I))/SUM .LT. RELERR) THEN + IERR=4 + RETURN + ENDIF + 20 CONTINUE +C +C Redefine the entries in A and B: A(I,J) := A(I,J)/A(I,I) +C and B(I) := B(I)/A(I,I) . +C + DO 40 I=1,N + HELP=1.0D0/A(I,I) + DO 50 J=1,N + A(I,J)=A(I,J)*HELP + 50 CONTINUE + B(I)=B(I)*HELP + 40 CONTINUE +C +C Check for convergence +C + IF(ISWITC .NE. 0) THEN + CALL CONV(ISWITC,A,N,IA,IERR) + IF(IERR .EQ. 0) RETURN + ENDIF +C +C The vector RES serves as auxiliary storage for the previous solution +C vektor. Initially RES contains the staring vector. +C + DO 60 I=1,N + RES(I)=X(I) + 60 CONTINUE +C +C One iteration with the Gauá-Seidel method gives the first iterate X +C + CALL GAUSEI(A,N,IA,B,OMEGA,X) +C +C Up the iteration counter +C + ITNUMB=ITNUMB+1 +C +C Compute the difference of the last two iterates +C + DO 70 I=1,N + WORK(I,1)=X(I)-RES(I) + 70 CONTINUE +C +C Iteration loop for the chosen method +C + DO 80 K=1,KMAX-1 +C +C Check break-off criterion +C + CALL MNORM(WORK(1,1),N,DIFFN) + CALL MNORM(X,N,XN) + IF(DIFFN .LE. EPS*XN) THEN + IERR=1 + ITNUMB=K + CALL RESID(A,N,IA,B,X,RES) + RETURN + ENDIF + IF(K .EQ. KMAX-1) THEN + ITNUMB=KMAX + IERR=2 + CALL RESID(A,N,IA,B,X,RES) + RETURN + ENDIF +C +C RES contains the previous iterate +C + DO 90 I=1,N + RES(I)=X(I) + 90 CONTINUE +C +C One iteration step using Gauá-Seidel for a fixed OMEGA +C + CALL GAUSEI(A,N,IA,B,OMEGA,X) +C +C Compute the difference of the last two iterates +C + DO 100 I=1,N + WORK(I,2)=X(I)-RES(I) + 100 CONTINUE +C +C If the number of performed iterations K is divisible by KADAPT, +C then we compute Q in order to adjust the relaxation parameter; +C Q is an estimate of the spectral radius of the iteration matrix. +C + IF(MOD(K,KADAPT) .EQ. 0) THEN + DO 110 I=1,N + IF(DABS(WORK(I,1)) .LT. FMACHP) THEN + WORK(I,3)=1.0D0 + ELSE + WORK(I,3)=WORK(I,2)/WORK(I,1) + ENDIF + 110 CONTINUE + CALL MNORM(WORK(1,3),N,Q) +C +C If Q > 1, then the iteration counter is upped by one and +C the next Gauá-Seidel step is executed; otherwise a new +C relaxation parameter is calculated. +C + IF(Q .LE. 1.0D0) THEN + Q=MAX(Q,OMEGA-1.0D0) + OMEGA=2.0D0/(1.0D0+DSQRT(1.0D0-((Q+OMEGA-1.0D0) + * /OMEGA)**2/Q)) + ENDIF + ENDIF +C +C The difference vector of the last two iterations is replaced +C by the one of the previous two iterations for the approximate solution +C + DO 120 I=1,N + WORK(I,1)=WORK(I,2) + 120 CONTINUE + 80 CONTINUE + END +C +C +C[BA*) +C[LE*) + SUBROUTINE GAUSEI(A,N,IA,B,OMEGA,X) +C[IX{GAUSEI}*) +C +C***************************************************************** +C * +C This subroutine performs one iteration with the Gauá-Seidel * +C method for a given relaxation parameter. * +C[BE*) +C * +C * +C INPUT PARAMETERS: * +C ================= * +C A : 2-dim. array A(1:IA, 1:N), that contains the * +C modified system matrix A : A(I,J)=A(I,J)/A(I,I) for * +C I,J=1, ..., N * +C N : order of the system * +C IA : leading dimension of A, as specified in the calling * +C program * +C B : N-vector B(1:N) with the modified right hand side: * +C B(I)=B(I)/A(I,I); I=1, ..., N * +C OMEGA : relaxation parameter * +C X : N-vector X(1:N) containing the starting vector for * +C the iteration * +C * +C * +C OUTPUT PARAMETERS: * +C ================== * +C X : N-vector X(1:N) containing the next iteration vector * +C * +C----------------------------------------------------------------* +C * +C Required subroutines: none * +C * +C***************************************************************** +C * +C Author : Gisela Engeln-Mllges * +C Date : 06.09.1992 * +C Source : FORTRAN 77 * +C * +C[BA*) +C***************************************************************** +C[BE*) +C + DOUBLE PRECISION A(1:IA,1:N),B(1:N),X(1:N),OMEGA,S +C + DO 10 I=1,N + S=B(I) + DO 20 J=1,N + S=S-A(I,J)*X(J) + 20 CONTINUE + X(I)=X(I)+OMEGA*S + 10 CONTINUE + RETURN + END +C +C +C[BA*) +C[LE*) + SUBROUTINE MNORM(X,N,XNORM) +C[IX{MNORM}*) +C +C***************************************************************** +C * +C This subroutine calculates the maximum norm XNORM of an * +C N-vector X. * +C * +C----------------------------------------------------------------* +C[BE*) +C * +C Required subroutines: none * +C * +C***************************************************************** +C * +C Author : Gisela Engeln-Mllges * +C Date : 06.09.1992 * +C Source : FORTRAN 77 * +C * +C***************************************************************** +C + DOUBLE PRECISION X(1:N),XNORM +C + XNORM=DABS(X(1)) + DO 10 I=2,N + XNORM=DMAX1(XNORM,DABS(X(I))) + 10 CONTINUE + RETURN + END +C +C +C[BA*) +C[LE*) + SUBROUTINE CONV(ISWITC,A,N,IA,IERR) +C[IX{CONV}*) +C +C***************************************************************** +C * +C This subroutine helps check convergence. * +C[BE*) +C * +C * +C INPUT PARAMETERS: * +C ================= * +C ISWITC : Parameter that determines the convergence criterion * +C to be checked: * +C = 0, none * +C = 1, row sum criterion * +C = 2, column sum criterion * +C = 3, criterion of Schmidt and v. Mises * +C A : 2-dim. array A(1:IA, 1:N), containing the matrix for * +C which we want to check convergence of the iterates * +C from the various SOR algorithms * +C N : order of the matrix A * +C IA : leading dimension of A, as prescribed in the calling * +C program * +C * +C * +C OUTPUT PARAMETERS: * +C ================== * +C IERR : error parameter: * +C = 0, the desired convergence criterion has not been * +C met * +C = 1, the desired criterion is satified * +C * +C----------------------------------------------------------------* +C * +C Required subroutines: none * +C * +C***************************************************************** +C * +C Author : Gisela Engeln-Mllges * +C Date : 06.09.1992 * +C Source : FORTRAN 77 * +C * +C[BA*) +C***************************************************************** +C[BE*) +C + DOUBLE PRECISION A(1:IA,1:N),SUM +C +C Row sum criterion +C + IF(ISWITC .EQ. 1) THEN + DO 10 I=1,N + SUM=-1.0D0 + DO 20 J=1,N + SUM=SUM+DABS(A(I,J)) + 20 CONTINUE + IF(SUM .LT. 1.0D0) THEN + IERR=1 + ELSE + IERR=0 + RETURN + ENDIF + 10 CONTINUE +C +C Column sum criterion +C + ELSE IF(ISWITC .EQ. 2) THEN + DO 30 J=1,N + SUM=-1.0D0 + DO 40 I=1,N + SUM=SUM+DABS(A(I,J)) + 40 CONTINUE + IF(SUM .LT. 1.0D0) THEN + IERR=1 + ELSE + IERR=0 + RETURN + ENDIF + 30 CONTINUE +C +C Criterion of Schmidt and v. Mises +C + ELSE IF(ISWITC .EQ. 3) THEN + SUM=-N + DO 50 I=1,N + DO 60 J=1,N + SUM=SUM+A(I,J)*A(I,J) + 60 CONTINUE + 50 CONTINUE + SUM=DSQRT(SUM) + IF(SUM .LT. 1.0D0) THEN + IERR=1 + ELSE + IERR=0 + RETURN + ENDIF + ENDIF + END +C +C +C[BA*) +C[LE*) + SUBROUTINE RESID(A,N,IA,B,X,RES) +C[IX{RESID}*) +C +C***************************************************************** +C * +C This subroutine computes the residuum RES = B - AX, where * +C both A and B are given in modified form. * +C * +C----------------------------------------------------------------* +C[BE*) +C * +C Required subroutines: none * +C * +C***************************************************************** +C * +C Author : Gisela Engeln-Mllges * +C Date : 09.06.1992 * +C Source : FORTRAN 77 * +C * +C***************************************************************** +C + DOUBLE PRECISION A(1:IA,1:N), B(1:N), X(1:N), RES(1:N),DSUM +C + DO 10 I=1,N + DSUM=B(I) + DO 20 J=1,N + DSUM=DSUM-A(I,J)*X(J) + 20 CONTINUE + RES(I)=DSUM + 10 CONTINUE + RETURN + END +c +C[KA{F 0}{Auxiliary Library}{Auxiliary Library}*) + INTEGER FUNCTION MACHPD(X) +C[IX{MACHPD}*) + DOUBLE PRECISION X + MACHPD=0 + IF (1.0D0 .LT. X) MACHPD=1 + RETURN + END diff --git a/dataassim/math/algebra/eigen_sym_up.f b/dataassim/math/algebra/eigen_sym_up.f new file mode 100644 index 0000000..953c462 --- /dev/null +++ b/dataassim/math/algebra/eigen_sym_up.f @@ -0,0 +1,51 @@ + subroutine eigen_sym_up(N,A,W) + implicit none +! +!compute the eigenvalues and eigenvectors of a symmetrical matrix. +!A: On entry, A is a symmetrical matrix with its upper triangle filled. +! on exit, A contains the normalized eigenvectors in its columns. +!W: contains the eigenvalues in descending order. + + CHARACTER JOBZ, UPLO + INTEGER INFO, LDA, LWORK, N + DOUBLE PRECISION A(N, N), W( N ), WORK(3*N-1) + double precision p + integer i,j + + JOBZ='V' + UPLO='U' + LWORK=3*N-1 + LDA=N + call DSYEV(JOBZ,UPLO,N,A(1:N,1:N),LDA,W,WORK,LWORK,INFO) +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, the algorithm failed to converge; i +* off-diagonal elements of an intermediate tridiagonal +* form did not converge to zero. + if(INFO.lt.0)then + write(*,*)'The ',-INFO, + & 'th argument in DSYEV has an illegal value' + stop + endif + if(INFO.gt.0)then + write(*,*)'The algorithm failed to converge' + stop + endif + +! Change the eigenvalue array from ascending to descending order and rearrange +! the eigen vectors accordingly. +!--------------------------------------------- + do i=1,N/2 + p=W(i) + W(i)=W(N-i+1) + W(N-i+1)=p + do j=1,N + p=A(j,i) + A(j,i)=A(j,N-i+1) + A(j,N-i+1)=p + enddo + enddo +!--------------------------------------------- + return + end \ No newline at end of file diff --git a/dataassim/math/algebra/lfit.f b/dataassim/math/algebra/lfit.f new file mode 100644 index 0000000..cceb39b --- /dev/null +++ b/dataassim/math/algebra/lfit.f @@ -0,0 +1,201 @@ + SUBROUTINE lfit(x,y,sig,ndat,a,ma,npc,funcs,ierr) + implicit none + +! ierr = 1, ok; =0 singular matrix + + INTEGER ma,ia(ma),npc,ndat,MMAX,ierr + double precision chisq,a(ma),covar(npc,npc), + & sig(ndat),x(ndat),y(ndat) + EXTERNAL funcs + PARAMETER (MMAX=10000) +CU USES covsrt,gaussj + INTEGER i,j,k,l,m,mfit + double precision sig2i,sum,wt,ym,afunc(MMAX),beta(MMAX) + mfit=0 + ierr=1 + do 11 j=1,ma + ia(j)=1 + if(ia(j).ne.0) mfit=mfit+1 +11 continue + if(mfit.eq.0) pause 'lfit: no parameters to be fitted' + do 13 j=1,mfit + do 12 k=1,mfit + covar(j,k)=0.0d0 +12 continue + beta(j)=0.0d0 +13 continue + do 17 i=1,ndat + + call funcs(x(i),afunc,ma) + + ym=y(i) + if(mfit.lt.ma) then + do 14 j=1,ma + if(ia(j).eq.0) ym=ym-a(j)*afunc(j) +14 continue + endif + sig2i=1.0d0/sig(i)**2 + j=0 + do 16 l=1,ma + if (ia(l).ne.0) then + j=j+1 + wt=afunc(l)*sig2i + k=0 + do 15 m=1,l + if (ia(m).ne.0) then + k=k+1 + covar(j,k)=covar(j,k)+wt*afunc(m) + endif +15 continue + beta(j)=beta(j)+ym*wt + endif +16 continue +17 continue + do 19 j=2,mfit + do 18 k=1,j-1 + covar(k,j)=covar(j,k) +18 continue +19 continue + call gaussj(covar,mfit,npc,beta,1,1,ierr) + if(ierr.eq.0)then +! singular matrix + return + endif + + j=0 + do 21 l=1,ma + if(ia(l).ne.0) then + j=j+1 + a(l)=beta(j) + endif +21 continue + chisq=0.0d0 + do 23 i=1,ndat + call funcs(x(i),afunc,ma) + sum=0.0d0 + do 22 j=1,ma + sum=sum+a(j)*afunc(j) +22 continue + chisq=chisq+((y(i)-sum)/sig(i))**2 +23 continue + call covsrt(covar,npc,ma,ia,mfit) + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + SUBROUTINE covsrt(covar,npc,ma,ia,mfit) + implicit none + INTEGER ma,mfit,npc,ia(ma) + double precision covar(npc,npc) + INTEGER i,j,k + double precision swap + do 12 i=mfit+1,ma + do 11 j=1,i + covar(i,j)=0.0d0 + covar(j,i)=0.0d0 +11 continue +12 continue + k=mfit + do 15 j=ma,1,-1 + if(ia(j).ne.0)then + do 13 i=1,ma + swap=covar(i,k) + covar(i,k)=covar(i,j) + covar(i,j)=swap +13 continue + do 14 i=1,ma + swap=covar(k,i) + covar(k,i)=covar(j,i) + covar(j,i)=swap +14 continue + k=k-1 + endif +15 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + SUBROUTINE gaussj(a,n,np,b,m,mp,ierr) + implicit none + INTEGER m,mp,n,np,NMAX,ierr + double precision a(np,np),b(np,mp) + PARAMETER (NMAX=10000) + INTEGER i,icol,irow,j,k,l,ll,indxc(NMAX),indxr(NMAX), + & ipiv(NMAX) + double precision big,dum,pivinv + ierr=1 + do 11 j=1,n + ipiv(j)=0 +11 continue + do 22 i=1,n + big=0.0d0 + do 13 j=1,n + if(ipiv(j).ne.1)then + do 12 k=1,n + if (ipiv(k).eq.0) then + if (dabs(a(j,k)).ge.big)then + big=dabs(a(j,k)) + irow=j + icol=k + endif + else if (ipiv(k).gt.1) then +! pause 'singular matrix in gaussj' + ierr=0 + return + endif +12 continue + endif +13 continue + ipiv(icol)=ipiv(icol)+1 + if (irow.ne.icol) then + do 14 l=1,n + dum=a(irow,l) + a(irow,l)=a(icol,l) + a(icol,l)=dum +14 continue + do 15 l=1,m + dum=b(irow,l) + b(irow,l)=b(icol,l) + b(icol,l)=dum +15 continue + endif + indxr(i)=irow + indxc(i)=icol + if (a(icol,icol).eq.0.0d0)then +! pause 'singular matrix in gaussj' + ierr=0 + return + endif + pivinv=1.0d0/a(icol,icol) + a(icol,icol)=1.0d0 + do 16 l=1,n + a(icol,l)=a(icol,l)*pivinv +16 continue + do 17 l=1,m + b(icol,l)=b(icol,l)*pivinv +17 continue + do 21 ll=1,n + if(ll.ne.icol)then + dum=a(ll,icol) + a(ll,icol)=0.0d0 + do 18 l=1,n + a(ll,l)=a(ll,l)-a(icol,l)*dum +18 continue + do 19 l=1,m + b(ll,l)=b(ll,l)-b(icol,l)*dum +19 continue + endif +21 continue +22 continue + do 24 l=n,1,-1 + if(indxr(l).ne.indxc(l))then + do 23 k=1,n + dum=a(k,indxr(l)) + a(k,indxr(l))=a(k,indxc(l)) + a(k,indxc(l))=dum +23 continue + endif +24 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. diff --git a/dataassim/math/algebra/matrixoper.f b/dataassim/math/algebra/matrixoper.f new file mode 100644 index 0000000..fe04a19 --- /dev/null +++ b/dataassim/math/algebra/matrixoper.f @@ -0,0 +1,1000 @@ + subroutine inv_det_matix(a,n,np,a_inv, + & lnabsdet,signunit,ierr) + implicit none +! +! Invert a matrix and calculate ln(dabs(determinant)) and the assoaciated +! sign +! +!-------------Inputs------------------------------- +!a: matrix to be inverted +!n: the actual dimension of a +!np: the declared dimension of a +! +!-------------Outputs------------------------------ +!a_inv: inverse matrix of a +!lnabsdet: the ln(|det|a||) +!signunit: det|a| = signunit*exp(lnabsdet) +!ierr: =0, ok; =1, matrix a is singular + + + integer n,np,indx(np),i,j,ierr,numneg + double precision a(np,np),a_inv(np,np), + & copya(np,np),d,signunit,lnabsdet + + ierr=0 + do i=1,n + do j=1,n + copya(i,j)=a(i,j) + a_inv(i,j)=0.0d0 + enddo + a_inv(i,i)=1.0d0 + enddo + call ludcmp(copya,n,np,indx,d,ierr) + numneg=0 + lnabsdet=0.0d0 + do j=1,n + if(copya(j,j).eq.0.0d0)then +! singular matrix and the determinant is zero + ierr=1 + signunit=-1.0d+100 + lnabsdet=-1.0d+100 + return + endif + if(copya(j,j).lt.0.0d0)then + numneg=numneg+1 + endif + lnabsdet=lnabsdet+dlog(dabs(copya(j,j))) + enddo + if(d.lt.0.0d0)then + numneg=numneg+1 + endif + if(mod(numneg,2).eq.0)then + signunit=1.0d0 + else + signunit=-1.0d0 + endif + do j=1,n + call lubksb(copya,n,np,indx,a_inv(1,j)) + enddo + return + end + + subroutine svd_inv_det_matix(a,n,np,a_inv, + & lnabsdet,signunit,ierr) + implicit none +! +! Invert a matrix and calculate ln(dabs(determinant)) and the assoaciated +! sign +! +!-------------Inputs------------------------------- +!a: matrix to be inverted +!n: the actual dimension of a +!np: the declared dimension of a +! +!-------------Outputs------------------------------ +!a_inv: inverse matrix of a +!lnabsdet: the ln(|det|a||) +!signunit: det|a| = signunit*exp(lnabsdet) +!ierr: =0, ok; =1, matrix a is singular + + integer n,np,indx(np),i,j,ierr + double precision a(np,np),a_inv(np,np), + & copya(np,np),w(np),v(np,np), + & d,signunit,signunitu,signunitv, + & lnabsdet,lnabsdetu,lnabsdetv,copyatrans(np,np), + & vinw(np,np) + + ierr=0 + do i=1,n + do j=1,n + copya(i,j)=a(i,j) + enddo + enddo + call svdcmp(copya(1:n,1:n),n,n,np,np,w,v(1:n,1:n),ierr) + do i=1,n + do j=1,n + vinw(i,j)=v(i,j)/w(j) + enddo + enddo + + call matrixtranspose(n,n,copya(1:n,1:n), + & copyatrans(1:n,1:n)) + call matrixproduct(n,n,vinw(1:n,1:n),n, + & copyatrans(1:n,1:n),a_inv(1:n,1:n)) + + call det_matix(copya(1:n,1:n),n,n,lnabsdetu,signunitu,ierr) + call det_matix(v(1:n,1:n),n,n,lnabsdetv,signunitv,ierr) + + lnabsdet=0.0d0 + do j=1,n + lnabsdet=lnabsdet+dlog(w(j)) + enddo + + signunit=signunitu*signunitv + + return + end + + + subroutine det_matix(a,n,np,lnabsdet,signunit,ierr) + implicit none +! +! calculate ln(dabs(determinant)) and the assoaciated sign +! +!-------------Inputs------------------------------- +!a: matrix to be inverted +!n: the actual dimension of a +!np: the declared dimension of a +! +!-------------Outputs------------------------------ +!lnabsdet: the ln(|det|a||) +!signunit: det|a| = signunit*exp(lnabsdet) +!ierr: =1, ok; =0, matrix a is singular + + + integer n,np,indx(np),i,j,ierr,numneg + double precision a(np,np),a_inv(np,np), + & copya(np,np),d,signunit,lnabsdet + + ierr=1 + do i=1,n + do j=1,n + copya(i,j)=a(i,j) + enddo + enddo + + call ludcmp(copya(1:n,1:n),n,np,indx,d,ierr) + numneg=0 + lnabsdet=0.0d0 + do j=1,n + if(copya(j,j).eq.0.0d0)then +! singular matrix and the determinant is zero + ierr=1 + signunit=-1.0d+100 + lnabsdet=-1.0d+100 + return + endif + if(copya(j,j).lt.0.0d0)then + numneg=numneg+1 + endif + lnabsdet=lnabsdet+dlog(dabs(copya(j,j))) + enddo + if(d.lt.0.0d0)then + numneg=numneg+1 + endif + if(mod(numneg,2).eq.0)then + signunit=1.0d0 + else + signunit=-1.0d0 + endif + return + end + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + double precision function tracematrix(m,a) + implicit none + integer m,i + double precision a(m,m) + + tracematrix=0.0d0 + do i=1,m + tracematrix=tracematrix+a(i,i) + enddo + return + end + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine matrixproduct(ma,n,a,nb,b,c) + implicit none +! +! matrix product c=ab +! + integer ma,n,nb + double precision a(ma,n),b(n,nb),c(ma,nb) + integer i,j,k + do i=1,ma + do j=1,nb + c(i,j)=0.0d0 + do k=1,n + c(i,j)=c(i,j)+a(i,k)*b(k,j) + enddo + enddo + enddo + return + end + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine matrixsum(m,n,a,b,c) + implicit none +! +! matrix sum c=a+b +! + integer m,n + double precision a(m,n),b(m,n),c(m,n) + integer i,j + do i=1,m + do j=1,n + c(i,j)=a(i,j)+b(i,j) + enddo + enddo + return + end + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine matrixdif(m,n,a,b,c) + implicit none +! +! matrix difference c=a-b +! + integer m,n + double precision a(m,n),b(m,n),c(m,n) + integer i,j + do i=1,m + do j=1,n + c(i,j)=a(i,j)-b(i,j) + enddo + enddo + return + end + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine matrixtranspose(m,n,a,b) + implicit none +! +! matrix transpose b=a^T +! + integer m,n + double precision a(m,n),b(n,m) + integer i,j + do i=1,m + do j=1,n + b(j,i)=a(i,j) + enddo + enddo + return + end + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + SUBROUTINE svbksb(u,w,v,m,n,mp,np,b,x) + implicit none + INTEGER m,mp,n,np,NMAX + double precision b(mp),u(mp,np),v(np,np),w(np),x(np) + PARAMETER (NMAX=1500) + INTEGER i,j,jj + double precision s,tmp(NMAX) + do 12 j=1,n + s=0.0d0 + if(w(j).ne.0.0d0)then + do 11 i=1,m + s=s+u(i,j)*b(i) +11 continue + s=s/w(j) + endif + tmp(j)=s +12 continue + do 14 j=1,n + s=0.0d0 + do 13 jj=1,n + s=s+v(j,jj)*tmp(jj) +13 continue + x(j)=s +14 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + SUBROUTINE svdcmp(a,m,n,mp,np,w,v,ierr) + implicit none + INTEGER m,mp,n,np,NMAX ,ierr + double precision a(mp,np),v(np,np),w(np) + PARAMETER (NMAX=1500) +CU USES pythag + INTEGER i,its,j,jj,k,l,nm + double precision anorm,c,f,g,h,s,scale,x,y,z, + & rv1(NMAX),pythag + g=0.0d0 + scale=0.0d0 + anorm=0.0d0 + do 25 i=1,n + l=i+1 + rv1(i)=scale*g + g=0.0d0 + s=0.0d0 + scale=0.0d0 + if(i.le.m)then + do 11 k=i,m + scale=scale+dabs(a(k,i)) +11 continue + if(scale.ne.0.0d0)then + do 12 k=i,m + a(k,i)=a(k,i)/scale + s=s+a(k,i)*a(k,i) +12 continue + f=a(i,i) + g=-dsign(dsqrt(s),f) + h=f*g-s + a(i,i)=f-g + do 15 j=l,n + s=0.0d0 + do 13 k=i,m + s=s+a(k,i)*a(k,j) +13 continue + f=s/h + do 14 k=i,m + a(k,j)=a(k,j)+f*a(k,i) +14 continue +15 continue + do 16 k=i,m + a(k,i)=scale*a(k,i) +16 continue + endif + endif + w(i)=scale*g + g=0.0d0 + s=0.0d0 + scale=0.0d0 + if((i.le.m).and.(i.ne.n))then + do 17 k=l,n + scale=scale+dabs(a(i,k)) +17 continue + if(scale.ne.0.0d0)then + do 18 k=l,n + a(i,k)=a(i,k)/scale + s=s+a(i,k)*a(i,k) +18 continue + f=a(i,l) + g=-dsign(dsqrt(s),f) + h=f*g-s + a(i,l)=f-g + do 19 k=l,n + rv1(k)=a(i,k)/h +19 continue + do 23 j=l,m + s=0.0d0 + do 21 k=l,n + s=s+a(j,k)*a(i,k) +21 continue + do 22 k=l,n + a(j,k)=a(j,k)+s*rv1(k) +22 continue +23 continue + do 24 k=l,n + a(i,k)=scale*a(i,k) +24 continue + endif + endif + anorm=dmax1(anorm,(dabs(w(i))+dabs(rv1(i)))) +25 continue + do 32 i=n,1,-1 + if(i.lt.n)then + if(g.ne.0.0d0)then + do 26 j=l,n + v(j,i)=(a(i,j)/a(i,l))/g +26 continue + do 29 j=l,n + s=0.0d0 + do 27 k=l,n + s=s+a(i,k)*v(k,j) +27 continue + do 28 k=l,n + v(k,j)=v(k,j)+s*v(k,i) +28 continue +29 continue + endif + do 31 j=l,n + v(i,j)=0.0d0 + v(j,i)=0.0d0 +31 continue + endif + v(i,i)=1.0d0 + g=rv1(i) + l=i +32 continue + do 39 i=min(m,n),1,-1 + l=i+1 + g=w(i) + do 33 j=l,n + a(i,j)=0.0d0 +33 continue + if(g.ne.0.0d0)then + g=1.0d0/g + do 36 j=l,n + s=0.0d0 + do 34 k=l,m + s=s+a(k,i)*a(k,j) +34 continue + f=(s/a(i,i))*g + do 35 k=i,m + a(k,j)=a(k,j)+f*a(k,i) +35 continue +36 continue + do 37 j=i,m + a(j,i)=a(j,i)*g +37 continue + else + do 38 j= i,m + a(j,i)=0.0d0 +38 continue + endif + a(i,i)=a(i,i)+1.0d0 +39 continue + do 49 k=n,1,-1 + do 48 its=1,30 + do 41 l=k,1,-1 + nm=l-1 + if((dabs(rv1(l))+anorm).eq.anorm) goto 2 + if((dabs(w(nm))+anorm).eq.anorm) goto 1 +41 continue +1 c=0.0d0 + s=1.0d0 + do 43 i=l,k + f=s*rv1(i) + rv1(i)=c*rv1(i) + if((dabs(f)+anorm).eq.anorm) goto 2 + g=w(i) + h=pythag(f,g) + w(i)=h + h=1.0d0/h + c= (g*h) + s=-(f*h) + do 42 j=1,m + y=a(j,nm) + z=a(j,i) + a(j,nm)=(y*c)+(z*s) + a(j,i)=-(y*s)+(z*c) +42 continue +43 continue +2 z=w(k) + if(l.eq.k)then + if(z.lt.0.0d0)then + w(k)=-z + do 44 j=1,n + v(j,k)=-v(j,k) +44 continue + endif + goto 3 + endif + if(its.eq.30)then + ierr=0 + return + endif + x=w(l) + nm=k-1 + y=w(nm) + g=rv1(nm) + h=rv1(k) + f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0d0*h*y) + g=pythag(f,1.0d0) + f=((x-z)*(x+z)+h*((y/(f+dsign(g,f)))-h))/x + c=1.0d0 + s=1.0d0 + do 47 j=l,nm + i=j+1 + g=rv1(i) + y=w(i) + h=s*g + g=c*g + z=pythag(f,h) + rv1(j)=z + c=f/z + s=h/z + f= (x*c)+(g*s) + g=-(x*s)+(g*c) + h=y*s + y=y*c + do 45 jj=1,n + x=v(jj,j) + z=v(jj,i) + v(jj,j)= (x*c)+(z*s) + v(jj,i)=-(x*s)+(z*c) +45 continue + z=pythag(f,h) + w(j)=z + if(z.ne.0.0d0)then + z=1.0d0/z + c=f*z + s=h*z + endif + f= (c*g)+(s*y) + x=-(s*g)+(c*y) + do 46 jj=1,m + y=a(jj,j) + z=a(jj,i) + a(jj,j)= (y*c)+(z*s) + a(jj,i)=-(y*s)+(z*c) +46 continue +47 continue + rv1(l)=0.0d0 + rv1(k)=f + w(k)=x +48 continue +3 continue +49 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + double precision FUNCTION pythag(a,b) + double precision a,b + double precision absa,absb + absa=dabs(a) + absb=dabs(b) + if(absa.gt.absb)then + pythag=absa*dsqrt(1.0d0+(absb/absa)**2) + else + if(absb.eq.0.0d0)then + pythag=0.0d0 + else + pythag=absb*dsqrt(1.0d0+(absa/absb)**2) + endif + endif + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + + subroutine xmprove(N,NP,a,b,x,mark) + implicit none + INTEGER i,j,idum,N,NP,indx(N),mark + double precision d,a(NP,NP),b(N),x(N),aa(NP,NP) + + do 12 i=1,N + x(i)=b(i) + do 11 j=1,N + aa(i,j)=a(i,j) +11 continue +12 continue + call ludcmp(aa,N,NP,indx,d,mark) + if (mark .eq. 0) goto 20 + call lubksb(aa,N,NP,indx,x) + call mprove(a,aa,N,NP,indx,b,x) +20 continue + return + END + + + SUBROUTINE mprove(a,alud,n,np,indx,b,x) + implicit none + INTEGER n,np,indx(n),NMAX + double precision a(np,np),alud(np,np),b(n),x(n) + PARAMETER (NMAX=500) +CU USES lubksb + INTEGER i,j + double precision r(NMAX) + DOUBLE PRECISION sdp + do 12 i=1,n + sdp=-b(i) + do 11 j=1,n + sdp=sdp+(a(i,j))*(x(j)) +11 continue + r(i)=sdp +12 continue + call lubksb(alud,n,np,indx,r) + do 13 i=1,n + x(i)=x(i)-r(i) +13 continue + return + END + + SUBROUTINE ludcmp(a,n,np,indx,d,mark) + implicit none + INTEGER n,np,indx(n),NMAX + double precision d,a(np,np),TINY + PARAMETER (NMAX=500,TINY=1.0d-20) + INTEGER i,imax,j,k,mark + double precision aamax,dum,sum,vv(NMAX) + mark=1 + + d=1.0d0 + do 12 i=1,n + aamax=0.0d0 + do 11 j=1,n + if (dabs(a(i,j)).gt.aamax) aamax=dabs(a(i,j)) +11 continue + if (aamax.eq.0.0d0) then +! singular matrix + mark=0 + return + end if + vv(i)=1.0d0/aamax +12 continue + do 19 j=1,n + do 14 i=1,j-1 + sum=a(i,j) + do 13 k=1,i-1 + sum=sum-a(i,k)*a(k,j) +13 continue + a(i,j)=sum +14 continue + aamax=0.0d0 + do 16 i=j,n + sum=a(i,j) + do 15 k=1,j-1 + sum=sum-a(i,k)*a(k,j) +15 continue + a(i,j)=sum + dum=vv(i)*dabs(sum) + if (dum.ge.aamax) then + imax=i + aamax=dum + endif +16 continue + if (j.ne.imax)then + do 17 k=1,n + dum=a(imax,k) + a(imax,k)=a(j,k) + a(j,k)=dum +17 continue + d=-d + vv(imax)=vv(j) + endif + indx(j)=imax + if(a(j,j).eq.0.0d0)a(j,j)=TINY + if(j.ne.n)then + dum=1.0d0/a(j,j) + do 18 i=j+1,n + a(i,j)=a(i,j)*dum +18 continue + endif +19 continue + return + END + + SUBROUTINE lubksb(a,n,np,indx,b) + implicit none + INTEGER n,np,indx(n) + double precision a(np,np),b(n) + INTEGER i,ii,j,ll + double precision sum + ii=0 + do 12 i=1,n + ll=indx(i) + sum=b(ll) + b(ll)=b(i) + if (ii.ne.0)then + do 11 j=ii,i-1 + sum=sum-a(i,j)*b(j) +11 continue + else if (sum.ne.0.0d0) then + ii=i + endif + b(i)=sum +12 continue + do 14 i=n,1,-1 + sum=b(i) + do 13 j=i+1,n + sum=sum-a(i,j)*b(j) +13 continue + b(i)=sum/a(i,i) +14 continue + return + END + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine svdlinsys(n,np,a,b,x) + implicit none +! +! Solving a linear system ax=b through singular value decomposition + integer n,np + double precision a(np,np),b(np),x(np) + integer i,j,ierr + double precision u(np,np),w(np),v(np,np), + & wmax,ftol,wmin + parameter(ftol=1.0d-7) + + do i=1,n + do j=1,n + u(i,j)=a(i,j) + enddo + enddo + call svdcmp(u(1:n,1:n),n,n,np,np,w,v(1:n,1:n),ierr) + wmax=0.0d0 + do j=1,n + if(w(j).gt.wmax)wmax=w(j) + enddo + wmin=wmax*ftol + do j=1,n + if(w(j).lt.wmin)w(j)=0.0d0 + enddo + call svbksb(u(1:n,1:n),w,v(1:n,1:n),n,n,np,np,b,x) + return + end + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + + SUBROUTINE qrdcmp(a,n,np,c,d,sing) + implicit none + INTEGER n,np + DOUBLE PRECISION a(np,np),c(n),d(n) + LOGICAL sing + INTEGER i,j,k + DOUBLE PRECISION scale,sigma,sum,tau + sing=.false. + do 17 k=1,n-1 + scale=0.0d0 + do 11 i=k,n + scale=dmax1(scale,dabs(a(i,k))) +11 continue + if(scale.eq.0.0d0)then + sing=.true. + c(k)=0.0d0 + d(k)=0.0d0 + else + do 12 i=k,n + a(i,k)=a(i,k)/scale +12 continue + sum=0.0d0 + do 13 i=k,n + sum=sum+a(i,k)**2 +13 continue + sigma=dsign(dsqrt(sum),a(k,k)) + a(k,k)=a(k,k)+sigma + c(k)=sigma*a(k,k) + d(k)=-scale*sigma + do 16 j=k+1,n + sum=0.0d0 + do 14 i=k,n + sum=sum+a(i,k)*a(i,j) +14 continue + tau=sum/c(k) + do 15 i=k,n + a(i,j)=a(i,j)-tau*a(i,k) +15 continue +16 continue + endif +17 continue + d(n)=a(n,n) + if(d(n).eq.0.0d0)sing=.true. + return + END +c + SUBROUTINE qrupdt(r,qt,n,np,u,v) + implicit none + INTEGER n,np + DOUBLE PRECISION r(np,np),qt(np,np),u(np),v(np) +CU USES rotate + INTEGER i,j,k + do 11 k=n,1,-1 + if(u(k).ne.0.0d0)goto 1 +11 continue + k=1 +1 do 12 i=k-1,1,-1 + call rotate(r,qt,n,np,i,u(i),-u(i+1)) + if(u(i).eq.0.0d0)then + u(i)=dabs(u(i+1)) + else if(dabs(u(i)).gt.dabs(u(i+1)))then + u(i)=dabs(u(i))*dsqrt(1.0d0+(u(i+1)/u(i))**2) + else + u(i)=dabs(u(i+1))*dsqrt(1.0d0+(u(i)/u(i+1))**2) + endif +12 continue + do 13 j=1,n + r(1,j)=r(1,j)+u(1)*v(j) +13 continue + do 14 i=1,k-1 + call rotate(r,qt,n,np,i,r(i,i),-r(i+1,i)) +14 continue + return + END +c + SUBROUTINE rsolv(a,n,np,d,b) + implicit none + INTEGER n,np + DOUBLE PRECISION a(np,np),b(n),d(n) + INTEGER i,j + DOUBLE PRECISION sum + b(n)=b(n)/d(n) + do 12 i=n-1,1,-1 + sum=0.0d0 + do 11 j=i+1,n + sum=sum+a(i,j)*b(j) +11 continue + b(i)=(b(i)-sum)/d(i) +12 continue + return + END +c + SUBROUTINE rotate(r,qt,n,np,i,a,b) + implicit none + INTEGER n,np,i + DOUBLE PRECISION a,b,r(np,np),qt(np,np) + INTEGER j + DOUBLE PRECISION c,fact,s,w,y + if(a.eq.0.0d0)then + c=0.0d0 + s=dsign(1.0d0,b) + else if(dabs(a).gt.dabs(b))then + fact=b/a + c=dsign(1.0d0/dsqrt(1.0d0+fact**2),a) + s=fact*c + else + fact=a/b + s=dsign(1.0d0/dsqrt(1.0d0+fact**2),b) + c=fact*s + endif + do 11 j=i,n + y=r(i,j) + w=r(i+1,j) + r(i,j)=c*y-s*w + r(i+1,j)=s*y+c*w +11 continue + do 12 j=1,n + y=qt(i,j) + w=qt(i+1,j) + qt(i,j)=c*y-s*w + qt(i+1,j)=s*y+c*w +12 continue + return + END + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine symmatindex(ndim,icolrow,indexi) + implicit none + + integer ndim,icolrow,indexi(ndim) + +! this subroutine determines the sequence number of the elements of the row i +! or column i of a symmetric matrix that is stored in compact form (diagonal included) +! The compact form stores the upper triangle of the matrix sequentially +! column by column +! 1, 2, 4, 7, 11, +! 3, 5, 8, 12, +! 6, 9, 13, +! 10 14, +! 15, +! Note that it does not matter whether it is row or column because the matrix is +! symmetric + integer j,icompactpostri + + indexi(1)=icompactpostri(1,icolrow) + do j=2,icolrow + indexi(j)=indexi(j-1)+1 + enddo + do j=icolrow+1,ndim + indexi(j)=icompactpostri(icolrow,j) + enddo + return + end +! +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine ivarjvartri(invars,nvars,indexvars, + & ivar,jvar,istart,jstart) + implicit none +! +!This subroutine has two functions: +!1.Given the position number in the vector that stores the upper triangle +! (including the diagonal elements) of a symmetric matrix, determine the cell position +! (ivar,jvar) indices in the actual matrix. +!2. Determine the starting cell position in the symmetric matrix formed by all +! elements of the nvars variables. The number of elements +! indexed by ivar or jvar is specified in indexvars. + + integer invars,nvars,indexvars(nvars),ivar,jvar, + & istart,jstart + integer n0 + + jvar=int((1.0d0+dsqrt(dble(8*invars-7)))/2.0d0) + ivar=invars-(jvar*(jvar-1))/2 + if(ivar.gt.jvar)then +! rounding error + jvar=jvar+1 + ivar=invars-(jvar*(jvar-1))/2 + endif + +20 istart=0 + do n0=1,ivar-1 + istart=istart+indexvars(n0) + enddo + istart=istart+1 + jstart=0 + do n0=1,jvar-1 + jstart=jstart+indexvars(n0) + enddo + jstart=jstart+1 + return + end subroutine ivarjvartri + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine ivarjvaroff(invars,nvars,indexvars, + & ivar,jvar,istart,jstart) + implicit none +! +!This subroutine has two functions: +!1.Given the position number in the vector that stores the upper triangle +! (not including the diagonal elements) of a symmetric matrix, determine the cell position +! (ivar,jvar) indices in the actual matrix. +!2. Determine the starting cell position in the expanded matrix. The number of elements +! indexed by ivar or jvar is specified in indexvars. + + integer invars,nvars,indexvars(nvars),ivar,jvar, + & istart,jstart + integer n0 + + jvar=int((3.0d0+dsqrt(dble(8*invars-7)))/2.0d0) + ivar=invars-((jvar-2)*(jvar-1))/2 + if(ivar.ge.jvar)then +! rounding error + jvar=jvar+1 + ivar=invars-((jvar-2)*(jvar-1))/2 + endif + istart=0 + do n0=1,ivar-1 + istart=istart+indexvars(n0) + enddo + istart=istart+1 + jstart=0 + do n0=1,jvar-1 + jstart=jstart+indexvars(n0) + enddo + jstart=jstart+1 + return + end subroutine ivarjvaroff + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + integer function icompactpostri(irow0,jcol0) + implicit none +! +! determine the position of the cell (irow,jcol) in the vector +! that stores the upper triangle of a symmetric matrix, including +! the diagonal elements. +! irow <=jcol + + integer irow0,jcol0 + + icompactpostri=irow0+(jcol0*(jcol0-1))/2 + + return + end +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + integer function icompactposoff(irow0,jcol0) + implicit none +! +! determine the position of the cell (irow,jcol) in the vector +! that stores the upper triangle of a symmetric matrix, not including +! the diagonal elements. +! irow < jcol-1 + + integer irow0,jcol0 + + icompactposoff=irow0+((jcol0-1)*(jcol0-2))/2 + return + end + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine istartjstart(ivar,jvar,nvars, + & indexvars,istart,jstart) + implicit none + + integer nvars,indexvars(nvars),ivar,jvar,istart, + & jstart,n0 +! + istart=0 + do n0=1,ivar-1 + istart=istart+indexvars(n0) + enddo + istart=istart+1 + jstart=0 + do n0=1,jvar-1 + jstart=jstart+indexvars(n0) + enddo + jstart=jstart+1 + return + end subroutine istartjstart +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + integer function getwhichvar(ipos,nvars,indexvars) + implicit none +! +! determine to which variable ipos belongs + integer ipos,nvars,indexvars(nvars),n0,i +! + n0=0 + i=0 +10 i=i+1 + n0=n0+indexvars(i) + if(ipos.le.n0)then + getwhichvar=i + return + endif + goto 10 + end +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& \ No newline at end of file diff --git a/dataassim/math/algebra/matrixsquare_up.f b/dataassim/math/algebra/matrixsquare_up.f new file mode 100644 index 0000000..708035e --- /dev/null +++ b/dataassim/math/algebra/matrixsquare_up.f @@ -0,0 +1,19 @@ + subroutine matrixsquare_up(m,n,A,B) + implicit none + +! compute B=AA^T. B is symmetrical so only its upper triangle is computed. + integer m,n + double precision A(m,n),B(m,m) + + integer i,j,k + do i=1,m + do j=i,m + B(i,j)=0.0d0 + do k=1,n + B(i,j)=B(i,j)+A(i,k)*A(j,k) + enddo + enddo + enddo + return + end + \ No newline at end of file diff --git a/dataassim/math/algebra/orthlinreg.f b/dataassim/math/algebra/orthlinreg.f new file mode 100644 index 0000000..0bdaa57 --- /dev/null +++ b/dataassim/math/algebra/orthlinreg.f @@ -0,0 +1,428 @@ + + program main + implicit none + double precision x(1000),y(1000),dx(1000),dy(1000), + * slope,fintcpt,rtmnsquare,xoutliers(100),youtliers(1000), + * x1(1000),y1(1000),k,b,sum1,sum2 + integer nsamp,i,numoutliers,nsamp1 + + open(unit=1,file='testdata.txt') + i=1 +10 read(1,*,end=100)x(i),y(i) + i=i+1 + goto 10 +100 nsamp=i-1 + + goto 200 + + + nsamp=13 + x(1)=-1.0d0 + y(1)=3.0d0 + x(2)=-3.0d0 + y(2)=4.0d0 + x(3)=-5.0d0 + y(3)=5.0d0 + x(4)=-7.0d0 + y(4)=6.0d0 + x(5)=-9.0d0 + y(5)=7.0d0 + x(6)=-11.0d0 + y(6)=8.0d0 + x(7)=-3.0d0 + y(7)=1.0d0 + x(8)=-5.0d0 + y(8)=2.0d0 + x(9)=-7.0d0 + y(9)=3.0d0 + x(10)=-9.0d0 + y(10)=4.0d0 + x(11)=-11.0d0 + y(11)=5.0d0 + x(12)=-4.0d0 + y(12)=7.0d0 + x(13)=-12.0d0 + y(13)=1.0d0 + +200 slope=-2.0d0 + fintcpt=0.0d0 + + call OrthSoilRespRegres(nsamp,x,y,slope,fintcpt) + write(*,*)slope,fintcpt + pause + + slope=-2.0d0 + fintcpt=0.0d0 + + call orthlinreg_outlier(nsamp,x,y,slope, + & fintcpt,dx,dy,rtmnsquare,xoutliers,youtliers, + & numoutliers) + write(*,*)slope/2.0d0,fintcpt,numoutliers + do i=1,numoutliers + write(*,*)xoutliers(i),youtliers(i) + enddo + end + + subroutine orthlinreg_outlier(nsamp0,x0,y0,slope, + & fintcpt,dx,dy,rtmnsquare,xoutliers,youtliers, + & numoutliers) + implicit none + integer nsamp0,numoutliers + double precision x0(nsamp0),y0(nsamp0),slope, + & fintcpt,dx(nsamp0),dy(nsamp0),rtmnsquare, + & xoutliers(nsamp0),youtliers(nsamp0),xtest(nsamp0), + & ytest(nsamp0),slopetest,fintcpttest,dxtest(nsamp0), + & dytest(nsamp0),rtmnsquaretest,testmeasure(nsamp0), + & x(nsamp0),y(nsamp0) + + integer iwhichside,nsamptest,isitoutlier, + & isoutlier_1side,i,j,nsamp + parameter (iwhichside=1) + + numoutliers=0 + nsamp=nsamp0 + do i=1,nsamp + x(i)=x0(i) + y(i)=y0(i) + enddo + +50 call orthlinreg(nsamp,x,y,slope,fintcpt, + & dx,dy,rtmnsquare) + + write(*,*)slope,fintcpt,rtmnsquare + stop + nsamptest=nsamp-1 + do i=1,nsamp + do j=1,nsamp + xtest(j)=x(j) + ytest(j)=y(j) + enddo + xtest(i)=x(nsamp) + ytest(i)=y(nsamp) + call orthlinreg(nsamptest,xtest,ytest,slopetest, + & fintcpttest,dxtest,dytest,rtmnsquaretest) +! write(*,*)i,slopetest,fintcpttest + +! testmeasure(i)=(slopetest-slope)**2+ +! & (fintcpttest-fintcpt)**2 + + testmeasure(i)=100.0d0*dabs(rtmnsquaretest-rtmnsquare)/ + & rtmnsquare +! write(*,*)i,testmeasure(i) + enddo + + isitoutlier=isoutlier_1side(nsamp,testmeasure,iwhichside) + if(isitoutlier.lt.1.or.isitoutlier.gt.nsamp)return +! outlier detected + numoutliers=numoutliers+1 + xoutliers(numoutliers)=x(isitoutlier) + youtliers(numoutliers)=y(isitoutlier) + x(isitoutlier)=x(nsamp) + y(isitoutlier)=y(nsamp) + nsamp=nsamp-1 + if(nsamp.le.2)then + write(*,*)'No enough good data left' + stop + endif + goto 50 + return + end + +! orthogonal linear regression + subroutine orthlinreg(nsamp,x,y,slope0,fintcpt0, + & dx,dy,rtmnsquare) + implicit none + integer nsamp + double precision x(nsamp),y(nsamp),dx1(nsamp), + & dy1(nsamp),slope(2),fintcpt(2),dx2(nsamp), + & dy2(nsamp),slope0,fintcpt0,dx(nsamp),dy(nsamp) + integer i,j + double precision w,u,v,xbar,ybar,root1,root2, + & a,b,c,rtmnsquare1,rtmnsquare2,rtmnsquare + + + + xbar=0.0d0 + ybar=0.0d0 + w=0.0d0 + u=0.0d0 + v=0.0d0 + do i=1,nsamp + xbar=xbar+x(i) + ybar=ybar+y(i) + w=w+x(i)*x(i) + u=u+y(i)*y(i) + v=v+x(i)*y(i) + enddo + xbar=xbar/dble(nsamp) + ybar=ybar/dble(nsamp) + w=w/dble(nsamp) + u=u/dble(nsamp) + v=v/dble(nsamp) + a=v-xbar*ybar + b=w-u-xbar*xbar+ybar*ybar + c=xbar*ybar-v + call quadraticroots(a,b,c,root1,root2) + slope(1)=root1 + slope(2)=root2 + fintcpt(1)=ybar-slope(1)*xbar + fintcpt(2)=ybar-slope(2)*xbar + rtmnsquare1=0.0d0 + rtmnsquare2=0.0d0 + do i=1,nsamp + dx1(i)=(y(i)-fintcpt(1)-x(i)*slope(1))* + & slope(1)/(1.0d0+slope(1)*slope(1)) + dy1(i)=-(y(i)-fintcpt(1)-x(i)*slope(1))/ + & (1.0d0+slope(1)*slope(1)) + rtmnsquare1=rtmnsquare1+dx1(i)**2+dy1(i)**2 + + dx2(i)=(y(i)-fintcpt(2)-x(i)*slope(2))* + & slope(2)/(1.0d0+slope(2)*slope(2)) + dy2(i)=-(y(i)-fintcpt(2)-x(i)*slope(2))/ + & (1.0d0+slope(2)*slope(2)) + rtmnsquare2=rtmnsquare2+dx2(i)**2+dy2(i)**2 + enddo + rtmnsquare1=dsqrt(rtmnsquare1/dble(nsamp)) + rtmnsquare2=dsqrt(rtmnsquare2/dble(nsamp)) + if(rtmnsquare1.gt.rtmnsquare2)then + rtmnsquare=rtmnsquare2 + slope0=slope(2) + fintcpt0=fintcpt(2) + do i=1,nsamp + dx(i)=dx2(i) + dy(i)=dy2(i) + enddo + else + rtmnsquare=rtmnsquare1 + slope0=slope(1) + fintcpt0=fintcpt(1) + do i=1,nsamp + dx(i)=dx1(i) + dy(i)=dy1(i) + enddo + endif + return + end + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +! + subroutine OrthSoilRespRegres(npoints,x0,y0,slope,fintcpt) + implicit none +c +C ODRPACK ARGUMENT DEFINITIONS +C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE +C ==> N NUMBER OF OBSERVATIONS +C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C <==> BETA FUNCTION PARAMETERS +C ==> Y RESPONSE VARIABLE +C ==> LDY LEADING DIMENSION OF ARRAY Y +C ==> X EXPLANATORY VARIABLE +C ==> LDX LEADING DIMENSION OF ARRAY X +C ==> WE "EPSILON" WEIGHTS +C ==> LDWE LEADING DIMENSION OF ARRAY WE +C ==> LD2WE SECOND DIMENSION OF ARRAY WE +C ==> WD "DELTA" WEIGHTS +C ==> LDWD LEADING DIMENSION OF ARRAY WD +C ==> LD2WD SECOND DIMENSION OF ARRAY WD +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> JOB TASK TO BE PERFORMED +C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS +C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR +C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION +C ==> PARTOL PARAMETER CONVERGENCE CRITERION +C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS +C ==> IPRINT PRINT CONTROL +C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS +C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS +C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA +C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA +C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD +C ==> SCLB SCALE VALUES FOR PARAMETERS BETA +C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE +C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD +C <==> WORK DOUBLE PRECISION WORK VECTOR +C ==> LWORK DIMENSION OF VECTOR WORK +C <== IWORK INTEGER WORK VECTOR +C ==> LIWORK DIMENSION OF VECTOR IWORK +C <== INFO STOPPING CONDITION + +C PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER +C MAXN MAXIMUM NUMBER OF OBSERVATIONS +C MAXM MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C MAXNP MAXIMUM NUMBER OF FUNCTION PARAMETERS +C MAXNQ MAXIMUM NUMBER OF RESPONSES PER OBSERVATION + +C PARAMETER DECLARATIONS AND SPECIFICATIONS + INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ + PARAMETER (MAXM=25,MAXN=50000,MAXNP=30,MAXNQ=1, + + LDY=MAXN,LDX=MAXN, + + LDWE=1,LD2WE=1,LDWD=1,LD2WD=1, + + LDIFX=MAXN,LDSTPD=1,LDSCLD=1, + + LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + + + 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP + + + 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + + + 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ, + + LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM)) +C VARIABLE DECLARATIONS + INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N, + + NDIGIT,NP,NQ + INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK) + DOUBLE PRECISION PARTOL,SSTOL,TAUFAC + DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM), + + STPB(MAXNP),STPD(LDSTPD,MAXM), + + WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ), + + WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ) +c + integer npoints,i1 + double precision x0(npoints),y0(npoints),slope,fintcpt + + + + EXTERNAL OrthRespFCN +c +C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS + WE(1,1,1) = -1.0D0 + WD(1,1,1) = -1.0D0 + IFIXB(1) = -1 +! IFIXX(1,1) = -1 +! JOB = 00023 + JOB=20 + NDIGIT = -1 + TAUFAC = -1.0D0 + SSTOL = -1.0D0 + PARTOL = -1.0D0 + MAXIT = -1 +! IPRINT = -1 +! IPRINT=0 + IPRINT=-1 + LUNERR = -1 + LUNRPT = -1 + STPB(1) = -1.0D0 + STPD(1,1) = -1.0D0 + SCLB(1) = -1.0D0 + SCLD(1,1) = -1.0D0 + + MAXIT = 200000 +C SET UP ODRPACK REPORT FILES + LUNERR = 9 + LUNRPT = 9 +c + N=npoints + M=1 + NP=2 + NQ=1 + + + do I=1,N + do i1=1,M + X(I,i1)=x0(I) + enddo + Y(I,1)=y0(I) + enddo + BETA(1)=slope + BETA(2)=fintcpt + +C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX + DO 10 I=1,N + DO 15 J=1, M + IFIXX(I,J) = 1 +15 CONTINUE +10 CONTINUE +60 CALL DODRC(OrthRespFCN, + + N,M,NP,NQ, + + BETA, + + Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, + + SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, + + SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + + slope=BETA(1) + fintcpt=BETA(2) + return + END +c + SUBROUTINE OrthRespFCN(N,M,NP,NQ, + + LDN,LDM,LDNP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,F,FJACB,FJACD, + + ISTOP) + implicit none +C SUBROUTINE ARGUMENTS +C ==> N NUMBER OF OBSERVATIONS +C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N +C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M +C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP +C ==> BETA CURRENT VALUES OF PARAMETERS +C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED +C <== F PREDICTED FUNCTION VALUES +C <== FJACB JACOBIAN WITH RESPECT TO BETA +C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA +C <== ISTOP STOPPING CONDITION, WHERE +C 0 MEANS CURRENT BETA AND X+DELTA WERE +C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY +C 1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES +C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE +C -1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD STOP + +C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE: + INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ + DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M) + INTEGER IFIXB(NP),IFIXX(LDIFX,M) +C OUTPUT ARGUMENTS: + DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) + +C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM +c +! + IF (MOD(IDEVAL,10).GE.1) THEN + DO 110 L = 1,NQ + DO 100 I = 1,N + F(I,L)=BETA(2)+BETA(1)*XPLUSD(I,1) + 100 CONTINUE + 110 CONTINUE + END IF + +C COMPUTE DERIVATIVES WITH RESPECT TO BETA + IF (MOD(IDEVAL/10,10).GE.1) THEN + DO 210 L = 1,NQ + DO 200 I = 1,N + FJACB(I,1,L)=XPLUSD(I,1) + FJACB(I,2,L)=1.0d0 + 200 CONTINUE + 210 CONTINUE + ENDIF + +C COMPUTE DERIVATIVES WITH RESPECT TO DELTA + IF (MOD(IDEVAL/100,10).GE.1) THEN + DO 310 L = 1,NQ + DO 300 I = 1,N + FJACD(I,1,L)=BETA(1) + 300 CONTINUE + 310 CONTINUE + + END IF + RETURN + END +! +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/algebra/symmetricmatrix.f b/dataassim/math/algebra/symmetricmatrix.f new file mode 100644 index 0000000..b64bccc --- /dev/null +++ b/dataassim/math/algebra/symmetricmatrix.f @@ -0,0 +1,1016 @@ +! program main +! implicit none +! integer n,i,j,kpvt(100),info,irowinc,index,nii,job, +! & inert(3) +! double precision aa(300),ac(300),sum,b(200),bc(200), +! & a2(100,100),ra2c(100,100),ran2,work(100), +! & lnabsdet,signunit,det(2) + +! n=20 +! do i=1,n*(n+1)/2 +! ac(i)=dble(i)*ran2() +! enddo + +! do i=1,n +! b(i)=(0.9d0+2.0d0*dble(i)-0.001d0*dble(i*i))*ran2() +! bc(i)=b(i) +! enddo + +! irowinc=1 +! do i=1,n +! do j=1,n +! if(j.le.i)then +! index=j+irowinc-1 +! if(j.eq.i)then +! nii=j+irowinc-1 +! endif +! else +! index=nii+j-1 +! nii=nii+j-1 +! endif +! a2(i,j)=ac(index) +! enddo +! irowinc=irowinc+i +! enddo + +! call dspfa(ac,n,kpvt,info) +! job=11 +! call dspdi(ac,n,kpvt,det,inert,work,job) +! irowinc=1 +! do i=1,n +! do j=1,n +! if(j.le.i)then +! index=j+irowinc-1 +! if(j.eq.i)then +! nii=j+irowinc-1 +! endif +! else +! index=nii+j-1 +! nii=nii+j-1 +! endif +! ra2c(i,j)=ac(index) +! enddo +! irowinc=irowinc+i +! enddo +! do i=1,20 +! write(2,310)(ra2c(i,j),j=1,20) +! enddo +! write(2,*) +! write(*,*) det(1) * 10.0d0**det(2) + +! call inv_det_matix(a2(1:n,1:n),n,n,ra2c(1:n,1:n), +! & lnabsdet,signunit,info) + +! write(*,*)signunit*dexp(lnabsdet) +! do i=1,20 +! write(2,310)(ra2c(i,j),j=1,20) +! enddo + +! stop + + +! call dspsl(ac,n,kpvt,b) +! do i=1,n +! write(*,*)b(i) +! enddo +! write(*,*) +! call svdlinsys(n,n,a2(1:n,1:n),bc,aa) +! do i=1,n +! write(*,*)aa(i)-b(i) +! enddo +!310 format(1x,20f15.8) +! end + + + subroutine dspfa(ap,n,kpvt,info) + integer n,kpvt(1),info + double precision ap(1) +c +c dspfa factors a double precision symmetric matrix stored in +c packed form by elimination with symmetric pivoting. +c +c to solve a*x = b , follow dspfa by dspsl. +c to compute inverse(a)*c , follow dspfa by dspsl. +c to compute determinant(a) , follow dspfa by dspdi. +c to compute inertia(a) , follow dspfa by dspdi. +c to compute inverse(a) , follow dspfa by dspdi. +c +c on entry +c +c ap double precision (n*(n+1)/2) +c the packed form of a symmetric matrix a . the +c columns of the upper triangle are stored sequentially +c in a one-dimensional array of length n*(n+1)/2 . +c see comments below for details. +c +c n integer +c the order of the matrix a . +c +c output +c +c ap a block diagonal matrix and the multipliers which +c were used to obtain it stored in packed form. +c the factorization can be written a = u*d*trans(u) +c where u is a product of permutation and unit +c upper triangular matrices , trans(u) is the +c transpose of u , and d is block diagonal +c with 1 by 1 and 2 by 2 blocks. +c +c kpvt integer(n) +c an integer vector of pivot indices. +c +c info integer +c = 0 normal value. +c = k if the k-th pivot block is singular. this is +c not an error condition for this subroutine, +c but it does indicate that dspsl or dspdi may +c divide by zero if called. +c +c packed storage +c +c the following program segment will pack the upper +c triangle of a symmetric matrix. +c +c k = 0 +c do 20 j = 1, n +c do 10 i = 1, j +c k = k + 1 +c ap(k) = a(i,j) +c 10 continue +c 20 continue +c +c linpack. this version dated 08/14/78 . +c james bunch, univ. calif. san diego, argonne nat. lab. +c +c subroutines and functions +c +c blas daxpysym,dswap,idamax +c fortran dabs,dmax1,dsqrt +c +c internal variables +c + double precision ak,akm1,bk,bkm1,denom,mulk,mulkm1,t + double precision absakk,alpha,colmax,rowmax + integer idamax,ij,ijj,ik,ikm1,im,imax,imaxp1,imim,imj,imk + integer j,jj,jk,jkm1,jmax,jmim,k,kk,km1,km1k,km1km1,km2,kstep + logical swap + +c +c initialize +c +c alpha is used in choosing pivot block size. + alpha = (1.0d0 + dsqrt(17.0d0))/8.0d0 +c + info = 0 +c +c main loop on k, which goes from n to 1. +c + k = n + ik = (n*(n - 1))/2 + 10 continue +c +c leave the loop if k=0 or k=1. +c +c ...exit + if (k .eq. 0) go to 200 + if (k .gt. 1) go to 20 + kpvt(1) = 1 + if (ap(1) .eq. 0.0d0) info = 1 +c ......exit + go to 200 + 20 continue +c +c this section of code determines the kind of +c elimination to be performed. when it is completed, +c kstep will be set to the size of the pivot block, and +c swap will be set to .true. if an interchange is +c required. +c + km1 = k - 1 + kk = ik + k + absakk = dabs(ap(kk)) +c +c determine the largest off-diagonal element in +c column k. +c + imax = idamax(k-1,ap(ik+1),1) + imk = ik + imax + colmax = dabs(ap(imk)) + if (absakk .lt. alpha*colmax) go to 30 + kstep = 1 + swap = .false. + go to 90 + 30 continue +c +c determine the largest off-diagonal element in +c row imax. +c + rowmax = 0.0d0 + imaxp1 = imax + 1 + im = imax*(imax - 1)/2 + imj = im + 2*imax + do 40 j = imaxp1, k + rowmax = dmax1(rowmax,dabs(ap(imj))) + imj = imj + j + 40 continue + if (imax .eq. 1) go to 50 + jmax = idamax(imax-1,ap(im+1),1) + jmim = jmax + im + rowmax = dmax1(rowmax,dabs(ap(jmim))) + 50 continue + imim = imax + im + if (dabs(ap(imim)) .lt. alpha*rowmax) go to 60 + kstep = 1 + swap = .true. + go to 80 + 60 continue + if (absakk .lt. alpha*colmax*(colmax/rowmax)) go to 70 + kstep = 1 + swap = .false. + go to 80 + 70 continue + kstep = 2 + swap = imax .ne. km1 + 80 continue + 90 continue + if (dmax1(absakk,colmax) .ne. 0.0d0) go to 100 +c +c column k is zero. set info and iterate the loop. +c + kpvt(k) = k + info = k + go to 190 + 100 continue + if (kstep .eq. 2) go to 140 +c +c 1 x 1 pivot block. +c + if (.not.swap) go to 120 +c +c perform an interchange. +c + call dswap(imax,ap(im+1),1,ap(ik+1),1) + imj = ik + imax + do 110 jj = imax, k + j = k + imax - jj + jk = ik + j + t = ap(jk) + ap(jk) = ap(imj) + ap(imj) = t + imj = imj - (j - 1) + 110 continue + 120 continue +c +c perform the elimination. +c + ij = ik - (k - 1) + do 130 jj = 1, km1 + j = k - jj + jk = ik + j + mulk = -ap(jk)/ap(kk) + t = mulk + call daxpysym(j,t,ap(ik+1),1,ap(ij+1),1) + ijj = ij + j + ap(jk) = mulk + ij = ij - (j - 1) + 130 continue +c +c set the pivot array. +c + kpvt(k) = k + if (swap) kpvt(k) = imax + go to 190 + 140 continue +c +c 2 x 2 pivot block. +c + km1k = ik + k - 1 + ikm1 = ik - (k - 1) + if (.not.swap) go to 160 +c +c perform an interchange. +c + call dswap(imax,ap(im+1),1,ap(ikm1+1),1) + imj = ikm1 + imax + do 150 jj = imax, km1 + j = km1 + imax - jj + jkm1 = ikm1 + j + t = ap(jkm1) + ap(jkm1) = ap(imj) + ap(imj) = t + imj = imj - (j - 1) + 150 continue + t = ap(km1k) + ap(km1k) = ap(imk) + ap(imk) = t + 160 continue +c +c perform the elimination. +c + km2 = k - 2 + if (km2 .eq. 0) go to 180 + ak = ap(kk)/ap(km1k) + km1km1 = ikm1 + k - 1 + akm1 = ap(km1km1)/ap(km1k) + denom = 1.0d0 - ak*akm1 + ij = ik - (k - 1) - (k - 2) + do 170 jj = 1, km2 + j = km1 - jj + jk = ik + j + bk = ap(jk)/ap(km1k) + jkm1 = ikm1 + j + bkm1 = ap(jkm1)/ap(km1k) + mulk = (akm1*bk - bkm1)/denom + mulkm1 = (ak*bkm1 - bk)/denom + t = mulk + call daxpysym(j,t,ap(ik+1),1,ap(ij+1),1) + t = mulkm1 + call daxpysym(j,t,ap(ikm1+1),1,ap(ij+1),1) + ap(jk) = mulk + ap(jkm1) = mulkm1 + ijj = ij + j + ij = ij - (j - 1) + 170 continue + 180 continue +c +c set the pivot array. +c + kpvt(k) = 1 - k + if (swap) kpvt(k) = -imax + kpvt(k-1) = kpvt(k) + 190 continue + ik = ik - (k - 1) + if (kstep .eq. 2) ik = ik - (k - 2) + k = k - kstep + go to 10 + 200 continue + return + end + + subroutine daxpysym(n,da,dx,incx,dy,incy) +c +c constant times a vector plus a vector. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),da + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if (da .eq. 0.0d0) return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dy(iy) + da*dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,4) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dy(i) + da*dx(i) + 30 continue + if( n .lt. 4 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,4 + dy(i) = dy(i) + da*dx(i) + dy(i + 1) = dy(i + 1) + da*dx(i + 1) + dy(i + 2) = dy(i + 2) + da*dx(i + 2) + dy(i + 3) = dy(i + 3) + da*dx(i + 3) + 50 continue + return + end + + subroutine dswap (n,dx,incx,dy,incy) +c +c interchanges two vectors. +c uses unrolled loops for increments equal one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal +c to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dx(ix) + dx(ix) = dy(iy) + dy(iy) = dtemp + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,3) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + 30 continue + if( n .lt. 3 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,3 + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + dtemp = dx(i + 1) + dx(i + 1) = dy(i + 1) + dy(i + 1) = dtemp + dtemp = dx(i + 2) + dx(i + 2) = dy(i + 2) + dy(i + 2) = dtemp + 50 continue + return + end + + 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 modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),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 + + subroutine dspdi(ap,n,kpvt,det,inert,work,job) + integer n,job + double precision ap(1),work(1) + double precision det(2) + integer kpvt(1),inert(3) +c +c dspdi computes the determinant, inertia and inverse +c of a double precision symmetric matrix using the factors from +c dspfa, where the matrix is stored in packed form. +c +c on entry +c +c ap double precision (n*(n+1)/2) +c the output from dspfa. +c +c n integer +c the order of the matrix a. +c +c kpvt integer(n) +c the pivot vector from dspfa. +c +c work double precision(n) +c work vector. contents ignored. +c +c job integer +c job has the decimal expansion abc where +c if c .ne. 0, the inverse is computed, +c if b .ne. 0, the determinant is computed, +c if a .ne. 0, the inertia is computed. +c +c for example, job = 111 gives all three. +c +c on return +c +c variables not requested by job are not used. +c +c ap contains the upper triangle of the inverse of +c the original matrix, stored in packed form. +c the columns of the upper triangle are stored +c sequentially in a one-dimensional array. +c +c det double precision(2) +c determinant of original matrix. +c determinant = det(1) * 10.0**det(2) +c with 1.0 .le. dabs(det(1)) .lt. 10.0 +c or det(1) = 0.0. +c +c inert integer(3) +c the inertia of the original matrix. +c inert(1) = number of positive eigenvalues. +c inert(2) = number of negative eigenvalues. +c inert(3) = number of zero eigenvalues. +c +c error condition +c +c a division by zero will occur if the inverse is requested +c and dspco has set rcond .eq. 0.0 +c or dspfa has set info .ne. 0 . +c +c linpack. this version dated 08/14/78 . +c james bunch, univ. calif. san diego, argonne nat. lab. +c +c subroutines and functions +c +c blas daxpysym,dcopysym,ddotsym,dswap +c fortran dabs,iabs,mod +c +c internal variables. +c + double precision akkp1,ddotsym,temp + double precision ten,d,t,ak,akp1 + integer ij,ik,ikp1,iks,j,jb,jk,jkp1 + integer k,kk,kkp1,km1,ks,ksj,kskp1,kstep + logical noinv,nodet,noert +c + noinv = mod(job,10) .eq. 0 + nodet = mod(job,100)/10 .eq. 0 + noert = mod(job,1000)/100 .eq. 0 +c + if (nodet .and. noert) go to 140 + if (noert) go to 10 + inert(1) = 0 + inert(2) = 0 + inert(3) = 0 + 10 continue + if (nodet) go to 20 + det(1) = 1.0d0 + det(2) = 0.0d0 + ten = 10.0d0 + 20 continue + t = 0.0d0 + ik = 0 + do 130 k = 1, n + kk = ik + k + d = ap(kk) +c +c check if 1 by 1 +c + if (kpvt(k) .gt. 0) go to 50 +c +c 2 by 2 block +c use det (d s) = (d/t * c - t) * t , t = dabs(s) +c (s c) +c to avoid underflow/overflow troubles. +c take two passes through scaling. use t for flag. +c + if (t .ne. 0.0d0) go to 30 + ikp1 = ik + k + kkp1 = ikp1 + k + t = dabs(ap(kkp1)) + d = (d/t)*ap(kkp1+1) - t + go to 40 + 30 continue + d = t + t = 0.0d0 + 40 continue + 50 continue +c + if (noert) go to 60 + if (d .gt. 0.0d0) inert(1) = inert(1) + 1 + if (d .lt. 0.0d0) inert(2) = inert(2) + 1 + if (d .eq. 0.0d0) inert(3) = inert(3) + 1 + 60 continue +c + if (nodet) go to 120 + det(1) = d*det(1) + if (det(1) .eq. 0.0d0) go to 110 + 70 if (dabs(det(1)) .ge. 1.0d0) go to 80 + det(1) = ten*det(1) + det(2) = det(2) - 1.0d0 + go to 70 + 80 continue + 90 if (dabs(det(1)) .lt. ten) go to 100 + det(1) = det(1)/ten + det(2) = det(2) + 1.0d0 + go to 90 + 100 continue + 110 continue + 120 continue + ik = ik + k + 130 continue + 140 continue +c +c compute inverse(a) +c + if (noinv) go to 270 + k = 1 + ik = 0 + 150 if (k .gt. n) go to 260 + km1 = k - 1 + kk = ik + k + ikp1 = ik + k + kkp1 = ikp1 + k + if (kpvt(k) .lt. 0) go to 180 +c +c 1 by 1 +c + ap(kk) = 1.0d0/ap(kk) + if (km1 .lt. 1) go to 170 + call dcopysym(km1,ap(ik+1),1,work,1) + ij = 0 + do 160 j = 1, km1 + jk = ik + j + ap(jk) = ddotsym(j,ap(ij+1),1,work,1) + call daxpysym(j-1,work(j),ap(ij+1),1,ap(ik+1),1) + ij = ij + j + 160 continue + ap(kk) = ap(kk) + ddotsym(km1,work,1,ap(ik+1),1) + 170 continue + kstep = 1 + go to 220 + 180 continue +c +c 2 by 2 +c + t = dabs(ap(kkp1)) + ak = ap(kk)/t + akp1 = ap(kkp1+1)/t + akkp1 = ap(kkp1)/t + d = t*(ak*akp1 - 1.0d0) + ap(kk) = akp1/d + ap(kkp1+1) = ak/d + ap(kkp1) = -akkp1/d + if (km1 .lt. 1) go to 210 + call dcopysym(km1,ap(ikp1+1),1,work,1) + ij = 0 + do 190 j = 1, km1 + jkp1 = ikp1 + j + ap(jkp1) = ddotsym(j,ap(ij+1),1,work,1) + call daxpysym(j-1,work(j),ap(ij+1),1,ap(ikp1+1),1) + ij = ij + j + 190 continue + ap(kkp1+1) = ap(kkp1+1) + * + ddotsym(km1,work,1,ap(ikp1+1),1) + ap(kkp1) = ap(kkp1) + * + ddotsym(km1,ap(ik+1),1,ap(ikp1+1),1) + call dcopysym(km1,ap(ik+1),1,work,1) + ij = 0 + do 200 j = 1, km1 + jk = ik + j + ap(jk) = ddotsym(j,ap(ij+1),1,work,1) + call daxpysym(j-1,work(j),ap(ij+1),1,ap(ik+1),1) + ij = ij + j + 200 continue + ap(kk) = ap(kk) + ddotsym(km1,work,1,ap(ik+1),1) + 210 continue + kstep = 2 + 220 continue +c +c swap +c + ks = iabs(kpvt(k)) + if (ks .eq. k) go to 250 + iks = (ks*(ks - 1))/2 + call dswap(ks,ap(iks+1),1,ap(ik+1),1) + ksj = ik + ks + do 230 jb = ks, k + j = k + ks - jb + jk = ik + j + temp = ap(jk) + ap(jk) = ap(ksj) + ap(ksj) = temp + ksj = ksj - (j - 1) + 230 continue + if (kstep .eq. 1) go to 240 + kskp1 = ikp1 + ks + temp = ap(kskp1) + ap(kskp1) = ap(kkp1) + ap(kkp1) = temp + 240 continue + 250 continue + ik = ik + k + if (kstep .eq. 2) ik = ik + k + 1 + k = k + kstep + go to 150 + 260 continue + 270 continue + return + end + + subroutine dcopysym(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end + + double precision function ddotsym(n,dx,incx,dy,incy) +c +c forms the dot product of two vectors. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + ddotsym = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddotsym = dtemp + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + 50 continue + 60 ddotsym = dtemp + return + end + + subroutine dspsl(ap,n,kpvt,b) + integer n,kpvt(1) + double precision ap(1),b(1) +c +c dsisl solves the double precision symmetric system +c a * x = b +c using the factors computed by dspfa. +c +c on entry +c +c ap double precision(n*(n+1)/2) +c the output from dspfa. +c +c n integer +c the order of the matrix a . +c +c kpvt integer(n) +c the pivot vector from dspfa. +c +c b double precision(n) +c the right hand side vector. +c +c on return +c +c b the solution vector x . +c +c error condition +c +c a division by zero may occur if dspco has set rcond .eq. 0.0 +c or dspfa has set info .ne. 0 . +c +c to compute inverse(a) * c where c is a matrix +c with p columns +c call dspfa(ap,n,kpvt,info) +c if (info .ne. 0) go to ... +c do 10 j = 1, p +c call dspsl(ap,n,kpvt,c(1,j)) +c 10 continue +c +c linpack. this version dated 08/14/78 . +c james bunch, univ. calif. san diego, argonne nat. lab. +c +c subroutines and functions +c +c blas daxpysym,ddotsym +c fortran iabs +c +c internal variables. +c + double precision ak,akm1,bk,bkm1,ddotsym,denom,temp + integer ik,ikm1,ikp1,k,kk,km1k,km1km1,kp +c +c loop backward applying the transformations and +c d inverse to b. +c + k = n + ik = (n*(n - 1))/2 + 10 if (k .eq. 0) go to 80 + kk = ik + k + if (kpvt(k) .lt. 0) go to 40 +c +c 1 x 1 pivot block. +c + if (k .eq. 1) go to 30 + kp = kpvt(k) + if (kp .eq. k) go to 20 +c +c interchange. +c + temp = b(k) + b(k) = b(kp) + b(kp) = temp + 20 continue +c +c apply the transformation. +c + call daxpysym(k-1,b(k),ap(ik+1),1,b(1),1) + 30 continue +c +c apply d inverse. +c + b(k) = b(k)/ap(kk) + k = k - 1 + ik = ik - k + go to 70 + 40 continue +c +c 2 x 2 pivot block. +c + ikm1 = ik - (k - 1) + if (k .eq. 2) go to 60 + kp = iabs(kpvt(k)) + if (kp .eq. k - 1) go to 50 +c +c interchange. +c + temp = b(k-1) + b(k-1) = b(kp) + b(kp) = temp + 50 continue +c +c apply the transformation. +c + call daxpysym(k-2,b(k),ap(ik+1),1,b(1),1) + call daxpysym(k-2,b(k-1),ap(ikm1+1),1,b(1),1) + 60 continue +c +c apply d inverse. +c + km1k = ik + k - 1 + kk = ik + k + ak = ap(kk)/ap(km1k) + km1km1 = ikm1 + k - 1 + akm1 = ap(km1km1)/ap(km1k) + bk = b(k)/ap(km1k) + bkm1 = b(k-1)/ap(km1k) + denom = ak*akm1 - 1.0d0 + b(k) = (akm1*bk - bkm1)/denom + b(k-1) = (ak*bkm1 - bk)/denom + k = k - 2 + ik = ik - (k + 1) - k + 70 continue + go to 10 + 80 continue +c +c loop forward applying the transformations. +c + k = 1 + ik = 0 + 90 if (k .gt. n) go to 160 + if (kpvt(k) .lt. 0) go to 120 +c +c 1 x 1 pivot block. +c + if (k .eq. 1) go to 110 +c +c apply the transformation. +c + b(k) = b(k) + ddotsym(k-1,ap(ik+1),1,b(1),1) + kp = kpvt(k) + if (kp .eq. k) go to 100 +c +c interchange. +c + temp = b(k) + b(k) = b(kp) + b(kp) = temp + 100 continue + 110 continue + ik = ik + k + k = k + 1 + go to 150 + 120 continue +c +c 2 x 2 pivot block. +c + if (k .eq. 1) go to 140 +c +c apply the transformation. +c + b(k) = b(k) + ddotsym(k-1,ap(ik+1),1,b(1),1) + ikp1 = ik + k + b(k+1) = b(k+1) + ddotsym(k-1,ap(ikp1+1),1,b(1),1) + kp = iabs(kpvt(k)) + if (kp .eq. k) go to 130 +c +c interchange. +c + temp = b(k) + b(k) = b(kp) + b(kp) = temp + 130 continue + 140 continue + ik = ik + k + k + 1 + k = k + 2 + 150 continue + go to 90 + 160 continue + return + end \ No newline at end of file diff --git a/dataassim/math/algebra/testdata.txt b/dataassim/math/algebra/testdata.txt new file mode 100644 index 0000000..e023e77 --- /dev/null +++ b/dataassim/math/algebra/testdata.txt @@ -0,0 +1,111 @@ +-0.21875 0.2 +-0.205 0.44263776 +-0.19555556 0.10590558 +-0.18666667 0.36658142 +-0.1765 0.06329114 +-0.176 0.12291351 +-0.17368421 0.22368421 +-0.17142857 0.36669213 +-0.16789474 0.09287926 +-0.1675 0.12742718 +-0.1573913 0.08733624 +-0.15692308 0.11617673 +-0.15 0.22163511 +-0.149 -0.09330629 +-0.14875 0.234375 +-0.1475 0.23972603 +-0.14714286 0.34413766 +-0.14625 -0.0308642 +-0.14125 0.27777778 +-0.14 0.24025974 +-0.13863636 0.08765339 +-0.1375 0.29329609 +-0.1355 0.27157895 +-0.1337037 0.05646903 +-0.13291667 0.01709402 +-0.13090909 -0.08833272 +-0.13074074 0.00829962 +-0.13 0.31606027 +-0.13 0.15448604 +-0.13 0.10471204 +-0.12888889 0.11695906 +-0.12555556 0.14814815 +-0.12545455 0.01196172 +-0.12518519 0.05713427 +-0.12444444 0.20643594 +-0.12392857 0.08314967 +-0.12344828 0.07705644 +-0.121 0.10019268 +-0.11652174 0.23768116 +-0.11375 0.10877581 +-0.1115625 0.08479021 +-0.10757576 0.05117845 +-0.10733333 0.2659176 +-0.10647059 0.09332991 +-0.105 0.0976423 +-0.10441176 0.07311399 +-0.10294118 0.04956306 +-0.10285714 0.07193372 +-0.10269231 0.25865701 +-0.10269231 0.24972856 +-0.09722222 0.12745539 +-0.095 -0.00529661 +-0.09466667 0.09460738 +-0.09210526 0.14687882 +-0.08705882 -0.05602241 +-0.08541667 -0.03205128 +-0.0821875 0.21426616 +-0.08105263 0.00903546 +-0.07888889 0.06196581 +-0.07888889 -0.03878622 +-0.075 0.17806268 +-0.07315789 -0.02300236 +-0.07166667 0.19302153 +-0.07 0.33347404 +-0.06736842 0.16951037 +-0.06333333 0.20434227 +-0.06219512 0.16561277 +-0.06219512 0.17213638 +-0.06071429 0.16789396 +-0.05906977 0.15890265 +-0.0575 0.16435011 +-0.05678571 0.17027201 +-0.05208333 0.1582618 +-0.05194444 0.19674797 +-0.05166667 0.01883239 +-0.05148148 0.2589273 +-0.0498 0.15882353 +-0.04891892 0.1733227 +-0.04833333 0.15214385 +-0.04647059 0.17944798 +-0.0462 0.14204426 +-0.04588235 0.05317065 +-0.0440625 0.23542945 +-0.04358491 0.16895538 +-0.04339623 0.13951771 +-0.04285714 -0.08354219 +-0.04243243 0.17635673 +-0.04203704 0.14302166 +-0.04132075 0.16332383 +-0.0412963 0.15429157 +-0.04109091 0.14965035 +-0.04051282 0.10450334 +-0.03738095 0.13354616 +-0.03488372 0.17941003 +-0.0347619 0.16658253 +-0.0344186 0.19873627 +-0.03352941 0.11351909 +-0.03333333 0.00316106 +-0.03275 0.16699411 +-0.031 -0.03697479 +-0.03090909 0.14141414 +-0.03 0 +-0.029375 0.12665198 +-0.02823529 0.14436343 +-0.02571429 0.26308866 +-0.025 0.14719848 +-0.02428571 0.1073493 +-0.02384615 0.00624122 +-0.02333333 0.10115891 +-0.02136364 0.14080196 +-0.02076923 0.19122664 diff --git a/dataassim/math/maxlikelihood/colikelihood.h b/dataassim/math/maxlikelihood/colikelihood.h new file mode 100644 index 0000000..f5ebf4c --- /dev/null +++ b/dataassim/math/maxlikelihood/colikelihood.h @@ -0,0 +1,54 @@ +!----------- Variables in likelihood common blocks ----------- +! +!nlikepoints: the number of sampling points for determining the parameters +! in the likelihood function +!ndesignparam: the number of design parameters +!xsamplike(nlikepoints,ndesignparam): the coordinates of the sampling points +! of the design parameters +!ysamplike(nlikepoints): the actual values at the sampling points +!delvector: = R^(-1)(y-Fb) +!coeffbas: on exit, holds the coefficients of the basis functions +!work: on exit, holds the upper triangle of the matrix R^(-1)F[F^tR^(-1)F)^(-1)F^(t)R^(-1)-R^(-1) +!fbassamp: on exit, holds the transpose of [F^(t)R^(-1)F]^(-1)F^(t)R^(-1) +!FtRinvF_inv: holds the upper triangle of the symmetric matrix [F^(t)R^(-1)F]^(-1) +!plikemin: likelihood parameter lower bounds +!plikemax: likelihood parameter upper bounds +!isitlastcall: if it is the last call, calculates the matrices needed by the prediction +!maxnvars: the maximum number of cokriging variables +!nvars: the actual number of cokriging variables +!kbasis: the total number of basis functions for all variables +!kbasvar: the number of basis functions in each variable +!maxkbasvar: the maximum number of basis functions iin each variable +!indexvars: the integer vector that holds the number of observations for each +! cokriging variables. +!ithetap: =1, pist=2.0; =2, pdist to be optimized +!kpvt: an integer array used in different subroutines, defined in common blocks +! to save memory, does not transfer data through common blocks. + + integer maxdesignparam,maxlikepoints,maxkbasvar,maxnvars + parameter(maxdesignparam=40,maxlikepoints=365*48, + & maxkbasvar=100,maxnvars=10) + + integer nlikepoints,ndesignparam,kbasis,kbasvar, + & nvars,indexvars,ithetap,kpvt + common /likedim/nlikepoints,ndesignparam,kbasis, + & kbasvar(maxnvars),nvars,indexvars(maxnvars), + & ithetap,kpvt(maxlikepoints) + + double precision xsamplike,ysamplike,coeffbas,delvector, + & work,fbassamp,FtRinvF_inv + common /likevar/xsamplike(maxlikepoints,maxdesignparam), + & ysamplike(maxlikepoints),delvector(maxlikepoints), + & coeffbas(maxkbasvar*maxnvars), + & work(maxlikepoints*(maxlikepoints+1)/2), + & fbassamp(maxlikepoints,maxkbasvar*maxnvars), + & FtRinvF_inv(maxkbasvar*maxnvars*(maxkbasvar*maxnvars+1)/2) + + double precision plikemin,plikemax + common /likebounds/plikemin(maxnvars*(maxnvars+1)* + & (2*maxdesignparam+1)/2), + & plikemax(maxnvars*(maxnvars+1)* + & (2*maxdesignparam+1)/2) + logical isitlastcall + common /likelogic/isitlastcall +!---------------------------------------------------------- diff --git a/dataassim/math/maxlikelihood/mumle.f b/dataassim/math/maxlikelihood/mumle.f new file mode 100644 index 0000000..36da654 --- /dev/null +++ b/dataassim/math/maxlikelihood/mumle.f @@ -0,0 +1,977 @@ +! Multivariate Universal Maximum Likelihood Estimation (MUMLE) +! Developed by +! Lianhong Gu +! Environmental Sciences Division +! Oak Ridge National Lab +! lianhong-gu@ornl.gov +! +! Version 1.0, July, 2006 + + subroutine coapproxyfunc(nkrigpoints,nxdim,xsampkrig, + & ysampkrig,nvarscp,indexvarscp,iupdatelikelihood, + & iwhattodo,ithetap0,ixnewpos,xnew, + & ypred,grad_xnew,rootmeanerror) + implicit none + include '../maxlikelihood/colikelihood.h' + +!!!!!!!!!!!!!!!!!!!! Arguments !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!-------------------Inputs-------------------------------------- +!nkrigpoints: the number of available points for kriging. +!nxdim: the dimension in the design parameter vector x +!xsampkrig: the coordinates of the sampled points for kriging. Note that these +! points may or may not be the same as those points used for estimating +! the parameters in the likelihood function +! +! **************************************************************************** +! *Note different variables are stacked in the vector (xsampkrig,ysampkrig) * +! *in an orderly fashion. The number of different variables is given by * +! *nvarscp. The number of points in each variable is indicated by indexvarscp* +! **************************************************************************** +! +!ysampkrig: the value at xsampkrig +!nvarscp: the number of variables for cokriging +!indexvarscp: the number of samples in each variable for cokriging +!iupdatelikelihood: whether to update the likelihood function +! =0: the first entering, so initilize the parameters to be optimized +! and do likelihood function optimization +! =1: update the likelihood parameters using the saved values from +! the last optimization as the initial guesses +! =2: do not do likelihood optimization +!iwhattodo: =1, only make a predition at xnew +! =2, make a prediction and calculate the derivative at xnew +! =3, only calculate the derivative at xnew +!ithetap0: =ithetap: =1 set pdist to 2.0, =2: pdist to be optimized +!ixnewpos: which variable does xnew belong to. +!xnew: the coordinates of the point to be kriged +! +!---------------------- Outputs -------------------------------- +!ypred: the predicted value at xnew +!rootmeanerror: the root mean square error of ypred +!grad_xnew: the derivative at xnew + + integer nkrigpoints,nxdim,iupdatelikelihood,iwhattodo, + & nvarscp,indexvarscp(nvarscp),ithetap0,ixnewpos + double precision xsampkrig(nkrigpoints,nxdim), + & ysampkrig(nkrigpoints),xnew(nxdim),ypred, + & rootmeanerror,grad_xnew(nxdim) +! +!!!!!!!!!!!!!!!!!!! Local variables !!!!!!!!!!!!!!!!!!!!!!!!! +! + double precision ftol + parameter(ftol=1.0d-8) + external df1dimd_like,gradlikefunc, + & likelihoodfunc,f1dim_like,colikelihoodgrad + integer i,j,nplike,info,nii,index,irowinc,istart, + & icompactpostri,icompactposoff + integer nbd(maxnvars*(maxnvars+1)* + & (2*maxdesignparam+1)/2) + double precision plike(maxnvars*(maxnvars+1)* + & (2*maxdesignparam+1)/2), + & x(nxdim),flikemin,xsamp(nxdim), + & theta((maxnvars*(maxnvars+1))/2,maxdesignparam), + & pdist((maxnvars*(maxnvars+1))/2,maxdesignparam), + & theta1(nxdim),pdist1(nxdim), + & covars(maxnvars),correls(maxnvars*(maxnvars-1)/2), + & rx(nkrigpoints),fb(maxkbasvar),corr_like, + & xmean(maxdesignparam), + & gradient(maxkbasvar,nxdim) + + double precision gradlike(maxnvars*(maxnvars+1)* + & (2*maxdesignparam+1)/2) + save nplike + save plike,theta,pdist,xmean,covars,correls + + if(iupdatelikelihood.le.1)then +! update parameters and correlation functions in the likelihood function +! +! nbd is an INTEGER array of dimension n that must be set by the +! user to the type of bounds imposed on the variables: +! nbd(i)=0 if x(i) is unbounded, +! 1 if x(i) has only a lower bound, +! 2 if x(i) has both lower and upper bounds, +! 3 if x(i) has only an upper bound. + + nlikepoints=nkrigpoints + nvars=nvarscp + ithetap=ithetap0 + do i=1,nvars + indexvars(i)=indexvarscp(i) + enddo + ndesignparam=nxdim + do i=1,nlikepoints + ysamplike(i)=ysampkrig(i) + enddo + +! Centralize the coordinates to stablize the linear system + do j=1,nxdim + xmean(j)=0.0d0 + do i=1,nlikepoints + xmean(j)=xmean(j)+xsampkrig(i,j) + enddo + xmean(j)=xmean(j)/dble(nlikepoints) + do i=1,nlikepoints + xsamplike(i,j)=xsampkrig(i,j)-xmean(j) + enddo + enddo + + call setinit_bounds(nvars,ndesignparam,ithetap, + & iupdatelikelihood,plikemin,plike,plikemax,nbd,nplike) + + isitlastcall=.false. + +! to use Lbfgsb_2_4, no need to call the cost function first + call Lbfgsb_2_4(nplike,plike,flikemin,plikemin,plikemax, + & nbd,colikelihoodgrad,ftol,info) + +! to use frprmn, the cost function needs to be called first +! call likelihoodfunc(nplike,plike,flikemin) +! call frprmn(plike,nplike,ftol,flikemin,plikemin, +! & plikemax,gradlikefunc,f1dim_like,df1dimd_like) + +! call dfpmin(plike,nplike,ftol,flikemin,likelihoodfunc, +! & plikemin,plikemax,gradlikefunc,f1dim_like,df1dimd_like) + + write(*,*)flikemin,plike(1),plike(2),plike(3),info + call gradlikefunc(nplike,plike,flikemin,gradlike) + write(*,*)gradlike(1),gradlike(2),gradlike(3) + + call nongradopt(nplike,likelihoodfunc,f1dim_like,plike, + & plikemin,plikemax,ftol,flikemin) + + write(*,*)flikemin,plike(1),plike(2),plike(3) + call gradlikefunc(nplike,plike,flikemin,gradlike) + write(*,*)gradlike(1),gradlike(2),gradlike(3) + + isitlastcall=.true. + call likelihoodfunc(nplike,plike,flikemin) + call colikeliparampart(nplike,plike,ithetap, + & ndesignparam,nvars, + & theta(1:(nvars*(nvars+1))/2,1:ndesignparam), + & pdist(1:(nvars*(nvars+1))/2,1:ndesignparam), + & covars,correls) + + endif +! + do j=1,ndesignparam + x(j)=xnew(j)-xmean(j) + enddo + istart=0 + do i=1,ixnewpos-1 + istart=istart+kbasvar(i) + enddo +! + if(iwhattodo.eq.1.or.iwhattodo.eq.2)then +! make a prediction at x + call cofuncbasis(ixnewpos,index,ndesignparam, + & x,fb) + irowinc=0 + do i=1,nvars + index=icompactpostri(ixnewpos,i) + do j=1,ndesignparam + theta1(j)=theta(index,j) + pdist1(j)=pdist(index,j) + enddo + if(ixnewpos.ne.i)then + index=icompactposoff(ixnewpos,i) + endif + do nii=1,indexvars(i) + irowinc=irowinc+1 + do j=1,ndesignparam + xsamp(j)=xsamplike(irowinc,j) + enddo + if(ixnewpos.eq.i)then + rx(irowinc)=covars(i)*corr_like(x,xsamp, + & theta1,pdist1,ndesignparam) + else + rx(irowinc)=dsqrt(covars(i)*covars(ixnewpos))* + & correls(index)*corr_like(x,xsamp, + & theta1,pdist1,ndesignparam) + endif + enddo + enddo + + ypred=0.0d0 + do i=1,kbasvar(ixnewpos) + ypred=ypred+fb(i)*coeffbas(i+istart) + enddo + do i=1,nlikepoints + ypred=ypred+delvector(i)*rx(i) + enddo + + rootmeanerror=covars(ixnewpos) + do i=1,kbasis + call symmatindex(kbasis,i,kpvt) + flikemin=0.0d0 + do j=1,kbasis + if(j.gt.istart.and.j.le.(istart+kbasvar(ixnewpos)))then + flikemin=flikemin+FtRinvF_inv(kpvt(j))*fb(j-istart) + endif + enddo + if(i.gt.istart.and.i.le.(istart+kbasvar(ixnewpos)))then + rootmeanerror=rootmeanerror+fb(i-istart)*flikemin + endif + enddo + + do i=1,kbasis + flikemin=0.0d0 + do j=1,nlikepoints + flikemin=flikemin+fbassamp(j,i)*rx(j) + enddo + if(i.gt.istart.and.i.le.(istart+kbasvar(ixnewpos)))then + rootmeanerror=rootmeanerror-2.0d0*fb(i)*flikemin + endif + enddo + + do i=1,nlikepoints + call symmatindex(nlikepoints,i,kpvt) + flikemin=0.0d0 + do j=1,nlikepoints + flikemin=flikemin+work(kpvt(j))*rx(j) + enddo + rootmeanerror=rootmeanerror+rx(i)*flikemin + enddo + if(rootmeanerror.lt.0.0d0)then +! computational error + rootmeanerror=0.0d0 + endif + rootmeanerror=dsqrt(rootmeanerror) + endif +! + if(iwhattodo.eq.2.or.iwhattodo.eq.3)then +! calculate the derivative of the approximated function with respect to x + call cogradbasx(ixnewpos,kbasvar(ixnewpos),ndesignparam, + & x,gradient(1:kbasvar(ixnewpos),1:ndesignparam)) + do i=1,ndesignparam + grad_xnew(i)=0.0d0 + do j=1,kbasvar(ixnewpos) + grad_xnew(i)=grad_xnew(i)+gradient(j,i)*coeffbas(j+istart) + enddo + enddo + + irowinc=0 + do i=1,nvars + if(i.eq.ixnewpos)then + flikemin=covars(ixnewpos) + else + index=icompactposoff(i,ixnewpos) + flikemin=dsqrt(covars(i)*covars(ixnewpos))* + & correls(index) + endif + index=icompactpostri(i,ixnewpos) + do j=1,ndesignparam + theta1(j)=theta(index,j) + pdist1(j)=pdist(index,j) + enddo + do j=1,indexvars(i) + irowinc=irowinc+1 + do index=1,ndesignparam + xsamp(index)=xsamplike(irowinc,index) + enddo + call gradcorratx(x,xsamp,ndesignparam,theta1, + & pdist1,rx) + do index=1,ndesignparam + grad_xnew(index)=grad_xnew(index)+flikemin* + & rx(index)*delvector(irowinc) + enddo + enddo + enddo + endif + return + end + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine colikelihoodgrad(nplike,plike,dogradient, + & fvalue,gradlike,ierr) + implicit none + include '../maxlikelihood/colikelihood.h' +! +! calculate the transformed likelihood function value and derivatives +! with respect to input parameters if specified +! +!----------- Arguments ------------------------------------ + integer nplike,ierr + logical dogradient + double precision plike(nplike),fvalue,gradlike(nplike) +! +!=> nplike: the number of likelihood parameters to be estimated +!=> plike: the likelihood parameters to be estimated +!=> dogradient: whether to do derivative calculations +!<= fvalue: the transformed likelihood function value +!<= gradlike: derivatives at plike +!<= ierr: error messages +! =0: every thing ok +! <0: parameter out of bounds. |ierr| denotes the out-of-bound parameter +! =11: the correlation matrix is not postitive definite (the determinant is negative) + +!----------- End of list of arguments --------------------- +!------------- Local variables ---------------------------- + integer i,j,n,t,inert(3),index,nii, + & irowinc,getwhichvar,ivar,jvar,icount,k, + & icompactposoff,icompactpostri,iloop,istart,jstart + double precision lnabsdet,signunit,delta,corr_like, + & covars(nvars),theta(nvars*(nvars+1)/2,ndesignparam), + & pdist(nvars*(nvars+1)/2,ndesignparam), + & correls(nvars*(nvars-1)/2),xi(ndesignparam), + & xj(ndesignparam),theta1(ndesignparam), + & pdist1(ndesignparam),derR(nlikepoints*(nlikepoints+1)/2), + & sumi,sumt,gradtheta(ndesignparam),gradp(ndesignparam) + + do i=1,nplike + if(plike(i).lt.plikemin(i).or. + & plike(i).gt.plikemax(i))then +! penalize out-of-bounds parameters + fvalue=1.0d+100 + ierr=-i + return + endif + enddo + + call colikeliparampart(nplike,plike,ithetap, + & ndesignparam,nvars, + & theta(1:(nvars*(nvars+1))/2,1:ndesignparam), + & pdist(1:(nvars*(nvars+1))/2,1:ndesignparam), + & covars,correls) + + t=0 + do j=1,nlikepoints + jvar=getwhichvar(j,nvars,indexvars) + do n=1,ndesignparam + xi(n)=xsamplike(j,n) + enddo + do i=1,j + t=t+1 + if(i.eq.j)then + work(t)=covars(jvar) + else + ivar=getwhichvar(i,nvars,indexvars) + k=icompactpostri(ivar,jvar) + do n=1,ndesignparam + xj(n)=xsamplike(i,n) + theta1(n)=theta(k,n) + pdist1(n)=pdist(k,n) + enddo + if(ivar.eq.jvar)then + work(t)=covars(jvar)*corr_like(xj,xi, + & theta1,pdist1,ndesignparam) + else + k=icompactposoff(ivar,jvar) + work(t)=dsqrt(covars(jvar)*covars(ivar))* + & correls(k)*corr_like(xj,xi, + & theta1,pdist1,ndesignparam) + endif + endif + enddo + enddo + + call dspfa(work,nlikepoints,kpvt,i) + j=11 + call dspdi(work,nlikepoints,kpvt,derR,inert,delvector,j) +! work now stores the upper triangle of the inverse covariance matrix +! determinant=derR(1)*10.0d0**derR(2) + signunit=dsign(1.0d0,derR(1)) + lnabsdet=dlog(dabs(derR(1)))+derR(2)*dlog(10.0d0) + + if(signunit.lt.0.0d0)then +! write(*,*)'Wrong! the covariance matrix has a negative' +! write(*,*)'determinant. Program stops in likelihoodfunc' + write(*,*)signunit,lnabsdet + ierr=11 + return + endif + + t=0 + kbasis=0 + do i=1,nvars + do j=1,indexvars(i) + t=t+1 + do n=1,ndesignparam + xi(n)=xsamplike(t,n) + enddo + call cofuncbasis(i,kbasvar(i),ndesignparam, + & xi,delvector) + do n=1,kbasvar(i) + fbassamp(t,kbasis+n)=delvector(n) + enddo + enddo + if(i.gt.1)then + do j=t-indexvars(i)+1,t + do n=1,kbasis + fbassamp(j,n)=0.0d0 + enddo + enddo + do j=1,t + do n=kbasis+1,kbasis+kbasvar(i) + fbassamp(j,n)=0.0d0 + enddo + enddo + endif + kbasis=kbasis+kbasvar(i) + enddo + call solvebassystem(delta) + + fvalue=delta+lnabsdet +! +! The actual likelihood function =exp(-(fvalue+nlikepoints*ln(2*pi))/2) + + if(dogradient.eqv..false..or.dogradient.eqv..FALSE.)then + ierr=0 + return + endif + if(isitlastcall.eqv..true..or.isitlastcall.eqv..TRUE.)then + ierr=0 + return + endif +! +! section for derivatives starts +! +! delvector=R^(-1)(Y-FB) was computed in solvebassystem and will not be altered from now +!----Section for calculating derivatives with respect to theta and pdist------- + icount=0 + do iloop=1,ithetap + do k=1,nvars*(nvars+1)/2 + call ivarjvartri(k,nvars,indexvars, + & ivar,jvar,istart,jstart) + if(ivar.ne.jvar)then + nii=icompactposoff(ivar,jvar) + endif + do n=1,ndesignparam + theta1(n)=theta(k,n) + pdist1(n)=pdist(k,n) + enddo + ierr=0 + do j=1,nlikepoints + do i=1,j + ierr=ierr+1 + derR(ierr)=0.0d0 + enddo + enddo + do t=1,ndesignparam + icount=icount+1 + do j=jstart,jstart+indexvars(jvar)-1 + do n=1,ndesignparam + xj(n)=xsamplike(j,n) + enddo + if(ivar.eq.jvar)then + kpvt(1)=j-1 + else + kpvt(1)=istart+indexvars(ivar)-1 + endif + do i=istart,kpvt(1) + do n=1,ndesignparam + xi(n)=xsamplike(i,n) + enddo + ierr=icompactpostri(i,j) + if(ivar.eq.jvar)then + if(iloop.eq.1)then + call gradcorr_liketheta(xi,xj, + & theta1,pdist1,ndesignparam,gradtheta) + derR(ierr)=covars(ivar)*gradtheta(t) + else + call gradcorr_likep(xi,xj, + & theta1,pdist1,ndesignparam,gradp) + derR(ierr)=covars(ivar)*gradp(t) + endif + else + if(iloop.eq.1)then + call gradcorr_liketheta(xi,xj, + & theta1,pdist1,ndesignparam,gradtheta) + derR(ierr)=dsqrt(covars(ivar)*covars(jvar))* + & correls(nii)*gradtheta(t) + else + call gradcorr_likep(xi,xj, + & theta1,pdist1,ndesignparam,gradp) + derR(ierr)=dsqrt(covars(ivar)*covars(jvar))* + & correls(nii)*gradp(t) + endif + endif + enddo + enddo + gradlike(icount)=0.0d0 + do i=1,nlikepoints + call symmatindex(nlikepoints,i,kpvt) + sumi=0.0d0 + do j=1,nlikepoints + sumi=sumi+derR(kpvt(j))*delvector(j) + enddo + gradlike(icount)= + & gradlike(icount)+delvector(i)*sumi + enddo + gradlike(icount)=-gradlike(icount) +! +!Now, the trace part + sumi=0.0d0 + do i=1,nlikepoints + call symmatindex(nlikepoints,i,kpvt) + sumt=0.0d0 + do j=1,nlikepoints + sumt=sumt+work(kpvt(j))*derR(kpvt(j)) + enddo + sumi=sumi+sumt + enddo +! sumi is the trace + gradlike(icount)=gradlike(icount)+sumi + enddo + enddo + enddo +!------------------------------------------------------------------- +! ------- Section for calculating derivatives with respect to variance + do k=1,nvars + icount=icount+1 + ierr=0 + do j=1,nlikepoints + do i=1,j + ierr=ierr+1 + derR(ierr)=0.0d0 + enddo + enddo +! first, vertical elements + do i=1,k-1 + ierr=icompactpostri(i,k) + do t=1,ndesignparam + theta1(t)=theta(ierr,t) + pdist1(t)=pdist(ierr,t) + enddo + ierr=icompactposoff(i,k) + call istartjstart(i,k,nvars,indexvars,istart,jstart) + do n=istart,istart+indexvars(i)-1 + do t=1,ndesignparam + xi(t)=xsamplike(n,t) + enddo + do j=jstart,jstart+indexvars(k)-1 + do t=1,ndesignparam + xj(t)=xsamplike(j,t) + enddo + ivar=icompactpostri(n,j) + derR(ivar)=0.5d0*dsqrt(covars(i)/covars(k))* + & correls(ierr)*corr_like(xi,xj, + & theta1,pdist1,ndesignparam) + enddo + enddo + enddo + ierr=icompactpostri(k,k) + do t=1,ndesignparam + theta1(t)=theta(ierr,t) + pdist1(t)=pdist(ierr,t) + enddo + call istartjstart(k,k,nvars,indexvars,istart,jstart) + do j=jstart,jstart+indexvars(k)-1 + do t=1,ndesignparam + xi(t)=xsamplike(j,t) + enddo + do n=istart,j + ivar=icompactpostri(n,j) + if(n.eq.j)then + derR(ivar)=1.0d0 + else + do t=1,ndesignparam + xj(t)=xsamplike(n,t) + enddo + derR(ivar)=corr_like(xi,xj, + & theta1,pdist1,ndesignparam) + endif + enddo + enddo +! then, horizontal elements + do i=k+1,nvars + ierr=icompactpostri(k,i) + do t=1,ndesignparam + theta1(t)=theta(ierr,t) + pdist1(t)=pdist(ierr,t) + enddo + ierr=icompactposoff(k,i) + call istartjstart(k,i,nvars,indexvars,istart,jstart) + do n=istart,istart+indexvars(i)-1 + do t=1,ndesignparam + xi(t)=xsamplike(n,t) + enddo + do j=jstart,jstart+indexvars(k)-1 + do t=1,ndesignparam + xj(t)=xsamplike(j,t) + enddo + ivar=icompactpostri(n,j) + derR(ivar)=0.5d0*dsqrt(covars(i)/covars(k))* + & correls(ierr)*corr_like(xi,xj, + & theta1,pdist1,ndesignparam) + enddo + enddo + enddo + + gradlike(icount)=0.0d0 + do i=1,nlikepoints + call symmatindex(nlikepoints,i,kpvt) + sumi=0.0d0 + do j=1,nlikepoints + sumi=sumi+derR(kpvt(j))*delvector(j) + enddo + gradlike(icount)= + & gradlike(icount)+delvector(i)*sumi + enddo + gradlike(icount)=-gradlike(icount) +! +!Now, the trace part + sumi=0.0d0 + do i=1,nlikepoints + call symmatindex(nlikepoints,i,kpvt) + sumt=0.0d0 + do j=1,nlikepoints + sumt=sumt+work(kpvt(j))*derR(kpvt(j)) + enddo + sumi=sumi+sumt + enddo + +! sumi is the trace + gradlike(icount)=gradlike(icount)+sumi + enddo +!-------------------------------------------------------------------- +! ------- Section for calculating derivatives with respect to correls + do k=1,nvars*(nvars-1)/2 + icount=icount+1 + ierr=0 + do j=1,nlikepoints + do i=1,j + ierr=ierr+1 + derR(ierr)=0.0d0 + enddo + enddo + call ivarjvaroff(k,nvars,indexvars, + & ivar,jvar,istart,jstart) + ierr=icompactpostri(ivar,jvar) + do t=1,ndesignparam + theta1(t)=theta(ierr,t) + pdist1(t)=pdist(ierr,t) + enddo + do i=istart,istart+indexvars(ivar)-1 + do t=1,ndesignparam + xi(t)=xsamplike(i,t) + enddo + do j=jstart,jstart+indexvars(jvar)-1 + do t=1,ndesignparam + xj(t)=xsamplike(j,t) + enddo + ierr=icompactpostri(i,j) + derR(ierr)=dsqrt(covars(ivar)*covars(jvar))* + & corr_like(xi,xj,theta1,pdist1,ndesignparam) + enddo + enddo + + gradlike(icount)=0.0d0 + do i=1,nlikepoints + call symmatindex(nlikepoints,i,kpvt) + sumi=0.0d0 + do j=1,nlikepoints + sumi=sumi+derR(kpvt(j))*delvector(j) + enddo + gradlike(icount)= + & gradlike(icount)+delvector(i)*sumi + enddo + gradlike(icount)=-gradlike(icount) + +!Now, the trace part + sumi=0.0d0 + do i=1,nlikepoints + call symmatindex(nlikepoints,i,kpvt) + sumt=0.0d0 + do j=1,nlikepoints + sumt=sumt+work(kpvt(j))*derR(kpvt(j)) + enddo + sumi=sumi+sumt + enddo +! sumi is the trace + gradlike(icount)=gradlike(icount)+sumi + enddo +!-------------------------------------------------------------- + ierr=0 + return + end + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine solvebassystem(delta) + implicit none + include '../maxlikelihood/colikelihood.h' +! +! Calculating the best linear estimates of the coefficients of the basis functions, +! delta (the residual square error), and matrices needed for prediction and estimation +! of prediction error + + integer kcopy(kbasis),inert(3) + double precision FR(kbasis,nlikepoints), + & a(kbasis*(kbasis+1)/2),rhs(kbasis),sum, + & acopy(max0(kbasis*(kbasis+1)/2,nlikepoints)), + & amat(kbasis*(kbasis+1)/2), + & rhscopy(kbasis),delta + + integer n,j,t,i,mark,irowinc,index,nii + + do i=1,nlikepoints + call symmatindex(nlikepoints,i,kpvt) + do j=1,kbasis + FR(j,i)=0.0d0 + do t=1,nlikepoints + FR(j,i)=FR(j,i)+work(kpvt(t))*fbassamp(t,j) + enddo + enddo + enddo + + do i=1,kbasis +! right hand side of the linear system + rhs(i)=0.0d0 + do j=1,nlikepoints + rhs(i)=rhs(i)+FR(i,j)*ysamplike(j) + enddo +! make a copy + rhscopy(i)=rhs(i) + enddo + +! coefficient matrix, symmetric + t=0 + do j=1,kbasis + do i=1,j + t=t+1 + a(t)=0.0d0 + do n=1,nlikepoints + a(t)=a(t)+FR(i,n)*fbassamp(n,j) + enddo +! make a copy + amat(t)=a(t) + enddo + enddo + +! solve the basis function linear system + call dspfa(a,kbasis,kpvt,mark) + do i=1,kbasis*(kbasis+1)/2 + acopy(i)=a(i) + enddo + do i=1,kbasis + kcopy(i)=kpvt(i) + enddo + if(isitlastcall.eqv..true..or.isitlastcall.eqv..TRUE.)then +! calculate the inverse only + do j=1,kbasis*(kbasis+1)/2 + FtRinvF_inv(j)=a(j) + enddo + j=1 + call dspdi(FtRinvF_inv,kbasis,kpvt,coeffbas, + & inert,delvector,j) + do i=1,kbasis + kpvt(i)=kcopy(i) + enddo + endif + call dspsl(a,kbasis,kpvt,rhs) + do i=1,kbasis + coeffbas(i)=rhs(i) + enddo + +! one step improvement + do i=1,kbasis + call symmatindex(kbasis,i,kpvt) + sum=0.0d0 + do t=1,kbasis + sum=sum+amat(kpvt(t))*coeffbas(t) + enddo + rhs(i)=(sum-rhscopy(i))*1.0d+9 + enddo + call dspsl(acopy,kbasis,kcopy,rhs) + do i=1,kbasis + coeffbas(i)=coeffbas(i)-rhs(i)*1.0d-9 + enddo + + do i=1,nlikepoints + acopy(i)=0.0d0 + do j=1,kbasis + acopy(i)=acopy(i)+coeffbas(j)*fbassamp(i,j) + enddo + acopy(i)=ysamplike(i)-acopy(i) + enddo + + do t=1,nlikepoints + call symmatindex(nlikepoints,t,kpvt) + delvector(t)=0.0d0 + do i=1,nlikepoints + delvector(t)=delvector(t)+work(kpvt(i))*acopy(i) + enddo + enddo + delta=0.0d0 + do t=1,nlikepoints + delta=delta+delvector(t)*acopy(t) + enddo + + if(isitlastcall.eqv..true..or.isitlastcall.eqv..TRUE.)then +! All parameters in the likelihood function have been optimized. Prepare +! matrices for MSE calculations + do i=1,kbasis + call symmatindex(kbasis,i,kpvt) + do j=1,nlikepoints + fbassamp(j,i)=0.0d0 + do t=1,kbasis + fbassamp(j,i)=fbassamp(j,i)+FtRinvF_inv(kpvt(t))* + & FR(t,j) + enddo + enddo + enddo + t=0 + do j=1,nlikepoints + do i=1,j + t=t+1 + work(t)=-work(t) + do n=1,kbasis + work(t)=work(t)+fbassamp(i,n)*FR(n,j) + enddo + enddo + enddo + endif + return + end +!###################################################### + + DOUBLE PRECISION FUNCTION df1dimd_like(x) + INTEGER NMAX + double precision x + PARAMETER (NMAX=50) +CU USES gradlikefunc + INTEGER j,ncom + double precision df(NMAX),pcom(NMAX),xicom(NMAX), + & xt(NMAX) ,dummy + COMMON /f1com/ pcom,xicom,ncom + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call gradlikefunc(ncom,xt,dummy,df) + df1dimd_like=0.0d0 + do 12 j=1,ncom + df1dimd_like=df1dimd_like+df(j)*xicom(j) +12 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + subroutine gradlikefunc(nplike,plike,fvalue,gradlike) + implicit none + integer nplike,ierr + double precision plike(nplike),fvalue,gradlike(nplike) + logical dogradient + + dogradient=.true. + call colikelihoodgrad(nplike,plike,dogradient, + & fvalue,gradlike,ierr) + return + end + + subroutine likelihoodfunc(nplike,plike,fvalue) + implicit none + integer nplike,ierr + double precision plike(nplike),fvalue,gradlike(nplike) + logical dogradient + + dogradient=.false. + call colikelihoodgrad(nplike,plike,dogradient, + & fvalue,gradlike,ierr) + return + end + + double precision function f1dim_like(x) + INTEGER NMAX + double precision x + PARAMETER (NMAX=50) +CU USES likelihood + INTEGER j,ncom + double precision pcom(NMAX),xicom(NMAX),xt(NMAX) + COMMON /f1com/ pcom,xicom,ncom + + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call likelihoodfunc(ncom,xt,f1dim_like) + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + +!################################################################# + subroutine gradfunkmin(ndim,x,fatx,fjac) + implicit none + + integer ndim,j + double precision x(ndim),fatx,fjac(ndim),h,eps, + & zero,temp,fxh + + call likelihoodfunc(ndim,x,fatx) + + eps = 1.0d-5 + zero=0.0d0 + + do j = 1, ndim + temp = x(j) + h = eps*dabs(temp) + if (h .eq. zero) h = eps + x(j) = temp + h + call likelihoodfunc(ndim,x,fxh) + x(j) = temp + fjac(j) = (fxh - fatx)/h + enddo + + return + end subroutine gradfunkmin + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine randpermut(npoints,ndim,x) + implicit none +! +! conduct random permutation + integer npoints,ndim,i,j,index + double precision x(npoints,ndim),xtemp(npoints), + & ran2 + + do i=1,ndim + do j=1,npoints + xtemp(j)=x(j,i) + enddo + do j=1,npoints + index=int(dble(npoints-j+1)*ran2()+1.0d0) + x(j,i)=xtemp(index) + xtemp(index)=xtemp(npoints-j+1) + enddo + enddo + return + end + +c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +c +c#################################################################### +c random number generator +c + double precision function ran2() + implicit none + integer im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv + double precision am,eps,rnmx + parameter(im1=2147483563,im2=2147483399,am=1.0d0/dble(im1), + &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1= + &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2d-7, + &rnmx=1.0d0-eps) + integer idum2,j,k,iv(ntab),iy,idum + save iv,iy,idum2,idum + data idum2/123456789/,iv/ntab*0/,iy/0/,idum/-1/ + + if(idum.le.0) then + idum=max0(-idum,1) + idum2=idum + do 11 j=ntab+8,1,-1 + k=idum/iq1 + idum=ia1*(idum-k*iq1)-k*ir1 + if(idum.lt.0) idum=idum+im1 + if(j.le.ntab) iv(j)=idum +11 continue + iy=iv(1) + end if + k=idum/iq1 + idum=ia1*(idum-k*iq1)-k*ir1 + if(idum.lt.0)idum=idum+im1 + k=idum2/iq2 + idum2=ia2*(idum2-k*iq2)-k*ir2 + if(idum2.lt.0) idum2=idum2+im2 + j=1+iy/ndiv + iy=iv(j)-idum2 + iv(j)=idum + if(iy.lt.1)iy=iy+imm1 + ran2=dmin1(am*dble(iy),rnmx) + return + end +!###################################################### diff --git a/dataassim/math/nonlinsystems/ApproxiNewton.f b/dataassim/math/nonlinsystems/ApproxiNewton.f new file mode 100644 index 0000000..bcb5f31 --- /dev/null +++ b/dataassim/math/nonlinsystems/ApproxiNewton.f @@ -0,0 +1,23 @@ + program testnewton + implicit none + integer i + double precision x,f0,f1,func,recider + x=-1.5d0 + do i=1,200 + f0=func(x) + write(*,*)i,x,f0 + pause + + f1=func(x+f0) + recider=f0/(f1-f0) + x=x-recider*f0 + enddo + + end + + double precision function func(x) + double precision x + func=x-(x*x+1.0d0)/2.0d0 +!x^2-2*x+1=0 + return + end diff --git a/dataassim/math/nonlinsystems/bookkeeping.f b/dataassim/math/nonlinsystems/bookkeeping.f new file mode 100644 index 0000000..45a8ef1 --- /dev/null +++ b/dataassim/math/nonlinsystems/bookkeeping.f @@ -0,0 +1,66 @@ + subroutine bookkeeping(nunknowns,xvar,fequ, + & icall,iflargest) + implicit none + include 'nslasystem.h' + integer nunknowns,icall,iflargest + double precision xvar(nunknowns),fequ(nunknowns) + integer iGuCall,i,j,k + parameter(iGuCall=49) +!-------------------------------------------------------------------------- + iflargest=1 + do j=2,nunknowns + if(dabs(fequ(j)).gt.dabs(fequ(iflargest))) + & iflargest=j + enddo + if(numeval.eq.maxeval)goto 100 + if(numeval.eq.0.or.icall.eq.iGuCall)then + numeval=numeval+1 + flargest(numeval)=dabs(fequ(iflargest)) + do i=1,nunknowns + xevaluated(numeval,i)=xvar(i) + fevaluated(numeval,i)=fequ(i) + enddo + return + endif +100 do i=1,numeval + k=0 + do j=1,nunknowns + if(dabs(xvar(j)-xevaluated(i,j)).gt. + & 1.0d-5*dabs(xvar(j)))k=1 + enddo + if(k.eq.0)goto 500 + enddo + if(numeval.lt.maxeval)then + numeval=numeval+1 + flargest(numeval)=dabs(fequ(iflargest)) + do i=1,nunknowns + xevaluated(numeval,i)=xvar(i) + fevaluated(numeval,i)=fequ(i) + enddo + return + endif +! replace a point + j=1 + do i=2,numeval + if(flargest(j).lt.flargest(i))then + j=i + endif + enddo + if(dabs(fequ(iflargest)).lt.flargest(j))then + flargest(j)=dabs(fequ(iflargest)) + do i=1,nunknowns + xevaluated(j,i)=xvar(i) + fevaluated(j,i)=fequ(i) + enddo + endif + return +! too close to the existing point i +500 if(dabs(fequ(iflargest)).lt.flargest(i))then + flargest(i)=dabs(fequ(iflargest)) + do j=1,nunknowns + xevaluated(i,j)=xvar(j) + fevaluated(i,j)=fequ(j) + enddo + endif + return + end diff --git a/dataassim/math/nonlinsystems/broydn.f b/dataassim/math/nonlinsystems/broydn.f new file mode 100644 index 0000000..907be91 --- /dev/null +++ b/dataassim/math/nonlinsystems/broydn.f @@ -0,0 +1,567 @@ +C This file contains all the subroutines needed by the nonlinear solver broydn +C code modified based on on-line version in Numerical Recipes Website, Dec 28, 2004 + + SUBROUTINE broydn(x0min,x,x0max,STPMX,n, + & fveccopy,funcv,TOLF,ierr) + implicit none + INTEGER n,NP,MAXITS,ierr + double precision x(n),EPS,TOLF,TOLMIN,TOLX,STPMX + double precision x0min(n),x0max(n),fveccopy(n) + LOGICAL check +! PARAMETER (NP=1000,MAXITS=250,EPS=1.0d-7,TOLF=1.0d-4, +! & TOLMIN=1.d-6,TOLX=EPS) + PARAMETER(NP=1000,MAXITS=250,EPS=1.0d-7,TOLX=EPS) +CU USES fdjac,funcv,lnsrch,qrdcmp,qrupdt,rsolv + INTEGER i,its,j,k + double precision den,f,fold,stpmax,sum,temp,test,c(NP), + & d(NP),fvcold(NP),g(NP),p(NP),qt(NP,NP),r(NP,NP), + & s(NP),t(NP),w(NP),xold(NP),fvec(NP) + LOGICAL restrt,sing,skip + EXTERNAL funcv + TOLMIN=TOLF*0.01d0 + call funcv(n,x,fvec,f) + test=0.0d0 + do 11 i=1,n + if(dabs(fvec(i)).gt.test)test=dabs(fvec(i)) +11 continue + if(test.lt..01d0*TOLF)then + ierr=0 +! check=.false. + return + endif + sum=0.0d0 + do 12 i=1,n + sum=sum+x(i)*x(i) +12 continue + stpmax=STPMX*dmax1(dsqrt(sum),dble(n)) + restrt=.true. + do 42 its=1,MAXITS + if(restrt)then + do i=1,n + if(x(i).lt.x0min(i).or.x(i).gt.x0max(i))then + ierr=1 + return + endif + enddo + call fdjac(n,x,fvec,NP,r,funcv) + call qrdcmp(r,n,NP,c,d,sing) +! if(sing) pause 'singular Jacobian in broydn' + if(sing)then + ierr=2 + return + end if + do 14 i=1,n + do 13 j=1,n + qt(i,j)=0.0d0 +13 continue + qt(i,i)=1.0d0 +14 continue + do 18 k=1,n-1 + if(c(k).ne.0.0d0)then + do 17 j=1,n + sum=0.0d0 + do 15 i=k,n + sum=sum+r(i,k)*qt(i,j) +15 continue + sum=sum/c(k) + do 16 i=k,n + qt(i,j)=qt(i,j)-sum*r(i,k) +16 continue +17 continue + endif +18 continue + do 21 i=1,n + r(i,i)=d(i) + do 19 j=1,i-1 + r(i,j)=0.0d0 +19 continue +21 continue + else + do 22 i=1,n + s(i)=x(i)-xold(i) +22 continue + do 24 i=1,n + sum=0.0d0 + do 23 j=i,n + sum=sum+r(i,j)*s(j) +23 continue + t(i)=sum +24 continue + skip=.true. + do 26 i=1,n + sum=0.0d0 + do 25 j=1,n + sum=sum+qt(j,i)*t(j) +25 continue + w(i)=fvec(i)-fvcold(i)-sum + if(dabs(w(i)).ge.EPS*(dabs(fvec(i))+ + & dabs(fvcold(i))))then + skip=.false. + else + w(i)=0.0d0 + endif +26 continue + if(.not.skip)then + do 28 i=1,n + sum=0.0d0 + do 27 j=1,n + sum=sum+qt(i,j)*w(j) +27 continue + t(i)=sum +28 continue + den=0.0d0 + do 29 i=1,n + den=den+s(i)*s(i) +29 continue + do 31 i=1,n + s(i)=s(i)/den +31 continue + call qrupdt(r,qt,n,NP,t,s) + do 32 i=1,n + if(r(i,i).eq.0.0d0) then + write(*,*) 'r singular in broydn' + end if + d(i)=r(i,i) +32 continue + endif + endif + do 34 i=1,n + sum=0.0d0 + do 33 j=1,n + sum=sum+qt(i,j)*fvec(j) +33 continue + p(i)=-sum +34 continue + do 36 i=n,1,-1 + sum=0.0d0 + do 35 j=1,i + sum=sum-r(j,i)*p(j) +35 continue + g(i)=sum +36 continue + do 37 i=1,n + xold(i)=x(i) + fvcold(i)=fvec(i) +37 continue + fold=f + call rsolv(r,n,NP,d,p) + +! Gu modification starts + do 100 i=1,n + if(xold(i).lt.x0min(i).or.xold(i).gt.x0max(i))then + ierr=1 + return + endif +100 continue +! Gu modification ends + call lnsrch(n,xold,fold,g,p,x,f, + & stpmax,check,funcv,fvec) + test=0.0d0 + do 38 i=1,n + if(dabs(fvec(i)).gt.test)test=dabs(fvec(i)) + fveccopy(i)=fvec(i) +38 continue + if(test.lt.TOLF)then + ierr=0 +! check=.false. + return + endif + if(check)then + if(restrt)then + ierr=3 + return + else + test=0.0d0 + den=dmax1(f,.5d0*dble(n)) + do 39 i=1,n + temp=dabs(g(i))*dmax1(dabs(x(i)),1.0d0)/den + if(temp.gt.test)test=temp +39 continue + if(test.lt.TOLMIN)then + ierr=4 + return + else + restrt=.true. + endif + endif + else + restrt=.false. + test=0.0d0 + do 41 i=1,n + temp=(dabs(x(i)-xold(i)))/dmax1(dabs(x(i)),1.0d0) + if(temp.gt.test)test=temp +41 continue + if(test.lt.TOLX)then + ierr=4 +! check=.true. + return + endif + endif +42 continue + ierr=5 + return + END + + SUBROUTINE fdjac(n,x,fvec,np,df,funcv) + implicit none + INTEGER n,np + double precision df(np,np),fvec(n),x(n),EPS + PARAMETER (EPS=1.0d-4) +CU USES funcv + INTEGER i,j,k + double precision h,temp,f(n),fsqsum + external funcv + do 12 j=1,n + temp=x(j) + h=EPS*dabs(temp) + if(h.eq.0.0d0)h=EPS + x(j)=temp+h + h=x(j)-temp + call funcv(n,x,f,fsqsum) + x(j)=temp + do 11 i=1,n + df(i,j)=(f(i)-fvec(i))/h +11 continue +12 continue + return + END +c + SUBROUTINE lnsrch(n,xold,fold,g,p,x,f, + & stpmax,check,funcv,fvec) + implicit none + INTEGER n + LOGICAL check + DOUBLE PRECISION f,fold,stpmax,g(n),p(n),x(n), + *xold(n),ALF,TOLX,fvec(n) + PARAMETER (ALF=1.d-4,TOLX=1.d-7) + EXTERNAL funcv +CU USES funcv + INTEGER i + DOUBLE PRECISION a,alam,alam2,alamin,b,disc, + *f2,rhs1,rhs2,slope,sum,temp,test,tmplam + check=.false. + sum=0.0d0 + do 11 i=1,n + sum=sum+p(i)*p(i) +11 continue + sum=dsqrt(sum) + if(sum.gt.stpmax)then + do 12 i=1,n + p(i)=p(i)*stpmax/sum +12 continue + endif + slope=0.0d0 + do 13 i=1,n + slope=slope+g(i)*p(i) +13 continue +! if(slope.ge.0.0d0)pause 'roundoff problem in lnsrch' + test=0.0d0 + do 14 i=1,n + temp=dabs(p(i))/dmax1(dabs(xold(i)),1.0d0) + if(temp.gt.test)test=temp +14 continue + alamin=TOLX/test + alam=1.0d0 +1 continue + do 15 i=1,n + x(i)=xold(i)+alam*p(i) +15 continue + call funcv(n,x,fvec,f) + if(alam.lt.alamin)then + do 16 i=1,n + x(i)=xold(i) +16 continue + check=.true. + return + else if(f.le.fold+ALF*alam*slope)then + return + else + if(alam.eq.1.0d0)then + tmplam=-slope/(2.0d0*(f-fold-slope)) + else + rhs1=f-fold-alam*slope + rhs2=f2-fold-alam2*slope + a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2) + b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/ + & (alam-alam2) + if(a.eq.0.0d0)then + tmplam=-slope/(2.0d0*b) + else + disc=b*b-3.0d0*a*slope + if(disc.lt.0.0d0) then + tmplam=0.5d0*alam + else if(b.le.0.0d0)then + tmplam=(-b+dsqrt(disc))/(3.0d0*a) + else + tmplam=-slope/(b+dsqrt(disc)) + endif + endif + if(tmplam.gt..5d0*alam)tmplam=.5d0*alam + endif + endif + alam2=alam + f2=f + alam=dmax1(tmplam,.1d0*alam) + goto 1 + END +c + SUBROUTINE qrdcmp(a,n,np,c,d,sing) + implicit none + INTEGER n,np + DOUBLE PRECISION a(np,np),c(n),d(n) + LOGICAL sing + INTEGER i,j,k + DOUBLE PRECISION scale,sigma,sum,tau + sing=.false. + do 17 k=1,n-1 + scale=0.0d0 + do 11 i=k,n + scale=dmax1(scale,dabs(a(i,k))) +11 continue + if(scale.eq.0.0d0)then + sing=.true. + c(k)=0.0d0 + d(k)=0.0d0 + else + do 12 i=k,n + a(i,k)=a(i,k)/scale +12 continue + sum=0.0d0 + do 13 i=k,n + sum=sum+a(i,k)**2 +13 continue + sigma=dsign(dsqrt(sum),a(k,k)) + a(k,k)=a(k,k)+sigma + c(k)=sigma*a(k,k) + d(k)=-scale*sigma + do 16 j=k+1,n + sum=0.0d0 + do 14 i=k,n + sum=sum+a(i,k)*a(i,j) +14 continue + tau=sum/c(k) + do 15 i=k,n + a(i,j)=a(i,j)-tau*a(i,k) +15 continue +16 continue + endif +17 continue + d(n)=a(n,n) + if(d(n).eq.0.0d0)sing=.true. + return + END +c + SUBROUTINE qrupdt(r,qt,n,np,u,v) + implicit none + INTEGER n,np + DOUBLE PRECISION r(np,np),qt(np,np),u(np),v(np) +CU USES rotate + INTEGER i,j,k + do 11 k=n,1,-1 + if(u(k).ne.0.0d0)goto 1 +11 continue + k=1 +1 do 12 i=k-1,1,-1 + call rotate(r,qt,n,np,i,u(i),-u(i+1)) + if(u(i).eq.0.0d0)then + u(i)=dabs(u(i+1)) + else if(dabs(u(i)).gt.dabs(u(i+1)))then + u(i)=dabs(u(i))*dsqrt(1.0d0+(u(i+1)/u(i))**2) + else + u(i)=dabs(u(i+1))*dsqrt(1.0d0+(u(i)/u(i+1))**2) + endif +12 continue + do 13 j=1,n + r(1,j)=r(1,j)+u(1)*v(j) +13 continue + do 14 i=1,k-1 + call rotate(r,qt,n,np,i,r(i,i),-r(i+1,i)) +14 continue + return + END +c + SUBROUTINE rsolv(a,n,np,d,b) + implicit none + INTEGER n,np + DOUBLE PRECISION a(np,np),b(n),d(n) + INTEGER i,j + DOUBLE PRECISION sum + b(n)=b(n)/d(n) + do 12 i=n-1,1,-1 + sum=0.0d0 + do 11 j=i+1,n + sum=sum+a(i,j)*b(j) +11 continue + b(i)=(b(i)-sum)/d(i) +12 continue + return + END +c + SUBROUTINE rotate(r,qt,n,np,i,a,b) + implicit none + INTEGER n,np,i + DOUBLE PRECISION a,b,r(np,np),qt(np,np) + INTEGER j + DOUBLE PRECISION c,fact,s,w,y + if(a.eq.0.0d0)then + c=0.0d0 + s=dsign(1.0d0,b) + else if(dabs(a).gt.dabs(b))then + fact=b/a + c=dsign(1.0d0/dsqrt(1.0d0+fact**2),a) + s=fact*c + else + fact=a/b + s=dsign(1.0d0/dsqrt(1.0d0+fact**2),b) + c=fact*s + endif + do 11 j=i,n + y=r(i,j) + w=r(i+1,j) + r(i,j)=c*y-s*w + r(i+1,j)=s*y+c*w +11 continue + do 12 j=1,n + y=qt(i,j) + w=qt(i+1,j) + qt(i,j)=c*y-s*w + qt(i+1,j)=s*y+c*w +12 continue + return + END + + subroutine xmprove(N,NP,a,b,x,mark) + implicit none + INTEGER i,j,idum,N,NP,indx(N),mark + double precision d,a(NP,NP),b(N),x(N),aa(NP,NP) + + do 12 i=1,N + x(i)=b(i) + do 11 j=1,N + aa(i,j)=a(i,j) +11 continue +12 continue + call ludcmp(aa,N,NP,indx,d,mark) + if (mark .eq. 0) goto 20 + call lubksb(aa,N,NP,indx,x) + call mprove(a,aa,N,NP,indx,b,x) +20 continue + return + END + + + SUBROUTINE mprove(a,alud,n,np,indx,b,x) + implicit none + INTEGER n,np,indx(n),NMAX + double precision a(np,np),alud(np,np),b(n),x(n) + PARAMETER (NMAX=500) +CU USES lubksb + INTEGER i,j + double precision r(NMAX) + DOUBLE PRECISION sdp + do 12 i=1,n + sdp=-b(i) + do 11 j=1,n + sdp=sdp+(a(i,j))*(x(j)) +11 continue + r(i)=sdp +12 continue + call lubksb(alud,n,np,indx,r) + do 13 i=1,n + x(i)=x(i)-r(i) +13 continue + return + END + + SUBROUTINE ludcmp(a,n,np,indx,d,mark) + implicit none + INTEGER n,np,indx(n),NMAX + double precision d,a(np,np),TINY + PARAMETER (NMAX=500,TINY=1.0d-20) + INTEGER i,imax,j,k,mark + double precision aamax,dum,sum,vv(NMAX) + mark=1 + d=1.0d0 + do 12 i=1,n + aamax=0.0d0 + do 11 j=1,n + if (dabs(a(i,j)).gt.aamax) aamax=dabs(a(i,j)) +11 continue + if (aamax.eq.0.0d0) then +! singular matrix + mark=0 + return + end if + vv(i)=1.0d0/aamax +12 continue + do 19 j=1,n + do 14 i=1,j-1 + sum=a(i,j) + do 13 k=1,i-1 + sum=sum-a(i,k)*a(k,j) +13 continue + a(i,j)=sum +14 continue + aamax=0.0d0 + do 16 i=j,n + sum=a(i,j) + do 15 k=1,j-1 + sum=sum-a(i,k)*a(k,j) +15 continue + a(i,j)=sum + dum=vv(i)*dabs(sum) + if (dum.ge.aamax) then + imax=i + aamax=dum + endif +16 continue + if (j.ne.imax)then + do 17 k=1,n + dum=a(imax,k) + a(imax,k)=a(j,k) + a(j,k)=dum +17 continue + d=-d + vv(imax)=vv(j) + endif + indx(j)=imax + if(a(j,j).eq.0.0d0)a(j,j)=TINY + if(j.ne.n)then + dum=1.0d0/a(j,j) + do 18 i=j+1,n + a(i,j)=a(i,j)*dum +18 continue + endif +19 continue + return + END + + SUBROUTINE lubksb(a,n,np,indx,b) + implicit none + INTEGER n,np,indx(n) + double precision a(np,np),b(n) + INTEGER i,ii,j,ll + double precision sum + ii=0 + do 12 i=1,n + ll=indx(i) + sum=b(ll) + b(ll)=b(i) + if (ii.ne.0)then + do 11 j=ii,i-1 + sum=sum-a(i,j)*b(j) +11 continue + else if (sum.ne.0.0d0) then + ii=i + endif + b(i)=sum +12 continue + do 14 i=n,1,-1 + sum=b(i) + do 13 j=i+1,n + sum=sum-a(i,j)*b(j) +13 continue + b(i)=sum/a(i,i) +14 continue + return + END diff --git a/dataassim/math/nonlinsystems/cpbookkeeping.f b/dataassim/math/nonlinsystems/cpbookkeeping.f new file mode 100644 index 0000000..2aa71e3 --- /dev/null +++ b/dataassim/math/nonlinsystems/cpbookkeeping.f @@ -0,0 +1,65 @@ + subroutine cpbookkeeping(nunknowns,xvar,fequ, + & icall,iflargest) + implicit none + include 'cpnslasystem.h' + integer nunknowns,icall,iflargest + double precision xvar(nunknowns),fequ(nunknowns) + integer iGuCall,i,j,k + parameter(iGuCall=49) +!-------------------------------------------------------------------------- + iflargest=1 + do j=2,nunknowns + if(dabs(fequ(j)).gt.dabs(fequ(iflargest))) + & iflargest=j + enddo + if(numeval.eq.0.or.icall.eq.iGuCall)then + numeval=numeval+1 + flargest(numeval)=dabs(fequ(iflargest)) + do i=1,nunknowns + xevaluated(numeval,i)=xvar(i) + fevaluated(numeval,i)=fequ(i) + enddo + return + endif + do i=1,numeval + k=0 + do j=1,nunknowns + if(dabs(xvar(j)-xevaluated(i,j)).gt. + & 1.0d-5*dabs(xvar(j)))k=1 + enddo + if(k.eq.0)goto 500 + enddo + if(numeval.lt.maxeval)then + numeval=numeval+1 + flargest(numeval)=dabs(fequ(iflargest)) + do i=1,nunknowns + xevaluated(numeval,i)=xvar(i) + fevaluated(numeval,i)=fequ(i) + enddo + return + endif +! replace a point + j=1 + do i=2,numeval + if(flargest(j).lt.flargest(i))then + j=i + endif + enddo + if(dabs(fequ(iflargest)).lt.flargest(j))then + flargest(j)=dabs(fequ(iflargest)) + do i=1,nunknowns + xevaluated(j,i)=xvar(i) + fevaluated(j,i)=fequ(i) + enddo + endif + return +! too close to the existing point i +500 if(dabs(fequ(iflargest)).lt.flargest(i))then + flargest(i)=dabs(fequ(iflargest)) + do j=1,nunknowns + xevaluated(i,j)=xvar(j) + fevaluated(i,j)=fequ(j) + enddo + endif + return + end diff --git a/dataassim/math/nonlinsystems/cpbroydn.f b/dataassim/math/nonlinsystems/cpbroydn.f new file mode 100644 index 0000000..684d432 --- /dev/null +++ b/dataassim/math/nonlinsystems/cpbroydn.f @@ -0,0 +1,567 @@ +C This file contains all the subroutines needed by the nonlinear solver broydn +C code modified based on on-line version in Numerical Recipes Website, Dec 28, 2004 + + SUBROUTINE cpbroydn(x0min,x,x0max,STPMX,n, + & fveccopy,funcv,TOLF,ierr) + implicit none + INTEGER n,NP,MAXITS,ierr + double precision x(n),EPS,TOLF,TOLMIN,TOLX,STPMX + double precision x0min(n),x0max(n),fveccopy(n) + LOGICAL check +! PARAMETER (NP=1000,MAXITS=250,EPS=1.0d-7,TOLF=1.0d-4, +! & TOLMIN=1.d-6,TOLX=EPS) + PARAMETER(NP=1000,MAXITS=250,EPS=1.0d-7,TOLX=EPS) +CU USES fdjac,funcv,lnsrch,qrdcmp,qrupdt,rsolv + INTEGER i,its,j,k + double precision den,f,fold,stpmax,sum,temp,test,c(NP), + & d(NP),fvcold(NP),g(NP),p(NP),qt(NP,NP),r(NP,NP), + & s(NP),t(NP),w(NP),xold(NP),fvec(NP) + LOGICAL restrt,sing,skip + EXTERNAL funcv + TOLMIN=TOLF*0.01d0 + call funcv(n,x,fvec,f) + test=0.0d0 + do 11 i=1,n + if(dabs(fvec(i)).gt.test)test=dabs(fvec(i)) +11 continue + if(test.lt..01d0*TOLF)then + ierr=0 +! check=.false. + return + endif + sum=0.0d0 + do 12 i=1,n + sum=sum+x(i)*x(i) +12 continue + stpmax=STPMX*dmax1(dsqrt(sum),dble(n)) + restrt=.true. + do 42 its=1,MAXITS + if(restrt)then + do i=1,n + if(x(i).lt.x0min(i).or.x(i).gt.x0max(i))then + ierr=1 + return + endif + enddo + call cpfdjac(n,x,fvec,NP,r,funcv) + call cpqrdcmp(r,n,NP,c,d,sing) +! if(sing) pause 'singular Jacobian in broydn' + if(sing)then + ierr=2 + return + end if + do 14 i=1,n + do 13 j=1,n + qt(i,j)=0.0d0 +13 continue + qt(i,i)=1.0d0 +14 continue + do 18 k=1,n-1 + if(c(k).ne.0.0d0)then + do 17 j=1,n + sum=0.0d0 + do 15 i=k,n + sum=sum+r(i,k)*qt(i,j) +15 continue + sum=sum/c(k) + do 16 i=k,n + qt(i,j)=qt(i,j)-sum*r(i,k) +16 continue +17 continue + endif +18 continue + do 21 i=1,n + r(i,i)=d(i) + do 19 j=1,i-1 + r(i,j)=0.0d0 +19 continue +21 continue + else + do 22 i=1,n + s(i)=x(i)-xold(i) +22 continue + do 24 i=1,n + sum=0.0d0 + do 23 j=i,n + sum=sum+r(i,j)*s(j) +23 continue + t(i)=sum +24 continue + skip=.true. + do 26 i=1,n + sum=0.0d0 + do 25 j=1,n + sum=sum+qt(j,i)*t(j) +25 continue + w(i)=fvec(i)-fvcold(i)-sum + if(dabs(w(i)).ge.EPS*(dabs(fvec(i))+ + & dabs(fvcold(i))))then + skip=.false. + else + w(i)=0.0d0 + endif +26 continue + if(.not.skip)then + do 28 i=1,n + sum=0.0d0 + do 27 j=1,n + sum=sum+qt(i,j)*w(j) +27 continue + t(i)=sum +28 continue + den=0.0d0 + do 29 i=1,n + den=den+s(i)*s(i) +29 continue + do 31 i=1,n + s(i)=s(i)/den +31 continue + call cpqrupdt(r,qt,n,NP,t,s) + do 32 i=1,n + if(r(i,i).eq.0.0d0) then + write(*,*) 'r singular in broydn' + end if + d(i)=r(i,i) +32 continue + endif + endif + do 34 i=1,n + sum=0.0d0 + do 33 j=1,n + sum=sum+qt(i,j)*fvec(j) +33 continue + p(i)=-sum +34 continue + do 36 i=n,1,-1 + sum=0.0d0 + do 35 j=1,i + sum=sum-r(j,i)*p(j) +35 continue + g(i)=sum +36 continue + do 37 i=1,n + xold(i)=x(i) + fvcold(i)=fvec(i) +37 continue + fold=f + call cprsolv(r,n,NP,d,p) + +! Gu modification starts + do 100 i=1,n + if(xold(i).lt.x0min(i).or.xold(i).gt.x0max(i))then + ierr=1 + return + endif +100 continue +! Gu modification ends + call cplnsrch(n,xold,fold,g,p,x,f, + & stpmax,check,funcv,fvec) + test=0.0d0 + do 38 i=1,n + if(dabs(fvec(i)).gt.test)test=dabs(fvec(i)) + fveccopy(i)=fvec(i) +38 continue + if(test.lt.TOLF)then + ierr=0 +! check=.false. + return + endif + if(check)then + if(restrt)then + ierr=3 + return + else + test=0.0d0 + den=dmax1(f,.5d0*dble(n)) + do 39 i=1,n + temp=dabs(g(i))*dmax1(dabs(x(i)),1.0d0)/den + if(temp.gt.test)test=temp +39 continue + if(test.lt.TOLMIN)then + ierr=4 + return + else + restrt=.true. + endif + endif + else + restrt=.false. + test=0.0d0 + do 41 i=1,n + temp=(dabs(x(i)-xold(i)))/dmax1(dabs(x(i)),1.0d0) + if(temp.gt.test)test=temp +41 continue + if(test.lt.TOLX)then + ierr=4 +! check=.true. + return + endif + endif +42 continue + ierr=5 + return + END + + SUBROUTINE cpfdjac(n,x,fvec,np,df,funcv) + implicit none + INTEGER n,np + double precision df(np,np),fvec(n),x(n),EPS + PARAMETER (EPS=1.0d-4) +CU USES funcv + INTEGER i,j,k + double precision h,temp,f(n),fsqsum + external funcv + do 12 j=1,n + temp=x(j) + h=EPS*dabs(temp) + if(h.eq.0.0d0)h=EPS + x(j)=temp+h + h=x(j)-temp + call funcv(n,x,f,fsqsum) + x(j)=temp + do 11 i=1,n + df(i,j)=(f(i)-fvec(i))/h +11 continue +12 continue + return + END +c + SUBROUTINE cplnsrch(n,xold,fold,g,p,x,f, + & stpmax,check,funcv,fvec) + implicit none + INTEGER n + LOGICAL check + DOUBLE PRECISION f,fold,stpmax,g(n),p(n),x(n), + *xold(n),ALF,TOLX,fvec(n) + PARAMETER (ALF=1.d-4,TOLX=1.d-7) + EXTERNAL funcv +CU USES funcv + INTEGER i + DOUBLE PRECISION a,alam,alam2,alamin,b,disc, + *f2,rhs1,rhs2,slope,sum,temp,test,tmplam + check=.false. + sum=0.0d0 + do 11 i=1,n + sum=sum+p(i)*p(i) +11 continue + sum=dsqrt(sum) + if(sum.gt.stpmax)then + do 12 i=1,n + p(i)=p(i)*stpmax/sum +12 continue + endif + slope=0.0d0 + do 13 i=1,n + slope=slope+g(i)*p(i) +13 continue +! if(slope.ge.0.0d0)pause 'roundoff problem in lnsrch' + test=0.0d0 + do 14 i=1,n + temp=dabs(p(i))/dmax1(dabs(xold(i)),1.0d0) + if(temp.gt.test)test=temp +14 continue + alamin=TOLX/test + alam=1.0d0 +1 continue + do 15 i=1,n + x(i)=xold(i)+alam*p(i) +15 continue + call funcv(n,x,fvec,f) + if(alam.lt.alamin)then + do 16 i=1,n + x(i)=xold(i) +16 continue + check=.true. + return + else if(f.le.fold+ALF*alam*slope)then + return + else + if(alam.eq.1.0d0)then + tmplam=-slope/(2.0d0*(f-fold-slope)) + else + rhs1=f-fold-alam*slope + rhs2=f2-fold-alam2*slope + a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2) + b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/ + & (alam-alam2) + if(a.eq.0.0d0)then + tmplam=-slope/(2.0d0*b) + else + disc=b*b-3.0d0*a*slope + if(disc.lt.0.0d0) then + tmplam=0.5d0*alam + else if(b.le.0.0d0)then + tmplam=(-b+dsqrt(disc))/(3.0d0*a) + else + tmplam=-slope/(b+dsqrt(disc)) + endif + endif + if(tmplam.gt..5d0*alam)tmplam=.5d0*alam + endif + endif + alam2=alam + f2=f + alam=dmax1(tmplam,.1d0*alam) + goto 1 + END +c + SUBROUTINE cpqrdcmp(a,n,np,c,d,sing) + implicit none + INTEGER n,np + DOUBLE PRECISION a(np,np),c(n),d(n) + LOGICAL sing + INTEGER i,j,k + DOUBLE PRECISION scale,sigma,sum,tau + sing=.false. + do 17 k=1,n-1 + scale=0.0d0 + do 11 i=k,n + scale=dmax1(scale,dabs(a(i,k))) +11 continue + if(scale.eq.0.0d0)then + sing=.true. + c(k)=0.0d0 + d(k)=0.0d0 + else + do 12 i=k,n + a(i,k)=a(i,k)/scale +12 continue + sum=0.0d0 + do 13 i=k,n + sum=sum+a(i,k)**2 +13 continue + sigma=dsign(dsqrt(sum),a(k,k)) + a(k,k)=a(k,k)+sigma + c(k)=sigma*a(k,k) + d(k)=-scale*sigma + do 16 j=k+1,n + sum=0.0d0 + do 14 i=k,n + sum=sum+a(i,k)*a(i,j) +14 continue + tau=sum/c(k) + do 15 i=k,n + a(i,j)=a(i,j)-tau*a(i,k) +15 continue +16 continue + endif +17 continue + d(n)=a(n,n) + if(d(n).eq.0.0d0)sing=.true. + return + END +c + SUBROUTINE cpqrupdt(r,qt,n,np,u,v) + implicit none + INTEGER n,np + DOUBLE PRECISION r(np,np),qt(np,np),u(np),v(np) +CU USES rotate + INTEGER i,j,k + do 11 k=n,1,-1 + if(u(k).ne.0.0d0)goto 1 +11 continue + k=1 +1 do 12 i=k-1,1,-1 + call cprotate(r,qt,n,np,i,u(i),-u(i+1)) + if(u(i).eq.0.0d0)then + u(i)=dabs(u(i+1)) + else if(dabs(u(i)).gt.dabs(u(i+1)))then + u(i)=dabs(u(i))*dsqrt(1.0d0+(u(i+1)/u(i))**2) + else + u(i)=dabs(u(i+1))*dsqrt(1.0d0+(u(i)/u(i+1))**2) + endif +12 continue + do 13 j=1,n + r(1,j)=r(1,j)+u(1)*v(j) +13 continue + do 14 i=1,k-1 + call cprotate(r,qt,n,np,i,r(i,i),-r(i+1,i)) +14 continue + return + END +c + SUBROUTINE cprsolv(a,n,np,d,b) + implicit none + INTEGER n,np + DOUBLE PRECISION a(np,np),b(n),d(n) + INTEGER i,j + DOUBLE PRECISION sum + b(n)=b(n)/d(n) + do 12 i=n-1,1,-1 + sum=0.0d0 + do 11 j=i+1,n + sum=sum+a(i,j)*b(j) +11 continue + b(i)=(b(i)-sum)/d(i) +12 continue + return + END +c + SUBROUTINE cprotate(r,qt,n,np,i,a,b) + implicit none + INTEGER n,np,i + DOUBLE PRECISION a,b,r(np,np),qt(np,np) + INTEGER j + DOUBLE PRECISION c,fact,s,w,y + if(a.eq.0.0d0)then + c=0.0d0 + s=dsign(1.0d0,b) + else if(dabs(a).gt.dabs(b))then + fact=b/a + c=dsign(1.0d0/dsqrt(1.0d0+fact**2),a) + s=fact*c + else + fact=a/b + s=dsign(1.0d0/dsqrt(1.0d0+fact**2),b) + c=fact*s + endif + do 11 j=i,n + y=r(i,j) + w=r(i+1,j) + r(i,j)=c*y-s*w + r(i+1,j)=s*y+c*w +11 continue + do 12 j=1,n + y=qt(i,j) + w=qt(i+1,j) + qt(i,j)=c*y-s*w + qt(i+1,j)=s*y+c*w +12 continue + return + END + + subroutine cpxmprove(N,NP,a,b,x,mark) + implicit none + INTEGER i,j,idum,N,NP,indx(N),mark + double precision d,a(NP,NP),b(N),x(N),aa(NP,NP) + + do 12 i=1,N + x(i)=b(i) + do 11 j=1,N + aa(i,j)=a(i,j) +11 continue +12 continue + call cpludcmp(aa,N,NP,indx,d,mark) + if (mark .eq. 0) goto 20 + call cplubksb(aa,N,NP,indx,x) + call cpmprove(a,aa,N,NP,indx,b,x) +20 continue + return + END + + + SUBROUTINE cpmprove(a,alud,n,np,indx,b,x) + implicit none + INTEGER n,np,indx(n),NMAX + double precision a(np,np),alud(np,np),b(n),x(n) + PARAMETER (NMAX=500) +CU USES lubksb + INTEGER i,j + double precision r(NMAX) + DOUBLE PRECISION sdp + do 12 i=1,n + sdp=-b(i) + do 11 j=1,n + sdp=sdp+(a(i,j))*(x(j)) +11 continue + r(i)=sdp +12 continue + call cplubksb(alud,n,np,indx,r) + do 13 i=1,n + x(i)=x(i)-r(i) +13 continue + return + END + + SUBROUTINE cpludcmp(a,n,np,indx,d,mark) + implicit none + INTEGER n,np,indx(n),NMAX + double precision d,a(np,np),TINY + PARAMETER (NMAX=500,TINY=1.0d-20) + INTEGER i,imax,j,k,mark + double precision aamax,dum,sum,vv(NMAX) + mark=1 + d=1.0d0 + do 12 i=1,n + aamax=0.0d0 + do 11 j=1,n + if (dabs(a(i,j)).gt.aamax) aamax=dabs(a(i,j)) +11 continue + if (aamax.eq.0.0d0) then +! singular matrix + mark=0 + return + end if + vv(i)=1.0d0/aamax +12 continue + do 19 j=1,n + do 14 i=1,j-1 + sum=a(i,j) + do 13 k=1,i-1 + sum=sum-a(i,k)*a(k,j) +13 continue + a(i,j)=sum +14 continue + aamax=0.0d0 + do 16 i=j,n + sum=a(i,j) + do 15 k=1,j-1 + sum=sum-a(i,k)*a(k,j) +15 continue + a(i,j)=sum + dum=vv(i)*dabs(sum) + if (dum.ge.aamax) then + imax=i + aamax=dum + endif +16 continue + if (j.ne.imax)then + do 17 k=1,n + dum=a(imax,k) + a(imax,k)=a(j,k) + a(j,k)=dum +17 continue + d=-d + vv(imax)=vv(j) + endif + indx(j)=imax + if(a(j,j).eq.0.0d0)a(j,j)=TINY + if(j.ne.n)then + dum=1.0d0/a(j,j) + do 18 i=j+1,n + a(i,j)=a(i,j)*dum +18 continue + endif +19 continue + return + END + + SUBROUTINE cplubksb(a,n,np,indx,b) + implicit none + INTEGER n,np,indx(n) + double precision a(np,np),b(n) + INTEGER i,ii,j,ll + double precision sum + ii=0 + do 12 i=1,n + ll=indx(i) + sum=b(ll) + b(ll)=b(i) + if (ii.ne.0)then + do 11 j=ii,i-1 + sum=sum-a(i,j)*b(j) +11 continue + else if (sum.ne.0.0d0) then + ii=i + endif + b(i)=sum +12 continue + do 14 i=n,1,-1 + sum=b(i) + do 13 j=i+1,n + sum=sum-a(i,j)*b(j) +13 continue + b(i)=sum/a(i,i) +14 continue + return + END diff --git a/dataassim/math/nonlinsystems/cpfixedpoint.f b/dataassim/math/nonlinsystems/cpfixedpoint.f new file mode 100644 index 0000000..ecdd1b6 --- /dev/null +++ b/dataassim/math/nonlinsystems/cpfixedpoint.f @@ -0,0 +1,315 @@ + subroutine cpfixedpoint(funcnleq1,x0min,x0ori,xp, + & x0max,fequ,nunknowns,TOLF,stpmax,iwhichsolver) + implicit none + include 'cpnslasystem.h' +!-------- Inputs --------------------------------------- +! nunknowns: The number of unknowns to be solved +! x0ori(1:nunknowns): initial guess for the unknowns +! x0min(1:nunknowns): lower bound of the solution +! x0max(1:nunknowns): upper bound of the solution +! stpmax: the maximum length of the steps allowed to prevent search into +! undefined region. +! TOLF: Error tolerance +! funcnleq1: the subroutine name for the nonlinear system + integer nunknowns + double precision x0min(1:nunknowns),x0ori(1:nunknowns), + & x0max(1:nunknowns),TOLF,stpmax +! --------- Outputs ------------------------------------- +! fequ(1:nunknowns): function values at the last step of iteration +! xp(1:nunknowns): final solutions or solutions not worse than x0ori +! iwhichsolver: =1,2,3,4 successful +! =-9999 failed, best solution returned + integer iwhichsolver + double precision fequ(1:nunknowns),xp(1:nunknowns) +! ---------Local variables -------------------------------- + integer i,j,k,maxiter,notfound,ncount,ierr, + & ismallest,iGuCall + double precision swap,x1,x2,f1,f2,fsqsumold, + & fsqsumnew,xpold(nunknowns),fequold(nunknowns), + & gfuncsum(nunknowns),deltax(nunknowns), + & xpder(nunknowns),fjacob(nunknowns,nunknowns), + & fjacobcopy(nunknowns,nunknowns),fsqsum + logical check + parameter(maxiter=200,notfound=-9999,iGuCall=49) + integer iselect(300*maxiter) + logical resetran2 + common /cpran2reset/resetran2 + save /cpran2reset/ + external funcnleq1 +!----------------------------------------------------------- + resetran2=.true. + do i=1,nunknowns + xp(i)=x0ori(i) + enddo + iwhichsolver=notfound + numeval=0 +!-------------------------------------------------------------- +!Plain fixed-point method. Fixed-point method 1 + do i=1,maxiter + call funcnleq1(nunknowns,xp,fequ,fsqsum) + call cpbookkeeping(nunknowns,xp,fequ,iGuCall,k) + if(dabs(fequ(k)).lt.TOLF)then + iwhichsolver=1 + return + endif + do j=1,nunknowns + xp(j)=xp(j)-fequ(j) + if(xp(j).lt.x0min(j).or.xp(j).gt.x0max(j))then + call reinitialization(x0min(j),x0ori(j), + & x0max(j),xp(j),50000) + endif + enddo + enddo +!_____________________________________________________________________ +!try fixed-point method 2 + do j=1,nunknowns + call reinitialization(x0min(j),x0ori(j), + & x0max(j),xp(j),10000) + enddo + call funcnleq1(nunknowns,xp,fequ,fsqsum) + call cpbookkeeping(nunknowns,xp,fequ,iGuCall,k) + do i=1,nunknowns + xp(i)=xp(i)-fequ(i) + if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),2000) + endif + enddo + do i=1,maxiter + call funcnleq1(nunknowns,xp,fequ,fsqsum) + call cpbookkeeping(nunknowns,xp,fequ,iGuCall,k) + if(dabs(fequ(k)).lt.TOLF)then + iwhichsolver=2 + return + endif + do j=1,nunknowns + ierr=0 + x1=xevaluated(numeval-1,j) + f1=x1-fevaluated(numeval-1,j) + x2=xevaluated(numeval,j) + f2=x2-fevaluated(numeval,j) + if(dabs(f2-f1-x2+x1).gt.1.0d-20)then + ierr=1 + xp(j)=(x1*(f2-f1)-f1*(x2-x1))/ + & (f2-f1-x2+x1) + if(xp(j).le.x0min(j).or.xp(j) + & .ge.x0max(j))then + ierr=0 + endif + endif + if(ierr.le.0.and.numeval.ge.3)then +! haven't found a usable new point yet, first try the opposite sign point + ncount=0 + do k=1,numeval-2 + if((fevaluated(k,j)*fevaluated(numeval,j)) + & .lt.0.0d0)then + ncount=ncount+1 + iselect(ncount)=k + endif + enddo + if(ncount.gt.0)then +! there are points at different sides of the zero. + ismallest=1 + do k=2,ncount + if(dabs(xevaluated(iselect(k),j)-x2).lt. + & dabs(xevaluated(iselect(ismallest),j)-x2))then + ismallest=k + endif + enddo + ierr=1 + x1=xevaluated(iselect(ismallest),j) + f1=x1-fevaluated(iselect(ismallest),j) + xp(j)=(x1*(f2-f1)-f1*(x2-x1))/ + & (f2-f1-x2+x1) + else +! all at the same sides of the zero. + do k=1,numeval-2 + x1=xevaluated(k,j) + f1=x1-fevaluated(k,j) + if(dabs(f2-f1-x2+x1).gt.1.0d-10)then + xp(j)=(x1*(f2-f1)-f1*(x2-x1))/ + & (f2-f1-x2+x1) + if(xp(j).gt.x0min(j).and.xp(j).lt.x0max(j))then + ierr=1 + endif + endif + if(ierr.eq.1)goto 10 + enddo +10 continue + endif + endif + if(ierr.eq.0)then + call reinitialization(x0min(j), + & xevaluated(numeval,j),x0max(j),xp(j),1000) + endif + enddo + ierr=0 + do k=1,nunknowns + if(xp(k).ne.xevaluated(numeval,k))ierr=1 + enddo + if(ierr.eq.0)then + do k=1,nunknowns + call reinitialization(x0min(k), + & xevaluated(numeval,k),x0max(k),xp(k),25000) + enddo + endif + enddo +!__________________________________________________________________ +!Try fixed-point method 3 + do i=1,nunknowns + xp(i)=x0ori(i)+1.0d-6 + if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),250910) + endif + enddo + do j=1,maxiter + call funcnleq1(nunknowns,xp,fequ,fsqsum) + call cpbookkeeping(nunknowns,xp,fequ,iGuCall,k) + if(dabs(fequ(k)).lt.TOLF)then + iwhichsolver=3 + return + endif + do i=1,nunknowns + xp(i)=xp(i)-fequ(i) + if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),25500) + endif + enddo + call funcnleq1(nunknowns,xp,fequ,fsqsum) + call cpbookkeeping(nunknowns,xp,fequ,iGuCall,k) + if(dabs(fequ(k)).lt.TOLF)then + iwhichsolver=3 + return + endif + do i=1,nunknowns + if(fevaluated(numeval,i).eq. + & fevaluated(numeval-1,i))then + x1=(xevaluated(numeval,i)+ + & xevaluated(numeval-1,i))/2.0d0 + call reinitialization(x0min(i),x1, + & x0max(i),xp(i),35678) + else + xp(i)=(xevaluated(numeval,i)*fevaluated(numeval-1,i) + & -xevaluated(numeval-1,i)*fevaluated(numeval,i))/ + & (fevaluated(numeval-1,i)-fevaluated(numeval,i)) + if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),45678) + endif + endif + enddo + enddo +!------------------------------------------------------------ +!Try fixed-point method 4 + +!11 call funcnleq1(nunknowns,xp,fequ,fsqsumold) +! call cpbookkeeping(nunknowns,xp,fequ,iGuCall,i) + + fsqsumold=0.0d0 + do i=1,nunknowns + xpold(i)=xevaluated(1,i) + fequold(i)=fevaluated(1,i) + fsqsumold=fsqsumold+fequold(i)*fequold(i) + enddo + fsqsumold=0.5d0*fsqsumold + do k=1,maxiter + do j=1,nunknowns + do i=1,nunknowns + xpder(i)=xpold(i) + enddo + if(dabs(fequold(j)).lt.1.0d-10)then + xpder(j)=xpold(j)+1.0d-5 + else + xpder(j)=xpold(j)-fequold(j) + endif + if(xpder(j).lt.x0min(j).or.xpder(j). + & gt.x0max(j))then + call reinitialization(x0min(j),xpold(j), + & x0max(j),xpder(j),89000) + endif + call funcnleq1(nunknowns,xpder,fequ,fsqsumnew) + call cpbookkeeping(nunknowns,xpder,fequ,iGuCall,i) + if(dabs(fequ(i)).lt.TOLF)then + iwhichsolver=4 + return + endif + do i=1,nunknowns + fjacob(i,j)=(fequ(i)-fequold(i))/ + & (xpder(j)-xpold(j)) + fjacobcopy(i,j)=fjacob(i,j) + enddo + gfuncsum(j)=(fsqsumnew-fsqsumold)/ + & (xpder(j)-xpold(j)) + enddo + call cpxmprove(nunknowns,nunknowns, + & fjacob,fequold,deltax,ierr) +!if ierr = 0, matrix is singular. ierr = 1, everything is ok. + if(ierr.eq.0)then + call adsor(fjacobcopy,nunknowns,nunknowns, + & fequold,deltax,ierr) + if(ierr.ne.1)ierr=0 + endif + if(ierr.ne.0)then + do i=1,nunknowns + deltax(i)=-deltax(i) + enddo + call cplnsrch(nunknowns,xpold,fsqsumold, + & gfuncsum,deltax,xp,fsqsumnew,stpmax, + & check,funcnleq1,fequ) + if(check.eq..true..or.check.eq..TRUE.)then + do i=1,nunknowns + call reinitialization(x0min(i),xpold(i), + & x0max(i),xp(i),6678) + enddo + endif + do i=1,nunknowns + if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),678) + endif + enddo + else + do i=1,nunknowns + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),75678) + enddo + endif + call funcnleq1(nunknowns,xp,fequ,fsqsumold) + call cpbookkeeping(nunknowns,xp,fequ,iGuCall,i) + if(dabs(fequ(i)).lt.TOLF)then + iwhichsolver=4 + return + endif + do i=1,nunknowns + xpold(i)=xp(i) + fequold(i)=fequ(i) + enddo + enddo +!_____________________________________________________________ +!If all four methods failed, choose the best xp + do i=1,numeval + do k=i+1,numeval + if(flargest(k).lt.flargest(i))then + swap=flargest(k) + flargest(k)=flargest(i) + flargest(i)=swap + do ncount=1,nunknowns + swap=xevaluated(k,ncount) + xevaluated(k,ncount)=xevaluated(i,ncount) + xevaluated(i,ncount)=swap + swap=fevaluated(k,ncount) + fevaluated(k,ncount)=fevaluated(i,ncount) + fevaluated(i,ncount)=swap + enddo + endif + enddo + enddo +! Best solution found so far + do i=1,nunknowns + xp(i)=xevaluated(1,i) + fequ(i)=fevaluated(1,i) + enddo + return + end subroutine cpfixedpoint diff --git a/dataassim/math/nonlinsystems/cpnonsyssolver.f b/dataassim/math/nonlinsystems/cpnonsyssolver.f new file mode 100644 index 0000000..a4d1219 --- /dev/null +++ b/dataassim/math/nonlinsystems/cpnonsyssolver.f @@ -0,0 +1,116 @@ + subroutine cpnonsyssolver(funcnleq1,fmin_funcnleq1, + & f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp, + & nunknowns,iwhichsolver) + implicit none + integer nunknowns,iwhichsolver + double precision x0min(nunknowns),x0ori(nunknowns), + & xp(nunknowns),x0max(nunknowns),fp(nunknowns) +!-------- Specified values --------------------------------------- +!funcnleq1: the subroutine that calculates the functional values of the +! the nonlinear system in the following form: +! funcnleq1(nunknowns,xp,fp,fsqsum) +!fmin_funcnleq1: the subroutine that calls funcnleq1 and returns fsqsum (half +! of the sum of the squared functional values of the nonlinear system) +! fmin_funcnleq1(nunknowns,xp,fsqsum) +!f1dim_funcnleq1: a function subroutine that returns fsqsum +! f1dim_funcnleq1(xp) +! nunknowns: The number of unknowns to be solved +! x0ori(1:nunknowns): initial guess for the unknowns +! x0min(1:nunknowns): lower bound of the solution +! x0max(1:nunknowns): upper bound of the solution +! --------- Calculated values ------------------------------------- +! fp(1:nunknowns): function values at the last step of iteration +! xp(1:nunknowns): final solutions +! iwhichsolver: +! =1 solved by plain fixed point method 1 +! =2 solved by fixed point method 2 +! =3 solved by fixed point method 3 +! =4 solved by fixed point method 4 +! =6 solved by broydn +! =7 Solved by multiobjective minimization. +! =-9999 Best approximation returned. Solution may not be accurate. +! --------- Local variables --------------------------------------- + double precision x0(nunknowns),TOLF,stpmax,scldstpmax, + & sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum, + & f1dim_funcnleq1 + integer i,irepeat,maxrepeats,IERR,notfound + intrinsic dble + parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-10) + external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1 +!------------------------------------------------------------------- + stpmax=0.0d0 + sum=0.0d0 + do i=1, nunknowns + x0(i)=x0ori(i) + sum=sum+x0ori(i)*x0ori(i) + stpmax=stpmax+ + & (x0min(i)-x0max(i))*(x0min(i)-x0max(i)) + enddo + stpmax=dsqrt(stpmax)/4.0d0 + scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns)) +! In Numerical Recipes, scldstpmax (STPMX) is 100 + scldstpmax=dmax1(100.0d0,scldstpmax) + iwhichsolver=notfound + do irepeat=1,maxrepeats + call cpfixedpoint(funcnleq1,x0min,x0,xp, + & x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver) + if(iwhichsolver.ne.notfound)return + tp=dabs(fp(1)) + xb(1)=xp(1) + do i=2,nunknowns + if(dabs(fp(i)).gt.tp)tp=dabs(fp(i)) + xb(i)=xp(i) + enddo + call cpbroydn(x0min,xb,x0max,scldstpmax,nunknowns, + & fb,funcnleq1,TOLF,IERR) + call funcnleq1(nunknowns,xb,fb,fsqsum) + tb=dabs(fb(1)) + do i=2,nunknowns + if(dabs(fb(i)).gt.tb)tb=dabs(fb(i)) + enddo + do i=1,nunknowns + if(xb(i).lt.x0min(i).or.xb(i).gt.x0max(i))then + tb=1.0d+100 + endif + enddo + if(tb.lt.tp)then + do i=1,nunknowns + xp(i)=xb(i) + fp(i)=fb(i) + enddo + if(tb.lt.TOLF)then + iwhichsolver=6 + return + endif + endif + fsqsum=0.0d0 + do i=1,nunknowns + fsqsum=fsqsum+fp(i)*fp(i) + enddo + tp=fsqsum + call cpnongradopt(nunknowns,fmin_funcnleq1, + & f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum) + if(dabs(tp-fsqsum).gt.TOLF)then + call cpRepeatCompassSearch(nunknowns,xp,fsqsum, + & x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1, + & TOLF) + endif + call funcnleq1(nunknowns,xp,fp,fsqsum) + tp=dabs(fp(1)) + do i=2,nunknowns + if(dabs(fp(i)).gt.tp)tp=dabs(fp(i)) + enddo + if(tp.lt.TOLF)then + iwhichsolver=7 + return + endif + IERR=0 + do i=1,nunknowns + if(dabs(xp(i)-x0(i)).gt.TOLF)IERR=1 + enddo + if(IERR.eq.0)return + do i=1,nunknowns + x0(i)=xp(i) + enddo + enddo + end subroutine cpnonsyssolver diff --git a/dataassim/math/nonlinsystems/cpnslasystem.h b/dataassim/math/nonlinsystems/cpnslasystem.h new file mode 100644 index 0000000..1ce8c70 --- /dev/null +++ b/dataassim/math/nonlinsystems/cpnslasystem.h @@ -0,0 +1,18 @@ +!------------------ Common Blocks ------------------------- + integer numeval,maxndim,maxeval + parameter(maxndim=1000,maxeval=15000) + double precision xevaluated,fevaluated,flargest + common /cpFuncvRegresInteg/numeval + common /cpFuncvRegresDble/xevaluated(1:maxeval,1:maxndim), + & fevaluated(1:maxeval,1:maxndim), + & flargest(1:maxeval) + save /cpFuncvRegresInteg/,/cpFuncvRegresDble/ +! numeval: the number of times that the system is evaluated so far +! iflargest: the index of the largest function for the latest evaluation +! xevaluated: the positions where the system is evaluated +! fevaluated: the function values at xevaluated +! flargest: the largest absolute function value +! maxndim: the maximum allowable dimensions of the system +! maxeval: the maximum allowable number of function evaluations + +!-------------------------------------------------------------- diff --git a/dataassim/math/nonlinsystems/fixedpoint.f b/dataassim/math/nonlinsystems/fixedpoint.f new file mode 100644 index 0000000..8147bc3 --- /dev/null +++ b/dataassim/math/nonlinsystems/fixedpoint.f @@ -0,0 +1,370 @@ + subroutine fixedpoint(funcnleq1,x0min,x0ori,xp, + & x0max,fequ,nunknowns,TOLF,stpmax,iwhichsolver) + implicit none + include 'nslasystem.h' +!-------- Inputs --------------------------------------- +! nunknowns: The number of unknowns to be solved +! x0ori(1:nunknowns): initial guess for the unknowns +! x0min(1:nunknowns): lower bound of the solution +! x0max(1:nunknowns): upper bound of the solution +! stpmax: the maximum length of the steps allowed to prevent search into +! undefined region. +! TOLF: Error tolerance +! funcnleq1: the subroutine name for the nonlinear system + integer nunknowns + double precision x0min(1:nunknowns),x0ori(1:nunknowns), + & x0max(1:nunknowns),TOLF,stpmax +! --------- Outputs ------------------------------------- +! fequ(1:nunknowns): function values at the last step of iteration +! xp(1:nunknowns): final solutions or solutions not worse than x0ori +! iwhichsolver: =0,1,2,3,4 successful +! =-9999 failed, best solution returned + integer iwhichsolver + double precision fequ(1:nunknowns),xp(1:nunknowns) +! ---------Local variables -------------------------------- + integer i,j,k,n,maxiter,notfound,ncount,ierr, + & ismallest,iGuCall + double precision swap,x1,x2,f1,f2,fsqsumold, + & fsqsumnew,xpold(nunknowns),fequold(nunknowns), + & gfuncsum(nunknowns),deltax(nunknowns), + & xpder(nunknowns),fjacob(nunknowns,nunknowns), + & fjacobcopy(nunknowns,nunknowns),fsqsum,term + logical check + parameter(maxiter=200,notfound=-9999,iGuCall=49) + integer iselect(300*maxiter) + logical resetran2 + common /ran2reset/resetran2 + save /ran2reset/ + external funcnleq1 +!----------------------------------------------------------- + resetran2=.true. + do i=1,nunknowns + xp(i)=x0ori(i) + enddo + iwhichsolver=notfound + numeval=0 +!-------------------------------------------------------------- +!Plain fixed-point method. Fixed-point method 1 + do i=1,maxiter + call funcnleq1(nunknowns,xp,fequ,fsqsum) + call bookkeeping(nunknowns,xp,fequ,iGuCall,k) + if(dabs(fequ(k)).lt.TOLF)then + iwhichsolver=1 + return + endif + do j=1,nunknowns + xp(j)=xp(j)-fequ(j) + if(xp(j).lt.x0min(j).or.xp(j).gt.x0max(j))then + call reinitialization(x0min(j),x0ori(j), + & x0max(j),xp(j),50000) + endif + enddo + enddo +!_____________________________________________________________________ +!try approximation to the newton method, iwhichsolver=0. this would work +!if the equations are independent +1 do i=1,nunknowns + xp(i)=x0ori(i) + enddo + do i=1,maxiter + call funcnleq1(nunknowns,xp,fequ,fsqsum) + n=0 + do j=1,nunknowns + if(dabs(fequ(j)).gt.0.0d0)then + else + n=1 + call reinitialization(x0min(j),x0ori(j), + & x0max(j),xp(j),50000) + endif + enddo + if(n.ne.0)goto 2 + call bookkeeping(nunknowns,xp,fequ,iGuCall,k) + if(dabs(fequ(k)).lt.TOLF)then + iwhichsolver=0 + return + endif + do j=1,nunknowns + xpold(j)=xp(j) + fequold(j)=fequ(j) + xp(j)=xp(j)+fequ(j) + enddo + call funcnleq1(nunknowns,xp,fequ,fsqsum) + do j=1,nunknowns + if(dabs(fequ(j)).gt.0.0d0)then + else + n=1 + call reinitialization(x0min(j),x0ori(j), + & x0max(j),xp(j),50000) + endif + enddo + if(n.ne.0)goto 2 + call bookkeeping(nunknowns,xp,fequ,iGuCall,k) + do j=1,nunknowns + if(fequ(j).ne.fequold(j))then + xpder(j)=fequold(j)/(fequ(j)-fequold(j)) + else + xpder(j)=0.0d0 + endif + xp(j)=xpold(j)-xpder(j)*fequold(j) + if(xp(j).lt.x0min(j).or.xp(j).gt.x0max(j))then + call reinitialization(x0min(j),x0ori(j), + & x0max(j),xp(j),50000) + endif + enddo +2 continue + enddo +!_____________________________________________________________________ +!try fixed-point method 2 + do j=1,nunknowns + call reinitialization(x0min(j),x0ori(j), + & x0max(j),xp(j),10000) + enddo + call funcnleq1(nunknowns,xp,fequ,fsqsum) + call bookkeeping(nunknowns,xp,fequ,iGuCall,k) + do i=1,nunknowns + xp(i)=xp(i)-fequ(i) + if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),2000) + endif + enddo + do i=1,maxiter + call funcnleq1(nunknowns,xp,fequ,fsqsum) + call bookkeeping(nunknowns,xp,fequ,iGuCall,k) + if(dabs(fequ(k)).lt.TOLF)then + iwhichsolver=2 + return + endif + do j=1,nunknowns + ierr=0 + x1=xevaluated(numeval-1,j) + f1=x1-fevaluated(numeval-1,j) + x2=xevaluated(numeval,j) + f2=x2-fevaluated(numeval,j) + if(dabs(f2-f1-x2+x1).gt.1.0d-20)then + ierr=1 + xp(j)=(x1*(f2-f1)-f1*(x2-x1))/ + & (f2-f1-x2+x1) + if(xp(j).le.x0min(j).or.xp(j) + & .ge.x0max(j))then + ierr=0 + endif + endif + if(ierr.le.0.and.numeval.ge.3)then +! haven't found a usable new point yet, first try the opposite sign point + ncount=0 + do k=1,numeval-2 + if((fevaluated(k,j)*fevaluated(numeval,j)) + & .lt.0.0d0)then + ncount=ncount+1 + iselect(ncount)=k + endif + enddo + if(ncount.gt.0)then +! there are points at different sides of the zero. + ismallest=1 + do k=2,ncount + if(dabs(xevaluated(iselect(k),j)-x2).lt. + & dabs(xevaluated(iselect(ismallest),j)-x2))then + ismallest=k + endif + enddo + ierr=1 + x1=xevaluated(iselect(ismallest),j) + f1=x1-fevaluated(iselect(ismallest),j) + xp(j)=(x1*(f2-f1)-f1*(x2-x1))/ + & (f2-f1-x2+x1) + else +! all at the same sides of the zero. + do k=1,numeval-2 + x1=xevaluated(k,j) + f1=x1-fevaluated(k,j) + if(dabs(f2-f1-x2+x1).gt.1.0d-10)then + xp(j)=(x1*(f2-f1)-f1*(x2-x1))/ + & (f2-f1-x2+x1) + if(xp(j).gt.x0min(j).and.xp(j).lt.x0max(j))then + ierr=1 + endif + endif + if(ierr.eq.1)goto 10 + enddo +10 continue + endif + endif + if(ierr.eq.0)then + call reinitialization(x0min(j), + & xevaluated(numeval,j),x0max(j),xp(j),1000) + endif + enddo + ierr=0 + do k=1,nunknowns + if(xp(k).ne.xevaluated(numeval,k))ierr=1 + enddo + if(ierr.eq.0)then + do k=1,nunknowns + call reinitialization(x0min(k), + & xevaluated(numeval,k),x0max(k),xp(k),25000) + enddo + endif + enddo +!__________________________________________________________________ +!Try fixed-point method 3 + do i=1,nunknowns + xp(i)=x0ori(i)+1.0d-6 + if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),250910) + endif + enddo + do j=1,maxiter + call funcnleq1(nunknowns,xp,fequ,fsqsum) + call bookkeeping(nunknowns,xp,fequ,iGuCall,k) + if(dabs(fequ(k)).lt.TOLF)then + iwhichsolver=3 + return + endif + do i=1,nunknowns + xp(i)=xp(i)-fequ(i) + if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),25500) + endif + enddo + call funcnleq1(nunknowns,xp,fequ,fsqsum) + call bookkeeping(nunknowns,xp,fequ,iGuCall,k) + if(dabs(fequ(k)).lt.TOLF)then + iwhichsolver=3 + return + endif + do i=1,nunknowns + if(fevaluated(numeval,i).eq. + & fevaluated(numeval-1,i))then + x1=(xevaluated(numeval,i)+ + & xevaluated(numeval-1,i))/2.0d0 + call reinitialization(x0min(i),x1, + & x0max(i),xp(i),35678) + else + xp(i)=(xevaluated(numeval,i)*fevaluated(numeval-1,i) + & -xevaluated(numeval-1,i)*fevaluated(numeval,i))/ + & (fevaluated(numeval-1,i)-fevaluated(numeval,i)) + if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),45678) + endif + endif + enddo + enddo +!------------------------------------------------------------ +!Try fixed-point method 4 + +!11 call funcnleq1(nunknowns,xp,fequ,fsqsumold) +! call bookkeeping(nunknowns,xp,fequ,iGuCall,i) + + fsqsumold=0.0d0 + do i=1,nunknowns + xpold(i)=xevaluated(numeval,i) + fequold(i)=fevaluated(numeval,i) + fsqsumold=fsqsumold+fequold(i)*fequold(i) + enddo + term=fsqsumold + do k=1,maxiter/5 + do j=1,nunknowns + do i=1,nunknowns + xpder(i)=xpold(i) + enddo + if(dabs(fequold(j)).lt.1.0d-10)then + xpder(j)=xpold(j)+1.0d-5 + else + xpder(j)=xpold(j)-fequold(j) + endif + if(xpder(j).lt.x0min(j).or.xpder(j). + & gt.x0max(j))then + call reinitialization(x0min(j),xpold(j), + & x0max(j),xpder(j),89000) + endif + call funcnleq1(nunknowns,xpder,fequ,fsqsumnew) + call bookkeeping(nunknowns,xpder,fequ,iGuCall,i) + if(dabs(fequ(i)).lt.TOLF)then + iwhichsolver=4 + return + endif + do i=1,nunknowns + fjacob(i,j)=(fequ(i)-fequold(i))/ + & (xpder(j)-xpold(j)) + fjacobcopy(i,j)=fjacob(i,j) + enddo + gfuncsum(j)=(fsqsumnew-fsqsumold)/ + & (xpder(j)-xpold(j)) + enddo + call xmprove(nunknowns,nunknowns, + & fjacob,fequold,deltax,ierr) +!if ierr = 0, matrix is singular. ierr = 1, everything is ok. + if(ierr.eq.0)then + call adsor(fjacobcopy,nunknowns,nunknowns, + & fequold,deltax,ierr) + if(ierr.ne.1)ierr=0 + endif + if(ierr.ne.0)then + do i=1,nunknowns + deltax(i)=-deltax(i) + enddo + call lnsrch(nunknowns,xpold,fsqsumold, + & gfuncsum,deltax,xp,fsqsumnew,stpmax, + & check,funcnleq1,fequ) + if(check.eq..true..or.check.eq..TRUE.)then + do i=1,nunknowns + call reinitialization(x0min(i),xpold(i), + & x0max(i),xp(i),6678) + enddo + endif + do i=1,nunknowns + if(xp(i).lt.x0min(i).or.xp(i).gt.x0max(i))then + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),678) + endif + enddo + else + do i=1,nunknowns + call reinitialization(x0min(i),x0ori(i), + & x0max(i),xp(i),75678) + enddo + endif + call funcnleq1(nunknowns,xp,fequ,fsqsumold) + call bookkeeping(nunknowns,xp,fequ,iGuCall,i) + if(dabs(fequ(i)).lt.TOLF)then + iwhichsolver=4 + return + endif + do i=1,nunknowns + xpold(i)=xp(i) + fequold(i)=fequ(i) + enddo + if(fsqsumold.ge.term)goto 30 + term=fsqsumold + enddo +!_____________________________________________________________ +!If all four methods failed, choose the best xp +30 do i=1,numeval + do k=i+1,numeval + if(flargest(k).lt.flargest(i))then + swap=flargest(k) + flargest(k)=flargest(i) + flargest(i)=swap + do ncount=1,nunknowns + swap=xevaluated(k,ncount) + xevaluated(k,ncount)=xevaluated(i,ncount) + xevaluated(i,ncount)=swap + swap=fevaluated(k,ncount) + fevaluated(k,ncount)=fevaluated(i,ncount) + fevaluated(i,ncount)=swap + enddo + endif + enddo + enddo +! Best solution found so far + do i=1,nunknowns + xp(i)=xevaluated(1,i) + fequ(i)=fevaluated(1,i) + enddo + return + end subroutine fixedpoint diff --git a/dataassim/math/nonlinsystems/nonsyssolver.f b/dataassim/math/nonlinsystems/nonsyssolver.f new file mode 100644 index 0000000..6bd2d78 --- /dev/null +++ b/dataassim/math/nonlinsystems/nonsyssolver.f @@ -0,0 +1,115 @@ + subroutine nonsyssolver(funcnleq1,fmin_funcnleq1, + & f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp, + & nunknowns,iwhichsolver) + implicit none + integer nunknowns,iwhichsolver + double precision x0min(nunknowns),x0ori(nunknowns), + & xp(nunknowns),x0max(nunknowns),fp(nunknowns) +!-------- Specified values --------------------------------------- +!funcnleq1: the subroutine that calculates the functional values of the +! the nonlinear system in the following form: +! funcnleq1(nunknowns,xp,fp,fsqsum) +!fmin_funcnleq1: the subroutine that calls funcnleq1 and returns fsqsum +! fmin_funcnleq1(nunknowns,xp,fsqsum) +!f1dim_funcnleq1: a function subroutine that returns fsqsum +! f1dim_funcnleq1(xp) +! nunknowns: The number of unknowns to be solved +! x0ori(1:nunknowns): initial guess for the unknowns +! x0min(1:nunknowns): lower bound of the solution +! x0max(1:nunknowns): upper bound of the solution +! --------- Calculated values ------------------------------------- +! fp(1:nunknowns): function values at the last step of iteration +! xp(1:nunknowns): final solutions +! iwhichsolver: +! =1 solved by plain fixed point method 1 +! =2 solved by fixed point method 2 +! =3 solved by fixed point method 3 +! =4 solved by fixed point method 4 +! =6 solved by broydn +! =7 Solved by multiobjective minimization. +! =-9999 Best approximation returned. Solution may not be accurate. +! --------- Local variables --------------------------------------- + double precision x0(nunknowns),TOLF,stpmax,scldstpmax, + & sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum, + & f1dim_funcnleq1 + integer i,irepeat,maxrepeats,IERR,notfound + intrinsic dble + parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-7) + external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1 +!------------------------------------------------------------------- + stpmax=0.0d0 + sum=0.0d0 + do i=1, nunknowns + x0(i)=x0ori(i) + sum=sum+x0ori(i)*x0ori(i) + stpmax=stpmax+ + & (x0min(i)-x0max(i))*(x0min(i)-x0max(i)) + enddo + stpmax=dsqrt(stpmax)/4.0d0 + scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns)) +! In Numerical Recipes, scldstpmax (STPMX) is 100 + scldstpmax=dmax1(100.0d0,scldstpmax) + iwhichsolver=notfound + do irepeat=1,maxrepeats + call fixedpoint(funcnleq1,x0min,x0,xp, + & x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver) + if(iwhichsolver.ne.notfound)return + tp=dabs(fp(1)) + xb(1)=xp(1) + do i=2,nunknowns + if(dabs(fp(i)).gt.tp)tp=dabs(fp(i)) + xb(i)=xp(i) + enddo + call broydn(x0min,xb,x0max,scldstpmax,nunknowns, + & fb,funcnleq1,TOLF,IERR) + call funcnleq1(nunknowns,xb,fb,fsqsum) + tb=dabs(fb(1)) + do i=2,nunknowns + if(dabs(fb(i)).gt.tb)tb=dabs(fb(i)) + enddo + do i=1,nunknowns + if(xb(i).lt.x0min(i).or.xb(i).gt.x0max(i))then + tb=1.0d+100 + endif + enddo + if(tb.lt.tp)then + do i=1,nunknowns + xp(i)=xb(i) + fp(i)=fb(i) + enddo + if(tb.lt.TOLF)then + iwhichsolver=6 + return + endif + endif + fsqsum=0.0d0 + do i=1,nunknowns + fsqsum=fsqsum+fp(i)*fp(i) + enddo + tp=fsqsum + call nongradopt(nunknowns,fmin_funcnleq1, + & f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum) +! if(dabs(tp-fsqsum).gt.TOLF)then +! call RepeatCompassSearch(nunknowns,xp,fsqsum, +! & x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1, +! & TOLF) +! endif + call funcnleq1(nunknowns,xp,fp,fsqsum) + tp=dabs(fp(1)) + do i=2,nunknowns + if(dabs(fp(i)).gt.tp)tp=dabs(fp(i)) + enddo + if(tp.lt.TOLF)then + iwhichsolver=7 + return + endif + IERR=0 + do i=1,nunknowns + if(dabs(xp(i)-x0(i)).gt.TOLF)IERR=1 + enddo + if(IERR.eq.0)return + do i=1,nunknowns + x0(i)=xp(i) + enddo + enddo + end subroutine nonsyssolver diff --git a/dataassim/math/nonlinsystems/nslasystem.h b/dataassim/math/nonlinsystems/nslasystem.h new file mode 100644 index 0000000..4443aff --- /dev/null +++ b/dataassim/math/nonlinsystems/nslasystem.h @@ -0,0 +1,18 @@ +!------------------ Common Blocks ------------------------- + integer numeval,maxndim,maxeval + parameter(maxndim=1000,maxeval=15000) + double precision xevaluated,fevaluated,flargest + common /FuncvRegresInteg/numeval + common /FuncvRegresDble/xevaluated(1:maxeval,1:maxndim), + & fevaluated(1:maxeval,1:maxndim), + & flargest(1:maxeval) + save /FuncvRegresInteg/,/FuncvRegresDble/ +! numeval: the number of times that the system is evaluated so far +! iflargest: the index of the largest function for the latest evaluation +! xevaluated: the positions where the system is evaluated +! fevaluated: the function values at xevaluated +! flargest: the largest absolute function value +! maxndim: the maximum allowable dimensions of the system +! maxeval: the maximum allowable number of function evaluations + +!-------------------------------------------------------------- diff --git a/dataassim/math/nonlinsystems/testexample.f b/dataassim/math/nonlinsystems/testexample.f new file mode 100644 index 0000000..5fd9a7f --- /dev/null +++ b/dataassim/math/nonlinsystems/testexample.f @@ -0,0 +1,85 @@ + program test + implicit none + integer nunknowns,iwhichsolver,i,j + double precision x0min(11),x0ori(11),xp(11), + & x0max(11),fequ(11),f1dim_funcsys + external funcsys,fsqsum_funcsys,f1dim_funcsys + + nunknowns=11 + do i=1,nunknowns + x0min(i)=-0.00001d0 + x0ori(i)=1.0d0 + x0max(i)=100.0d0 + enddo + nunknowns=2 + x0ori(1)=0.0d0 + x0ori(2)=3.0d0 + call nonsyssolver(funcsys,fsqsum_funcsys, + & f1dim_funcsys,x0min,x0ori,xp,x0max, + & fequ,nunknowns,iwhichsolver) + do i=1,nunknowns + write(*,*)fequ(i),xp(i),iwhichsolver + enddo + end + + subroutine funcsys(nunknowns,x,f,fsqsum) + implicit none + integer nunknowns,i + double precision x(nunknowns),f(nunknowns), + & fsqsum + double precision R,p,K5,K6,K7,K8,K9,K10 + parameter(R=10.0d0,p=40.0d0, + & K5=1.0d0,K6=1.0d0, + & K7=1.0d0,K8=0.1d0, + & K9=1.0d0,K10=0.1d0) + + f(1)=x(1)-(1.0d0+0.5d0*dsin(x(1))) + f(2)=x(2)-(3.0d0+2.0d0*dsin(x(2))) + +! Combustion of propane problem +! f(1)=x(1)-(3.0d0-x(4)) +! f(2)=x(2)-(R-2.0d0*x(1)-x(4)-x(7)- +! & x(8)-x(9)-2.0d0*x(10)) +! f(3)=x(3)-(2.0d0*R-0.5d0*x(9)) +! f(4)=x(4)-x(1)*x(5)/(K5*x(2)) +! f(5)=x(5)-(4-x(2)-0.5d0*x(6)-0.5d0*x(7)) +! f(6)=x(6)-K6*dsqrt(x(2)*x(4)*x(11)/(p*x(1))) +! f(7)=x(7)-K7*dsqrt(x(1)*x(2)*x(11)/(p*x(4))) +! f(8)=x(8)-K8*x(1)*x(11)/(p*x(4)) +! f(9)=x(9)-K9*(x(1)/x(4))*dsqrt(x(3)*x(11)/p) +! f(10)=x(10)-K10*x(1)*x(1)*x(11)/(p*x(4)*x(4)) +! f(11)=x(11)-(x(1)+x(2)+x(3)+x(4)+x(5)+x(6) +! & +x(7)+x(8)+x(9)+x(10)) + fsqsum=0.0d0 + do i=1,nunknowns + fsqsum=fsqsum+f(i)*f(i) + enddo + fsqsum=0.5d0*fsqsum + return + end + + subroutine fsqsum_funcsys(nunknowns,xp,fsqsum) + implicit none + integer nunknowns + double precision xp(nunknowns),fsqsum, + & fequ(nunknowns) + call funcsys(nunknowns,xp,fequ,fsqsum) + return + end + + double precision function f1dim_funcsys(x) + INTEGER NMAX + double precision x + PARAMETER (NMAX=1000) +CU USES funcsys + INTEGER j,ncom + double precision pcom(NMAX),xicom(NMAX), + & xt(NMAX),fequ(NMAX) + COMMON /f1com/ pcom,xicom,ncom + save /f1com/ + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call funcsys(ncom,xt,fequ,f1dim_funcsys) + return + END diff --git a/dataassim/math/numrec/f77_sources.tar.gz b/dataassim/math/numrec/f77_sources.tar.gz new file mode 100644 index 0000000..fc630a3 Binary files /dev/null and b/dataassim/math/numrec/f77_sources.tar.gz differ diff --git a/dataassim/math/numrec/f77_sources/addint.for b/dataassim/math/numrec/f77_sources/addint.for new file mode 100644 index 0000000..bc815a9 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/addint.for @@ -0,0 +1,13 @@ + SUBROUTINE addint(uf,uc,res,nf) + INTEGER nf + DOUBLE PRECISION res(nf,nf),uc(nf/2+1,nf/2+1),uf(nf,nf) +CU USES interp + INTEGER i,j + call interp(res,uc,nf) + do 12 j=1,nf + do 11 i=1,nf + uf(i,j)=uf(i,j)+res(i,j) +11 continue +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/airy.for b/dataassim/math/numrec/f77_sources/airy.for new file mode 100644 index 0000000..a3463de --- /dev/null +++ b/dataassim/math/numrec/f77_sources/airy.for @@ -0,0 +1,32 @@ + SUBROUTINE airy(x,ai,bi,aip,bip) + REAL ai,aip,bi,bip,x +CU USES bessik,bessjy + REAL absx,ri,rip,rj,rjp,rk,rkp,rootx,ry,ryp,z,PI,THIRD,TWOTHR, + *ONOVRT + PARAMETER (PI=3.1415927,THIRD=1./3.,TWOTHR=2.*THIRD, + *ONOVRT=.57735027) + absx=abs(x) + rootx=sqrt(absx) + z=TWOTHR*absx*rootx + if(x.gt.0.)then + call bessik(z,THIRD,ri,rk,rip,rkp) + ai=rootx*ONOVRT*rk/PI + bi=rootx*(rk/PI+2.*ONOVRT*ri) + call bessik(z,TWOTHR,ri,rk,rip,rkp) + aip=-x*ONOVRT*rk/PI + bip=x*(rk/PI+2.*ONOVRT*ri) + else if(x.lt.0.)then + call bessjy(z,THIRD,rj,ry,rjp,ryp) + ai=.5*rootx*(rj-ONOVRT*ry) + bi=-.5*rootx*(ry+ONOVRT*rj) + call bessjy(z,TWOTHR,rj,ry,rjp,ryp) + aip=.5*absx*(ONOVRT*ry+rj) + bip=.5*absx*(ONOVRT*rj-ry) + else + ai=.35502805 + bi=ai/ONOVRT + aip=-.25881940 + bip=-aip/ONOVRT + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/amebsa.for b/dataassim/math/numrec/f77_sources/amebsa.for new file mode 100644 index 0000000..519821b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/amebsa.for @@ -0,0 +1,85 @@ + SUBROUTINE amebsa(p,y,mp,np,ndim,pb,yb,ftol,funk,iter,temptr) + INTEGER iter,mp,ndim,np,NMAX + REAL ftol,temptr,yb,p(mp,np),pb(np),y(mp),funk + PARAMETER (NMAX=200) + EXTERNAL funk +CU USES amotsa,funk,ran1 + INTEGER i,idum,ihi,ilo,inhi,j,m,n + REAL rtol,sum,swap,tt,yhi,ylo,ynhi,ysave,yt,ytry,psum(NMAX), + *amotsa,ran1 + COMMON /ambsa/ tt,idum + tt=-temptr +1 do 12 n=1,ndim + sum=0. + do 11 m=1,ndim+1 + sum=sum+p(m,n) +11 continue + psum(n)=sum +12 continue +2 ilo=1 + inhi=1 + ihi=2 + ylo=y(1)+tt*log(ran1(idum)) + ynhi=ylo + yhi=y(2)+tt*log(ran1(idum)) + if (ylo.gt.yhi) then + ihi=1 + inhi=2 + ilo=2 + ynhi=yhi + yhi=ylo + ylo=ynhi + endif + do 13 i=3,ndim+1 + yt=y(i)+tt*log(ran1(idum)) + if(yt.le.ylo) then + ilo=i + ylo=yt + endif + if(yt.gt.yhi) then + inhi=ihi + ynhi=yhi + ihi=i + yhi=yt + else if(yt.gt.ynhi) then + inhi=i + ynhi=yt + endif +13 continue + rtol=2.*abs(yhi-ylo)/(abs(yhi)+abs(ylo)) + if (rtol.lt.ftol.or.iter.lt.0) then + swap=y(1) + y(1)=y(ilo) + y(ilo)=swap + do 14 n=1,ndim + swap=p(1,n) + p(1,n)=p(ilo,n) + p(ilo,n)=swap +14 continue + return + endif + iter=iter-2 + ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,-1.0) + if (ytry.le.ylo) then + ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,2.0) + else if (ytry.ge.ynhi) then + ysave=yhi + ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,0.5) + if (ytry.ge.ysave) then + do 16 i=1,ndim+1 + if(i.ne.ilo)then + do 15 j=1,ndim + psum(j)=0.5*(p(i,j)+p(ilo,j)) + p(i,j)=psum(j) +15 continue + y(i)=funk(psum) + endif +16 continue + iter=iter-ndim + goto 1 + endif + else + iter=iter+1 + endif + goto 2 + END diff --git a/dataassim/math/numrec/f77_sources/amoeba.for b/dataassim/math/numrec/f77_sources/amoeba.for new file mode 100644 index 0000000..0b29eac --- /dev/null +++ b/dataassim/math/numrec/f77_sources/amoeba.for @@ -0,0 +1,71 @@ + SUBROUTINE amoeba(p,y,mp,np,ndim,ftol,funk,iter) + INTEGER iter,mp,ndim,np,NMAX,ITMAX + REAL ftol,p(mp,np),y(mp),funk + PARAMETER (NMAX=20,ITMAX=5000) + EXTERNAL funk +CU USES amotry,funk + INTEGER i,ihi,ilo,inhi,j,m,n + REAL rtol,sum,swap,ysave,ytry,psum(NMAX),amotry + iter=0 +1 do 12 n=1,ndim + sum=0. + do 11 m=1,ndim+1 + sum=sum+p(m,n) +11 continue + psum(n)=sum +12 continue +2 ilo=1 + if (y(1).gt.y(2)) then + ihi=1 + inhi=2 + else + ihi=2 + inhi=1 + endif + do 13 i=1,ndim+1 + if(y(i).le.y(ilo)) ilo=i + if(y(i).gt.y(ihi)) then + inhi=ihi + ihi=i + else if(y(i).gt.y(inhi)) then + if(i.ne.ihi) inhi=i + endif +13 continue + rtol=2.*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo))) + if (rtol.lt.ftol) then + swap=y(1) + y(1)=y(ilo) + y(ilo)=swap + do 14 n=1,ndim + swap=p(1,n) + p(1,n)=p(ilo,n) + p(ilo,n)=swap +14 continue + return + endif + if (iter.ge.ITMAX) pause 'ITMAX exceeded in amoeba' + iter=iter+2 + ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,-1.0) + if (ytry.le.y(ilo)) then + ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,2.0) + else if (ytry.ge.y(inhi)) then + ysave=y(ihi) + ytry=amotry(p,y,psum,mp,np,ndim,funk,ihi,0.5) + if (ytry.ge.ysave) then + do 16 i=1,ndim+1 + if(i.ne.ilo)then + do 15 j=1,ndim + psum(j)=0.5*(p(i,j)+p(ilo,j)) + p(i,j)=psum(j) +15 continue + y(i)=funk(psum) + endif +16 continue + iter=iter+ndim + goto 1 + endif + else + iter=iter-1 + endif + goto 2 + END diff --git a/dataassim/math/numrec/f77_sources/amotry.for b/dataassim/math/numrec/f77_sources/amotry.for new file mode 100644 index 0000000..facaf47 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/amotry.for @@ -0,0 +1,24 @@ + FUNCTION amotry(p,y,psum,mp,np,ndim,funk,ihi,fac) + INTEGER ihi,mp,ndim,np,NMAX + REAL amotry,fac,p(mp,np),psum(np),y(mp),funk + PARAMETER (NMAX=20) + EXTERNAL funk +CU USES funk + INTEGER j + REAL fac1,fac2,ytry,ptry(NMAX) + fac1=(1.-fac)/ndim + fac2=fac1-fac + do 11 j=1,ndim + ptry(j)=psum(j)*fac1-p(ihi,j)*fac2 +11 continue + ytry=funk(ptry) + if (ytry.lt.y(ihi)) then + y(ihi)=ytry + do 12 j=1,ndim + psum(j)=psum(j)-p(ihi,j)+ptry(j) + p(ihi,j)=ptry(j) +12 continue + endif + amotry=ytry + return + END diff --git a/dataassim/math/numrec/f77_sources/amotsa.for b/dataassim/math/numrec/f77_sources/amotsa.for new file mode 100644 index 0000000..9e87889 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/amotsa.for @@ -0,0 +1,33 @@ + FUNCTION amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,fac) + INTEGER ihi,mp,ndim,np,NMAX + REAL amotsa,fac,yb,yhi,p(mp,np),pb(np),psum(np),y(mp),funk + PARAMETER (NMAX=200) + EXTERNAL funk +CU USES funk,ran1 + INTEGER idum,j + REAL fac1,fac2,tt,yflu,ytry,ptry(NMAX),ran1 + COMMON /ambsa/ tt,idum + fac1=(1.-fac)/ndim + fac2=fac1-fac + do 11 j=1,ndim + ptry(j)=psum(j)*fac1-p(ihi,j)*fac2 +11 continue + ytry=funk(ptry) + if (ytry.le.yb) then + do 12 j=1,ndim + pb(j)=ptry(j) +12 continue + yb=ytry + endif + yflu=ytry-tt*log(ran1(idum)) + if (yflu.lt.yhi) then + y(ihi)=ytry + yhi=yflu + do 13 j=1,ndim + psum(j)=psum(j)-p(ihi,j)+ptry(j) + p(ihi,j)=ptry(j) +13 continue + endif + amotsa=yflu + return + END diff --git a/dataassim/math/numrec/f77_sources/anneal.for b/dataassim/math/numrec/f77_sources/anneal.for new file mode 100644 index 0000000..7838335 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/anneal.for @@ -0,0 +1,62 @@ + SUBROUTINE anneal(x,y,iorder,ncity) + INTEGER ncity,iorder(ncity) + REAL x(ncity),y(ncity) +CU USES irbit1,metrop,ran3,revcst,revers,trncst,trnspt + INTEGER i,i1,i2,idec,idum,iseed,j,k,nlimit,nn,nover,nsucc,n(6), + *irbit1 + REAL de,path,t,tfactr,ran3,alen,x1,x2,y1,y2 + LOGICAL ans + alen(x1,x2,y1,y2)=sqrt((x2-x1)**2+(y2-y1)**2) + nover=100*ncity + nlimit=10*ncity + tfactr=0.9 + path=0.0 + t=0.5 + do 11 i=1,ncity-1 + i1=iorder(i) + i2=iorder(i+1) + path=path+alen(x(i1),x(i2),y(i1),y(i2)) +11 continue + i1=iorder(ncity) + i2=iorder(1) + path=path+alen(x(i1),x(i2),y(i1),y(i2)) + idum=-1 + iseed=111 + do 13 j=1,100 + nsucc=0 + do 12 k=1,nover +1 n(1)=1+int(ncity*ran3(idum)) + n(2)=1+int((ncity-1)*ran3(idum)) + if (n(2).ge.n(1)) n(2)=n(2)+1 + nn=1+mod((n(1)-n(2)+ncity-1),ncity) + if (nn.lt.3) goto 1 + idec=irbit1(iseed) + if (idec.eq.0) then + n(3)=n(2)+int(abs(nn-2)*ran3(idum))+1 + n(3)=1+mod(n(3)-1,ncity) + call trncst(x,y,iorder,ncity,n,de) + call metrop(de,t,ans) + if (ans) then + nsucc=nsucc+1 + path=path+de + call trnspt(iorder,ncity,n) + endif + else + call revcst(x,y,iorder,ncity,n,de) + call metrop(de,t,ans) + if (ans) then + nsucc=nsucc+1 + path=path+de + call revers(iorder,ncity,n) + endif + endif + if (nsucc.ge.nlimit) goto 2 +12 continue +2 write(*,*) + write(*,*) 'T =',t,' Path Length =',path + write(*,*) 'Successful Moves: ',nsucc + t=t*tfactr + if (nsucc.eq.0) return +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/anorm2.for b/dataassim/math/numrec/f77_sources/anorm2.for new file mode 100644 index 0000000..749d7fe --- /dev/null +++ b/dataassim/math/numrec/f77_sources/anorm2.for @@ -0,0 +1,14 @@ + DOUBLE PRECISION FUNCTION anorm2(a,n) + INTEGER n + DOUBLE PRECISION a(n,n) + INTEGER i,j + DOUBLE PRECISION sum + sum=0.d0 + do 12 j=1,n + do 11 i=1,n + sum=sum+a(i,j)**2 +11 continue +12 continue + anorm2=sqrt(sum)/n + return + END diff --git a/dataassim/math/numrec/f77_sources/arcmak.for b/dataassim/math/numrec/f77_sources/arcmak.for new file mode 100644 index 0000000..ab651ae --- /dev/null +++ b/dataassim/math/numrec/f77_sources/arcmak.for @@ -0,0 +1,20 @@ + SUBROUTINE arcmak(nfreq,nchh,nradd) + INTEGER nchh,nradd,nfreq(nchh),MC,NWK,MAXINT + PARAMETER (MC=512,NWK=20,MAXINT=2147483647) + INTEGER j,jdif,minint,nc,nch,nrad,ncum,ncumfq(MC+2),ilob(NWK), + *iupb(NWK) + COMMON /arccom/ ncumfq,iupb,ilob,nch,nrad,minint,jdif,nc,ncum + SAVE /arccom/ + if(nchh.gt.MC)pause 'MC too small in arcmak' + if(nradd.gt.256)pause 'nradd may not exceed 256 in arcmak' + minint=MAXINT/nradd + nch=nchh + nrad=nradd + ncumfq(1)=0 + do 11 j=2,nch+1 + ncumfq(j)=ncumfq(j-1)+max(nfreq(j-1),1) +11 continue + ncumfq(nch+2)=ncumfq(nch+1)+1 + ncum=ncumfq(nch+2) + return + END diff --git a/dataassim/math/numrec/f77_sources/arcode.for b/dataassim/math/numrec/f77_sources/arcode.for new file mode 100644 index 0000000..6a11b45 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/arcode.for @@ -0,0 +1,75 @@ + SUBROUTINE arcode(ich,code,lcode,lcd,isign) + INTEGER ich,isign,lcd,lcode,MC,NWK + CHARACTER*1 code(lcode) + PARAMETER (MC=512,NWK=20) +CU USES arcsum + INTEGER ihi,j,ja,jdif,jh,jl,k,m,minint,nc,nch,nrad,ilob(NWK), + *iupb(NWK),ncumfq(MC+2),ncum,JTRY + COMMON /arccom/ ncumfq,iupb,ilob,nch,nrad,minint,jdif,nc,ncum + SAVE /arccom/ + JTRY(j,k,m)=int((dble(k)*dble(j))/dble(m)) + if (isign.eq.0) then + jdif=nrad-1 + do 11 j=NWK,1,-1 + iupb(j)=nrad-1 + ilob(j)=0 + nc=j + if(jdif.gt.minint)return + jdif=(jdif+1)*nrad-1 +11 continue + pause 'NWK too small in arcode' + else + if (isign.gt.0) then + if(ich.gt.nch.or.ich.lt.0)pause 'bad ich in arcode' + else + ja=ichar(code(lcd))-ilob(nc) + do 12 j=nc+1,NWK + ja=ja*nrad+(ichar(code(j+lcd-nc))-ilob(j)) +12 continue + ich=0 + ihi=nch+1 +1 if(ihi-ich.gt.1) then + m=(ich+ihi)/2 + if (ja.ge.JTRY(jdif,ncumfq(m+1),ncum)) then + ich=m + else + ihi=m + endif + goto 1 + endif + if(ich.eq.nch)return + endif + jh=JTRY(jdif,ncumfq(ich+2),ncum) + jl=JTRY(jdif,ncumfq(ich+1),ncum) + jdif=jh-jl + call arcsum(ilob,iupb,jh,NWK,nrad,nc) + call arcsum(ilob,ilob,jl,NWK,nrad,nc) + do 13 j=nc,NWK + if(ich.ne.nch.and.iupb(j).ne.ilob(j))goto 2 + if(lcd.gt.lcode)pause 'lcode too small in arcode' + if(isign.gt.0) code(lcd)=char(ilob(j)) + lcd=lcd+1 +13 continue + return +2 nc=j + j=0 +3 if (jdif.lt.minint) then + j=j+1 + jdif=jdif*nrad + goto 3 + endif + if (nc-j.lt.1) pause 'NWK too small in arcode' + if(j.ne.0)then + do 14 k=nc,NWK + iupb(k-j)=iupb(k) + ilob(k-j)=ilob(k) +14 continue + endif + nc=nc-j + do 15 k=NWK-j+1,NWK + iupb(k)=0 + ilob(k)=0 +15 continue + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/arcsum.for b/dataassim/math/numrec/f77_sources/arcsum.for new file mode 100644 index 0000000..7ef7059 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/arcsum.for @@ -0,0 +1,18 @@ + SUBROUTINE arcsum(iin,iout,ja,nwk,nrad,nc) + INTEGER ja,nc,nrad,nwk,iin(*),iout(*) + INTEGER j,jtmp,karry + karry=0 + do 11 j=nwk,nc+1,-1 + jtmp=ja + ja=ja/nrad + iout(j)=iin(j)+(jtmp-ja*nrad)+karry + if (iout(j).ge.nrad) then + iout(j)=iout(j)-nrad + karry=1 + else + karry=0 + endif +11 continue + iout(nc)=iin(nc)+ja+karry + return + END diff --git a/dataassim/math/numrec/f77_sources/asolve.for b/dataassim/math/numrec/f77_sources/asolve.for new file mode 100644 index 0000000..41272dc --- /dev/null +++ b/dataassim/math/numrec/f77_sources/asolve.for @@ -0,0 +1,10 @@ + SUBROUTINE asolve(n,b,x,itrnsp) + INTEGER n,itrnsp,ija,NMAX,i + DOUBLE PRECISION x(n),b(n),sa + PARAMETER (NMAX=1000) + COMMON /mat/ sa(NMAX),ija(NMAX) + do 11 i=1,n + x(i)=b(i)/sa(i) +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/atimes.for b/dataassim/math/numrec/f77_sources/atimes.for new file mode 100644 index 0000000..6e783fc --- /dev/null +++ b/dataassim/math/numrec/f77_sources/atimes.for @@ -0,0 +1,13 @@ + SUBROUTINE atimes(n,x,r,itrnsp) + INTEGER n,itrnsp,ija,NMAX + DOUBLE PRECISION x(n),r(n),sa + PARAMETER (NMAX=1000) + COMMON /mat/ sa(NMAX),ija(NMAX) +CU USES dsprsax,dsprstx + if (itrnsp.eq.0) then + call dsprsax(sa,ija,x,r,n) + else + call dsprstx(sa,ija,x,r,n) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/avevar.for b/dataassim/math/numrec/f77_sources/avevar.for new file mode 100644 index 0000000..2de3e8c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/avevar.for @@ -0,0 +1,20 @@ + SUBROUTINE avevar(data,n,ave,var) + INTEGER n + REAL ave,var,data(n) + INTEGER j + REAL s,ep + ave=0.0 + do 11 j=1,n + ave=ave+data(j) +11 continue + ave=ave/n + var=0.0 + ep=0.0 + do 12 j=1,n + s=data(j)-ave + ep=ep+s + var=var+s*s +12 continue + var=(var-ep**2/n)/(n-1) + return + END diff --git a/dataassim/math/numrec/f77_sources/badluk.for b/dataassim/math/numrec/f77_sources/badluk.for new file mode 100644 index 0000000..342dd53 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/badluk.for @@ -0,0 +1,44 @@ + PROGRAM badluk + INTEGER ic,icon,idwk,ifrac,im,iybeg,iyend,iyyy,jd,jday,n,julday + REAL TIMZON,frac + PARAMETER (TIMZON=-5./24.) + DATA iybeg,iyend /1900,2000/ +CU USES flmoon,julday + write (*,'(1x,a,i5,a,i5)') 'Full moons on Friday the 13th from', + *iybeg,' to',iyend + do 12 iyyy=iybeg,iyend + do 11 im=1,12 + jday=julday(im,13,iyyy) + idwk=mod(jday+1,7) + if(idwk.eq.5) then + n=12.37*(iyyy-1900+(im-0.5)/12.) + icon=0 +1 call flmoon(n,2,jd,frac) + ifrac=nint(24.*(frac+TIMZON)) + if(ifrac.lt.0)then + jd=jd-1 + ifrac=ifrac+24 + endif + if(ifrac.gt.12)then + jd=jd+1 + ifrac=ifrac-12 + else + ifrac=ifrac+12 + endif + if(jd.eq.jday)then + write (*,'(/1x,i2,a,i2,a,i4)') im,'/',13,'/',iyyy + write (*,'(1x,a,i2,a)') 'Full moon ',ifrac, + *' hrs after midnight (EST).' + goto 2 + else + ic=isign(1,jday-jd) + if(ic.eq.-icon) goto 2 + icon=ic + n=n+ic + endif + goto 1 +2 continue + endif +11 continue +12 continue + END diff --git a/dataassim/math/numrec/f77_sources/balanc.for b/dataassim/math/numrec/f77_sources/balanc.for new file mode 100644 index 0000000..157881d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/balanc.for @@ -0,0 +1,47 @@ + SUBROUTINE balanc(a,n,np) + INTEGER n,np + REAL a(np,np),RADIX,SQRDX + PARAMETER (RADIX=2.,SQRDX=RADIX**2) + INTEGER i,j,last + REAL c,f,g,r,s +1 continue + last=1 + do 14 i=1,n + c=0. + r=0. + do 11 j=1,n + if(j.ne.i)then + c=c+abs(a(j,i)) + r=r+abs(a(i,j)) + endif +11 continue + if(c.ne.0..and.r.ne.0.)then + g=r/RADIX + f=1. + s=c+r +2 if(c.lt.g)then + f=f*RADIX + c=c*SQRDX + goto 2 + endif + g=r*RADIX +3 if(c.gt.g)then + f=f/RADIX + c=c/SQRDX + goto 3 + endif + if((c+r)/f.lt.0.95*s)then + last=0 + g=1./f + do 12 j=1,n + a(i,j)=a(i,j)*g +12 continue + do 13 j=1,n + a(j,i)=a(j,i)*f +13 continue + endif + endif +14 continue + if(last.eq.0)goto 1 + return + END diff --git a/dataassim/math/numrec/f77_sources/banbks.for b/dataassim/math/numrec/f77_sources/banbks.for new file mode 100644 index 0000000..060b91f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/banbks.for @@ -0,0 +1,31 @@ + SUBROUTINE banbks(a,n,m1,m2,np,mp,al,mpl,indx,b) + INTEGER m1,m2,mp,mpl,n,np,indx(n) + REAL a(np,mp),al(np,mpl),b(n) + INTEGER i,k,l,mm + REAL dum + mm=m1+m2+1 + if(mm.gt.mp.or.m1.gt.mpl.or.n.gt.np) pause 'bad args in banbks' + l=m1 + do 12 k=1,n + i=indx(k) + if(i.ne.k)then + dum=b(k) + b(k)=b(i) + b(i)=dum + endif + if(l.lt.n)l=l+1 + do 11 i=k+1,l + b(i)=b(i)-al(k,i-k)*b(k) +11 continue +12 continue + l=1 + do 14 i=n,1,-1 + dum=b(i) + do 13 k=2,l + dum=dum-a(i,k)*b(k+i-1) +13 continue + b(i)=dum/a(i,1) + if(l.lt.mm) l=l+1 +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/bandec.for b/dataassim/math/numrec/f77_sources/bandec.for new file mode 100644 index 0000000..be9dc3a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bandec.for @@ -0,0 +1,51 @@ + SUBROUTINE bandec(a,n,m1,m2,np,mp,al,mpl,indx,d) + INTEGER m1,m2,mp,mpl,n,np,indx(n) + REAL d,a(np,mp),al(np,mpl),TINY + PARAMETER (TINY=1.e-20) + INTEGER i,j,k,l,mm + REAL dum + mm=m1+m2+1 + if(mm.gt.mp.or.m1.gt.mpl.or.n.gt.np) pause 'bad args in bandec' + l=m1 + do 13 i=1,m1 + do 11 j=m1+2-i,mm + a(i,j-l)=a(i,j) +11 continue + l=l-1 + do 12 j=mm-l,mm + a(i,j)=0. +12 continue +13 continue + d=1. + l=m1 + do 18 k=1,n + dum=a(k,1) + i=k + if(l.lt.n)l=l+1 + do 14 j=k+1,l + if(abs(a(j,1)).gt.abs(dum))then + dum=a(j,1) + i=j + endif +14 continue + indx(k)=i + if(dum.eq.0.) a(k,1)=TINY + if(i.ne.k)then + d=-d + do 15 j=1,mm + dum=a(k,j) + a(k,j)=a(i,j) + a(i,j)=dum +15 continue + endif + do 17 i=k+1,l + dum=a(i,1)/a(k,1) + al(k,i-k)=dum + do 16 j=2,mm + a(i,j-1)=a(i,j)-dum*a(k,j) +16 continue + a(i,mm)=0. +17 continue +18 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/banmul.for b/dataassim/math/numrec/f77_sources/banmul.for new file mode 100644 index 0000000..3f8a6ea --- /dev/null +++ b/dataassim/math/numrec/f77_sources/banmul.for @@ -0,0 +1,13 @@ + SUBROUTINE banmul(a,n,m1,m2,np,mp,x,b) + INTEGER m1,m2,mp,n,np + REAL a(np,mp),b(n),x(n) + INTEGER i,j,k + do 12 i=1,n + b(i)=0. + k=i-m1-1 + do 11 j=max(1,1-k),min(m1+m2+1,n-k) + b(i)=b(i)+a(i,j)*x(j+k) +11 continue +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/bcucof.for b/dataassim/math/numrec/f77_sources/bcucof.for new file mode 100644 index 0000000..ce27594 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bcucof.for @@ -0,0 +1,35 @@ + SUBROUTINE bcucof(y,y1,y2,y12,d1,d2,c) + REAL d1,d2,c(4,4),y(4),y1(4),y12(4),y2(4) + INTEGER i,j,k,l + REAL d1d2,xx,cl(16),wt(16,16),x(16) + SAVE wt + DATA wt/1,0,-3,2,4*0,-3,0,9,-6,2,0,-6,4,8*0,3,0,-9,6,-2,0,6,-4,10* + *0,9,-6,2*0,-6,4,2*0,3,-2,6*0,-9,6,2*0,6,-4,4*0,1,0,-3,2,-2,0,6,-4, + *1,0,-3,2,8*0,-1,0,3,-2,1,0,-3,2,10*0,-3,2,2*0,3,-2,6*0,3,-2,2*0, + *-6,4,2*0,3,-2,0,1,-2,1,5*0,-3,6,-3,0,2,-4,2,9*0,3,-6,3,0,-2,4,-2, + *10*0,-3,3,2*0,2,-2,2*0,-1,1,6*0,3,-3,2*0,-2,2,5*0,1,-2,1,0,-2,4, + *-2,0,1,-2,1,9*0,-1,2,-1,0,1,-2,1,10*0,1,-1,2*0,-1,1,6*0,-1,1,2*0, + *2,-2,2*0,-1,1/ + d1d2=d1*d2 + do 11 i=1,4 + x(i)=y(i) + x(i+4)=y1(i)*d1 + x(i+8)=y2(i)*d2 + x(i+12)=y12(i)*d1d2 +11 continue + do 13 i=1,16 + xx=0. + do 12 k=1,16 + xx=xx+wt(i,k)*x(k) +12 continue + cl(i)=xx +13 continue + l=0 + do 15 i=1,4 + do 14 j=1,4 + l=l+1 + c(i,j)=cl(l) +14 continue +15 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/bcuint.for b/dataassim/math/numrec/f77_sources/bcuint.for new file mode 100644 index 0000000..8c2f4fc --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bcuint.for @@ -0,0 +1,23 @@ + SUBROUTINE bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,ansy1, + *ansy2) + REAL ansy,ansy1,ansy2,x1,x1l,x1u,x2,x2l,x2u,y(4),y1(4),y12(4), + *y2(4) +CU USES bcucof + INTEGER i + REAL t,u,c(4,4) + call bcucof(y,y1,y2,y12,x1u-x1l,x2u-x2l,c) + if(x1u.eq.x1l.or.x2u.eq.x2l)pause 'bad input in bcuint' + t=(x1-x1l)/(x1u-x1l) + u=(x2-x2l)/(x2u-x2l) + ansy=0. + ansy2=0. + ansy1=0. + do 11 i=4,1,-1 + ansy=t*ansy+((c(i,4)*u+c(i,3))*u+c(i,2))*u+c(i,1) + ansy2=t*ansy2+(3.*c(i,4)*u+2.*c(i,3))*u+c(i,2) + ansy1=u*ansy1+(3.*c(4,i)*t+2.*c(3,i))*t+c(2,i) +11 continue + ansy1=ansy1/(x1u-x1l) + ansy2=ansy2/(x2u-x2l) + return + END diff --git a/dataassim/math/numrec/f77_sources/beschb.for b/dataassim/math/numrec/f77_sources/beschb.for new file mode 100644 index 0000000..1f2ea62 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/beschb.for @@ -0,0 +1,19 @@ + SUBROUTINE beschb(x,gam1,gam2,gampl,gammi) + INTEGER NUSE1,NUSE2 + DOUBLE PRECISION gam1,gam2,gammi,gampl,x + PARAMETER (NUSE1=5,NUSE2=5) +CU USES chebev + REAL xx,c1(7),c2(8),chebev + SAVE c1,c2 + DATA c1/-1.142022680371168d0,6.5165112670737d-3,3.087090173086d-4, + *-3.4706269649d-6,6.9437664d-9,3.67795d-11,-1.356d-13/ + DATA c2/1.843740587300905d0,-7.68528408447867d-2, + *1.2719271366546d-3,-4.9717367042d-6,-3.31261198d-8,2.423096d-10, + *-1.702d-13,-1.49d-15/ + xx=8.d0*x*x-1.d0 + gam1=chebev(-1.,1.,c1,NUSE1,xx) + gam2=chebev(-1.,1.,c2,NUSE2,xx) + gampl=gam2-x*gam1 + gammi=gam2+x*gam1 + return + END diff --git a/dataassim/math/numrec/f77_sources/bessi.for b/dataassim/math/numrec/f77_sources/bessi.for new file mode 100644 index 0000000..42b7014 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessi.for @@ -0,0 +1,32 @@ + FUNCTION bessi(n,x) + INTEGER n,IACC + REAL bessi,x,BIGNO,BIGNI + PARAMETER (IACC=40,BIGNO=1.0e10,BIGNI=1.0e-10) +CU USES bessi0 + INTEGER j,m + REAL bi,bim,bip,tox,bessi0 + if (n.lt.2) pause 'bad argument n in bessi' + if (x.eq.0.) then + bessi=0. + else + tox=2.0/abs(x) + bip=0.0 + bi=1.0 + bessi=0. + m=2*((n+int(sqrt(float(IACC*n))))) + do 11 j=m,1,-1 + bim=bip+float(j)*tox*bi + bip=bi + bi=bim + if (abs(bi).gt.BIGNO) then + bessi=bessi*BIGNI + bi=bi*BIGNI + bip=bip*BIGNI + endif + if (j.eq.n) bessi=bip +11 continue + bessi=bessi*bessi0(x)/bi + if (x.lt.0..and.mod(n,2).eq.1) bessi=-bessi + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/bessi0.for b/dataassim/math/numrec/f77_sources/bessi0.for new file mode 100644 index 0000000..38cf319 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessi0.for @@ -0,0 +1,21 @@ + FUNCTION bessi0(x) + REAL bessi0,x + REAL ax + DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y + SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9 + DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,3.5156229d0,3.0899424d0, + *1.2067492d0,0.2659732d0,0.360768d-1,0.45813d-2/ + DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,0.1328592d-1, + *0.225319d-2,-0.157565d-2,0.916281d-2,-0.2057706d-1,0.2635537d-1, + *-0.1647633d-1,0.392377d-2/ + if (abs(x).lt.3.75) then + y=(x/3.75)**2 + bessi0=p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7))))) + else + ax=abs(x) + y=3.75/ax + bessi0=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y* + *(q7+y*(q8+y*q9)))))))) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/bessi1.for b/dataassim/math/numrec/f77_sources/bessi1.for new file mode 100644 index 0000000..190f38c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessi1.for @@ -0,0 +1,22 @@ + FUNCTION bessi1(x) + REAL bessi1,x + REAL ax + DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y + SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9 + DATA p1,p2,p3,p4,p5,p6,p7/0.5d0,0.87890594d0,0.51498869d0, + *0.15084934d0,0.2658733d-1,0.301532d-2,0.32411d-3/ + DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,-0.3988024d-1, + *-0.362018d-2,0.163801d-2,-0.1031555d-1,0.2282967d-1,-0.2895312d-1, + *0.1787654d-1,-0.420059d-2/ + if (abs(x).lt.3.75) then + y=(x/3.75)**2 + bessi1=x*(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7)))))) + else + ax=abs(x) + y=3.75/ax + bessi1=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y* + *(q7+y*(q8+y*q9)))))))) + if(x.lt.0.)bessi1=-bessi1 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/bessik.for b/dataassim/math/numrec/f77_sources/bessik.for new file mode 100644 index 0000000..0b2f602 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessik.for @@ -0,0 +1,129 @@ + SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp) + INTEGER MAXIT + REAL ri,rip,rk,rkp,x,xnu,XMIN + DOUBLE PRECISION EPS,FPMIN,PI + PARAMETER (EPS=1.e-10,FPMIN=1.e-30,MAXIT=10000,XMIN=2., + *PI=3.141592653589793d0) +CU USES beschb + INTEGER i,l,nl + DOUBLE PRECISION a,a1,b,c,d,del,del1,delh,dels,e,f,fact,fact2,ff, + *gam1,gam2,gammi,gampl,h,p,pimu,q,q1,q2,qnew,ril,ril1,rimu,rip1, + *ripl,ritemp,rk1,rkmu,rkmup,rktemp,s,sum,sum1,x2,xi,xi2,xmu,xmu2 + if(x.le.0..or.xnu.lt.0.) pause 'bad arguments in bessik' + nl=int(xnu+.5d0) + xmu=xnu-nl + xmu2=xmu*xmu + xi=1.d0/x + xi2=2.d0*xi + h=xnu*xi + if(h.lt.FPMIN)h=FPMIN + b=xi2*xnu + d=0.d0 + c=h + do 11 i=1,MAXIT + b=b+xi2 + d=1.d0/(b+d) + c=b+1.d0/c + del=c*d + h=del*h + if(abs(del-1.d0).lt.EPS)goto 1 +11 continue + pause 'x too large in bessik; try asymptotic expansion' +1 continue + ril=FPMIN + ripl=h*ril + ril1=ril + rip1=ripl + fact=xnu*xi + do 12 l=nl,1,-1 + ritemp=fact*ril+ripl + fact=fact-xi + ripl=fact*ritemp+ril + ril=ritemp +12 continue + f=ripl/ril + if(x.lt.XMIN) then + x2=.5d0*x + pimu=PI*xmu + if(abs(pimu).lt.EPS)then + fact=1.d0 + else + fact=pimu/sin(pimu) + endif + d=-log(x2) + e=xmu*d + if(abs(e).lt.EPS)then + fact2=1.d0 + else + fact2=sinh(e)/e + endif + call beschb(xmu,gam1,gam2,gampl,gammi) + ff=fact*(gam1*cosh(e)+gam2*fact2*d) + sum=ff + e=exp(e) + p=0.5d0*e/gampl + q=0.5d0/(e*gammi) + c=1.d0 + d=x2*x2 + sum1=p + do 13 i=1,MAXIT + ff=(i*ff+p+q)/(i*i-xmu2) + c=c*d/i + p=p/(i-xmu) + q=q/(i+xmu) + del=c*ff + sum=sum+del + del1=c*(p-i*ff) + sum1=sum1+del1 + if(abs(del).lt.abs(sum)*EPS)goto 2 +13 continue + pause 'bessk series failed to converge' +2 continue + rkmu=sum + rk1=sum1*xi2 + else + b=2.d0*(1.d0+x) + d=1.d0/b + delh=d + h=delh + q1=0.d0 + q2=1.d0 + a1=.25d0-xmu2 + c=a1 + q=c + a=-a1 + s=1.d0+q*delh + do 14 i=2,MAXIT + a=a-2*(i-1) + c=-a*c/i + qnew=(q1-b*q2)/a + q1=q2 + q2=qnew + q=q+c*qnew + b=b+2.d0 + d=1.d0/(b+a*d) + delh=(b*d-1.d0)*delh + h=h+delh + dels=q*delh + s=s+dels + if(abs(dels/s).lt.EPS)goto 3 +14 continue + pause 'bessik: failure to converge in cf2' +3 continue + h=a1*h + rkmu=sqrt(PI/(2.d0*x))*exp(-x)/s + rk1=rkmu*(xmu+x+.5d0-h)*xi + endif + rkmup=xmu*xi*rkmu-rk1 + rimu=xi/(f*rkmu-rkmup) + ri=(rimu*ril1)/ril + rip=(rimu*rip1)/ril + do 15 i=1,nl + rktemp=(xmu+i)*xi2*rk1+rkmu + rkmu=rk1 + rk1=rktemp +15 continue + rk=rkmu + rkp=xnu*xi*rkmu-rk1 + return + END diff --git a/dataassim/math/numrec/f77_sources/bessj.for b/dataassim/math/numrec/f77_sources/bessj.for new file mode 100644 index 0000000..931f9c6 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessj.for @@ -0,0 +1,49 @@ + FUNCTION bessj(n,x) + INTEGER n,IACC + REAL bessj,x,BIGNO,BIGNI + PARAMETER (IACC=40,BIGNO=1.e10,BIGNI=1.e-10) +CU USES bessj0,bessj1 + INTEGER j,jsum,m + REAL ax,bj,bjm,bjp,sum,tox,bessj0,bessj1 + if(n.lt.2)pause 'bad argument n in bessj' + ax=abs(x) + if(ax.eq.0.)then + bessj=0. + else if(ax.gt.float(n))then + tox=2./ax + bjm=bessj0(ax) + bj=bessj1(ax) + do 11 j=1,n-1 + bjp=j*tox*bj-bjm + bjm=bj + bj=bjp +11 continue + bessj=bj + else + tox=2./ax + m=2*((n+int(sqrt(float(IACC*n))))/2) + bessj=0. + jsum=0 + sum=0. + bjp=0. + bj=1. + do 12 j=m,1,-1 + bjm=j*tox*bj-bjp + bjp=bj + bj=bjm + if(abs(bj).gt.BIGNO)then + bj=bj*BIGNI + bjp=bjp*BIGNI + bessj=bessj*BIGNI + sum=sum*BIGNI + endif + if(jsum.ne.0)sum=sum+bj + jsum=1-jsum + if(j.eq.n)bessj=bjp +12 continue + sum=2.*sum-bj + bessj=bessj/sum + endif + if(x.lt.0..and.mod(n,2).eq.1)bessj=-bessj + return + END diff --git a/dataassim/math/numrec/f77_sources/bessj0.for b/dataassim/math/numrec/f77_sources/bessj0.for new file mode 100644 index 0000000..e3dd5d8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessj0.for @@ -0,0 +1,28 @@ + FUNCTION bessj0(x) + REAL bessj0,x + REAL ax,xx,z + DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6, + *s1,s2,s3,s4,s5,s6,y + SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4, + *s5,s6 + DATA p1,p2,p3,p4,p5/1.d0,-.1098628627d-2,.2734510407d-4, + *-.2073370639d-5,.2093887211d-6/, q1,q2,q3,q4,q5/-.1562499995d-1, + *.1430488765d-3,-.6911147651d-5,.7621095161d-6,-.934945152d-7/ + DATA r1,r2,r3,r4,r5,r6/57568490574.d0,-13362590354.d0, + *651619640.7d0,-11214424.18d0,77392.33017d0,-184.9052456d0/,s1,s2, + *s3,s4,s5,s6/57568490411.d0,1029532985.d0,9494680.718d0, + *59272.64853d0,267.8532712d0,1.d0/ + if(abs(x).lt.8.)then + y=x**2 + bessj0=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+y* + *(s4+y*(s5+y*s6))))) + else + ax=abs(x) + z=8./ax + y=z**2 + xx=ax-.785398164 + bessj0=sqrt(.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y* + *p5))))-z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5))))) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/bessj1.for b/dataassim/math/numrec/f77_sources/bessj1.for new file mode 100644 index 0000000..d3f97ea --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessj1.for @@ -0,0 +1,28 @@ + FUNCTION bessj1(x) + REAL bessj1,x + REAL ax,xx,z + DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6, + *s1,s2,s3,s4,s5,s6,y + SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4, + *s5,s6 + DATA r1,r2,r3,r4,r5,r6/72362614232.d0,-7895059235.d0, + *242396853.1d0,-2972611.439d0,15704.48260d0,-30.16036606d0/,s1,s2, + *s3,s4,s5,s6/144725228442.d0,2300535178.d0,18583304.74d0, + *99447.43394d0,376.9991397d0,1.d0/ + DATA p1,p2,p3,p4,p5/1.d0,.183105d-2,-.3516396496d-4, + *.2457520174d-5,-.240337019d-6/, q1,q2,q3,q4,q5/.04687499995d0, + *-.2002690873d-3,.8449199096d-5,-.88228987d-6,.105787412d-6/ + if(abs(x).lt.8.)then + y=x**2 + bessj1=x*(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+ + *y*(s4+y*(s5+y*s6))))) + else + ax=abs(x) + z=8./ax + y=z**2 + xx=ax-2.356194491 + bessj1=sqrt(.636619772/ax)*(cos(xx)*(p1+y*(p2+y*(p3+y*(p4+y* + *p5))))-z*sin(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5)))))*sign(1.,x) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/bessjy.for b/dataassim/math/numrec/f77_sources/bessjy.for new file mode 100644 index 0000000..da82f73 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessjy.for @@ -0,0 +1,162 @@ + SUBROUTINE bessjy(x,xnu,rj,ry,rjp,ryp) + INTEGER MAXIT + REAL rj,rjp,ry,ryp,x,xnu,XMIN + DOUBLE PRECISION EPS,FPMIN,PI + PARAMETER (EPS=1.e-10,FPMIN=1.e-30,MAXIT=10000,XMIN=2., + *PI=3.141592653589793d0) +CU USES beschb + INTEGER i,isign,l,nl + DOUBLE PRECISION a,b,br,bi,c,cr,ci,d,del,del1,den,di,dlr,dli,dr,e, + *f,fact,fact2,fact3,ff,gam,gam1,gam2,gammi,gampl,h,p,pimu,pimu2,q, + *r,rjl,rjl1,rjmu,rjp1,rjpl,rjtemp,ry1,rymu,rymup,rytemp,sum,sum1, + *temp,w,x2,xi,xi2,xmu,xmu2 + if(x.le.0..or.xnu.lt.0.) pause 'bad arguments in bessjy' + if(x.lt.XMIN)then + nl=int(xnu+.5d0) + else + nl=max(0,int(xnu-x+1.5d0)) + endif + xmu=xnu-nl + xmu2=xmu*xmu + xi=1.d0/x + xi2=2.d0*xi + w=xi2/PI + isign=1 + h=xnu*xi + if(h.lt.FPMIN)h=FPMIN + b=xi2*xnu + d=0.d0 + c=h + do 11 i=1,MAXIT + b=b+xi2 + d=b-d + if(abs(d).lt.FPMIN)d=FPMIN + c=b-1.d0/c + if(abs(c).lt.FPMIN)c=FPMIN + d=1.d0/d + del=c*d + h=del*h + if(d.lt.0.d0)isign=-isign + if(abs(del-1.d0).lt.EPS)goto 1 +11 continue + pause 'x too large in bessjy; try asymptotic expansion' +1 continue + rjl=isign*FPMIN + rjpl=h*rjl + rjl1=rjl + rjp1=rjpl + fact=xnu*xi + do 12 l=nl,1,-1 + rjtemp=fact*rjl+rjpl + fact=fact-xi + rjpl=fact*rjtemp-rjl + rjl=rjtemp +12 continue + if(rjl.eq.0.d0)rjl=EPS + f=rjpl/rjl + if(x.lt.XMIN) then + x2=.5d0*x + pimu=PI*xmu + if(abs(pimu).lt.EPS)then + fact=1.d0 + else + fact=pimu/sin(pimu) + endif + d=-log(x2) + e=xmu*d + if(abs(e).lt.EPS)then + fact2=1.d0 + else + fact2=sinh(e)/e + endif + call beschb(xmu,gam1,gam2,gampl,gammi) + ff=2.d0/PI*fact*(gam1*cosh(e)+gam2*fact2*d) + e=exp(e) + p=e/(gampl*PI) + q=1.d0/(e*PI*gammi) + pimu2=0.5d0*pimu + if(abs(pimu2).lt.EPS)then + fact3=1.d0 + else + fact3=sin(pimu2)/pimu2 + endif + r=PI*pimu2*fact3*fact3 + c=1.d0 + d=-x2*x2 + sum=ff+r*q + sum1=p + do 13 i=1,MAXIT + ff=(i*ff+p+q)/(i*i-xmu2) + c=c*d/i + p=p/(i-xmu) + q=q/(i+xmu) + del=c*(ff+r*q) + sum=sum+del + del1=c*p-i*del + sum1=sum1+del1 + if(abs(del).lt.(1.d0+abs(sum))*EPS)goto 2 +13 continue + pause 'bessy series failed to converge' +2 continue + rymu=-sum + ry1=-sum1*xi2 + rymup=xmu*xi*rymu-ry1 + rjmu=w/(rymup-f*rymu) + else + a=.25d0-xmu2 + p=-.5d0*xi + q=1.d0 + br=2.d0*x + bi=2.d0 + fact=a*xi/(p*p+q*q) + cr=br+q*fact + ci=bi+p*fact + den=br*br+bi*bi + dr=br/den + di=-bi/den + dlr=cr*dr-ci*di + dli=cr*di+ci*dr + temp=p*dlr-q*dli + q=p*dli+q*dlr + p=temp + do 14 i=2,MAXIT + a=a+2*(i-1) + bi=bi+2.d0 + dr=a*dr+br + di=a*di+bi + if(abs(dr)+abs(di).lt.FPMIN)dr=FPMIN + fact=a/(cr*cr+ci*ci) + cr=br+cr*fact + ci=bi-ci*fact + if(abs(cr)+abs(ci).lt.FPMIN)cr=FPMIN + den=dr*dr+di*di + dr=dr/den + di=-di/den + dlr=cr*dr-ci*di + dli=cr*di+ci*dr + temp=p*dlr-q*dli + q=p*dli+q*dlr + p=temp + if(abs(dlr-1.d0)+abs(dli).lt.EPS)goto 3 +14 continue + pause 'cf2 failed in bessjy' +3 continue + gam=(p-f)/q + rjmu=sqrt(w/((p-f)*gam+q)) + rjmu=sign(rjmu,rjl) + rymu=rjmu*gam + rymup=rymu*(p+q/gam) + ry1=xmu*xi*rymu-rymup + endif + fact=rjmu/rjl + rj=rjl1*fact + rjp=rjp1*fact + do 15 i=1,nl + rytemp=(xmu+i)*xi2*ry1-rymu + rymu=ry1 + ry1=rytemp +15 continue + ry=rymu + ryp=xnu*xi*rymu-ry1 + return + END diff --git a/dataassim/math/numrec/f77_sources/bessk.for b/dataassim/math/numrec/f77_sources/bessk.for new file mode 100644 index 0000000..9ea90da --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessk.for @@ -0,0 +1,18 @@ + FUNCTION bessk(n,x) + INTEGER n + REAL bessk,x +CU USES bessk0,bessk1 + INTEGER j + REAL bk,bkm,bkp,tox,bessk0,bessk1 + if (n.lt.2) pause 'bad argument n in bessk' + tox=2.0/x + bkm=bessk0(x) + bk=bessk1(x) + do 11 j=1,n-1 + bkp=bkm+j*tox*bk + bkm=bk + bk=bkp +11 continue + bessk=bk + return + END diff --git a/dataassim/math/numrec/f77_sources/bessk0.for b/dataassim/math/numrec/f77_sources/bessk0.for new file mode 100644 index 0000000..2a5bf9f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessk0.for @@ -0,0 +1,21 @@ + FUNCTION bessk0(x) + REAL bessk0,x +CU USES bessi0 + REAL bessi0 + DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y + SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7 + DATA p1,p2,p3,p4,p5,p6,p7/-0.57721566d0,0.42278420d0,0.23069756d0, + *0.3488590d-1,0.262698d-2,0.10750d-3,0.74d-5/ + DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,-0.7832358d-1,0.2189568d-1, + *-0.1062446d-1,0.587872d-2,-0.251540d-2,0.53208d-3/ + if (x.le.2.0) then + y=x*x/4.0 + bessk0=(-log(x/2.0)*bessi0(x))+(p1+y*(p2+y*(p3+y*(p4+y*(p5+y* + *(p6+y*p7)))))) + else + y=(2.0/x) + bessk0=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y* + *q7)))))) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/bessk1.for b/dataassim/math/numrec/f77_sources/bessk1.for new file mode 100644 index 0000000..a874c77 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessk1.for @@ -0,0 +1,21 @@ + FUNCTION bessk1(x) + REAL bessk1,x +CU USES bessi1 + REAL bessi1 + DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y + SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7 + DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,0.15443144d0,-0.67278579d0, + *-0.18156897d0,-0.1919402d-1,-0.110404d-2,-0.4686d-4/ + DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,0.23498619d0,-0.3655620d-1, + *0.1504268d-1,-0.780353d-2,0.325614d-2,-0.68245d-3/ + if (x.le.2.0) then + y=x*x/4.0 + bessk1=(log(x/2.0)*bessi1(x))+(1.0/x)*(p1+y*(p2+y*(p3+y*(p4+y* + *(p5+y*(p6+y*p7)))))) + else + y=2.0/x + bessk1=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y* + *q7)))))) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/bessy.for b/dataassim/math/numrec/f77_sources/bessy.for new file mode 100644 index 0000000..1c29a5c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessy.for @@ -0,0 +1,18 @@ + FUNCTION bessy(n,x) + INTEGER n + REAL bessy,x +CU USES bessy0,bessy1 + INTEGER j + REAL by,bym,byp,tox,bessy0,bessy1 + if(n.lt.2)pause 'bad argument n in bessy' + tox=2./x + by=bessy1(x) + bym=bessy0(x) + do 11 j=1,n-1 + byp=j*tox*by-bym + bym=by + by=byp +11 continue + bessy=by + return + END diff --git a/dataassim/math/numrec/f77_sources/bessy0.for b/dataassim/math/numrec/f77_sources/bessy0.for new file mode 100644 index 0000000..21c07f4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessy0.for @@ -0,0 +1,28 @@ + FUNCTION bessy0(x) + REAL bessy0,x +CU USES bessj0 + REAL xx,z,bessj0 + DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6, + *s1,s2,s3,s4,s5,s6,y + SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4, + *s5,s6 + DATA p1,p2,p3,p4,p5/1.d0,-.1098628627d-2,.2734510407d-4, + *-.2073370639d-5,.2093887211d-6/, q1,q2,q3,q4,q5/-.1562499995d-1, + *.1430488765d-3,-.6911147651d-5,.7621095161d-6,-.934945152d-7/ + DATA r1,r2,r3,r4,r5,r6/-2957821389.d0,7062834065.d0, + *-512359803.6d0,10879881.29d0,-86327.92757d0,228.4622733d0/,s1,s2, + *s3,s4,s5,s6/40076544269.d0,745249964.8d0,7189466.438d0, + *47447.26470d0,226.1030244d0,1.d0/ + if(x.lt.8.)then + y=x**2 + bessy0=(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+y* + *(s4+y*(s5+y*s6)))))+.636619772*bessj0(x)*log(x) + else + z=8./x + y=z**2 + xx=x-.785398164 + bessy0=sqrt(.636619772/x)*(sin(xx)*(p1+y*(p2+y*(p3+y*(p4+y* + *p5))))+z*cos(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5))))) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/bessy1.for b/dataassim/math/numrec/f77_sources/bessy1.for new file mode 100644 index 0000000..9947288 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bessy1.for @@ -0,0 +1,28 @@ + FUNCTION bessy1(x) + REAL bessy1,x +CU USES bessj1 + REAL xx,z,bessj1 + DOUBLE PRECISION p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6, + *s1,s2,s3,s4,s5,s6,s7,y + SAVE p1,p2,p3,p4,p5,q1,q2,q3,q4,q5,r1,r2,r3,r4,r5,r6,s1,s2,s3,s4, + *s5,s6,s7 + DATA p1,p2,p3,p4,p5/1.d0,.183105d-2,-.3516396496d-4, + *.2457520174d-5,-.240337019d-6/, q1,q2,q3,q4,q5/.04687499995d0, + *-.2002690873d-3,.8449199096d-5,-.88228987d-6,.105787412d-6/ + DATA r1,r2,r3,r4,r5,r6/-.4900604943d13,.1275274390d13, + *-.5153438139d11,.7349264551d9,-.4237922726d7,.8511937935d4/,s1,s2, + *s3,s4,s5,s6,s7/.2499580570d14,.4244419664d12,.3733650367d10, + *.2245904002d8,.1020426050d6,.3549632885d3,1.d0/ + if(x.lt.8.)then + y=x**2 + bessy1=x*(r1+y*(r2+y*(r3+y*(r4+y*(r5+y*r6)))))/(s1+y*(s2+y*(s3+ + *y*(s4+y*(s5+y*(s6+y*s7))))))+.636619772*(bessj1(x)*log(x)-1./x) + else + z=8./x + y=z**2 + xx=x-2.356194491 + bessy1=sqrt(.636619772/x)*(sin(xx)*(p1+y*(p2+y*(p3+y*(p4+y* + *p5))))+z*cos(xx)*(q1+y*(q2+y*(q3+y*(q4+y*q5))))) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/beta.for b/dataassim/math/numrec/f77_sources/beta.for new file mode 100644 index 0000000..07120d1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/beta.for @@ -0,0 +1,7 @@ + FUNCTION beta(z,w) + REAL beta,w,z +CU USES gammln + REAL gammln + beta=exp(gammln(z)+gammln(w)-gammln(z+w)) + return + END diff --git a/dataassim/math/numrec/f77_sources/betacf.for b/dataassim/math/numrec/f77_sources/betacf.for new file mode 100644 index 0000000..feaabce --- /dev/null +++ b/dataassim/math/numrec/f77_sources/betacf.for @@ -0,0 +1,37 @@ + FUNCTION betacf(a,b,x) + INTEGER MAXIT + REAL betacf,a,b,x,EPS,FPMIN + PARAMETER (MAXIT=100,EPS=3.e-7,FPMIN=1.e-30) + INTEGER m,m2 + REAL aa,c,d,del,h,qab,qam,qap + qab=a+b + qap=a+1. + qam=a-1. + c=1. + d=1.-qab*x/qap + if(abs(d).lt.FPMIN)d=FPMIN + d=1./d + h=d + do 11 m=1,MAXIT + m2=2*m + aa=m*(b-m)*x/((qam+m2)*(a+m2)) + d=1.+aa*d + if(abs(d).lt.FPMIN)d=FPMIN + c=1.+aa/c + if(abs(c).lt.FPMIN)c=FPMIN + d=1./d + h=h*d*c + aa=-(a+m)*(qab+m)*x/((a+m2)*(qap+m2)) + d=1.+aa*d + if(abs(d).lt.FPMIN)d=FPMIN + c=1.+aa/c + if(abs(c).lt.FPMIN)c=FPMIN + d=1./d + del=d*c + h=h*del + if(abs(del-1.).lt.EPS)goto 1 +11 continue + pause 'a or b too big, or MAXIT too small in betacf' +1 betacf=h + return + END diff --git a/dataassim/math/numrec/f77_sources/betai.for b/dataassim/math/numrec/f77_sources/betai.for new file mode 100644 index 0000000..0c92341 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/betai.for @@ -0,0 +1,18 @@ + FUNCTION betai(a,b,x) + REAL betai,a,b,x +CU USES betacf,gammln + REAL bt,betacf,gammln + if(x.lt.0..or.x.gt.1.)pause 'bad argument x in betai' + if(x.eq.0..or.x.eq.1.)then + bt=0. + else + bt=exp(gammln(a+b)-gammln(a)-gammln(b)+a*log(x)+b*log(1.-x)) + endif + if(x.lt.(a+1.)/(a+b+2.))then + betai=bt*betacf(a,b,x)/a + return + else + betai=1.-bt*betacf(b,a,1.-x)/b + return + endif + END diff --git a/dataassim/math/numrec/f77_sources/bico.for b/dataassim/math/numrec/f77_sources/bico.for new file mode 100644 index 0000000..1538901 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bico.for @@ -0,0 +1,8 @@ + FUNCTION bico(n,k) + INTEGER k,n + REAL bico +CU USES factln + REAL factln + bico=nint(exp(factln(n)-factln(k)-factln(n-k))) + return + END diff --git a/dataassim/math/numrec/f77_sources/bksub.for b/dataassim/math/numrec/f77_sources/bksub.for new file mode 100644 index 0000000..352c5e9 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bksub.for @@ -0,0 +1,28 @@ + SUBROUTINE bksub(ne,nb,jf,k1,k2,c,nci,ncj,nck) + INTEGER jf,k1,k2,nb,nci,ncj,nck,ne + REAL c(nci,ncj,nck) + INTEGER i,im,j,k,kp,nbf + REAL xx + nbf=ne-nb + im=1 + do 13 k=k2,k1,-1 + if (k.eq.k1) im=nbf+1 + kp=k+1 + do 12 j=1,nbf + xx=c(j,jf,kp) + do 11 i=im,ne + c(i,jf,k)=c(i,jf,k)-c(i,j,k)*xx +11 continue +12 continue +13 continue + do 16 k=k1,k2 + kp=k+1 + do 14 i=1,nb + c(i,1,k)=c(i+nbf,jf,k) +14 continue + do 15 i=1,nbf + c(i+nb,1,k)=c(i,jf,kp) +15 continue +16 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/bnldev.for b/dataassim/math/numrec/f77_sources/bnldev.for new file mode 100644 index 0000000..d147cb4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bnldev.for @@ -0,0 +1,54 @@ + FUNCTION bnldev(pp,n,idum) + INTEGER idum,n + REAL bnldev,pp,PI +CU USES gammln,ran1 + PARAMETER (PI=3.141592654) + INTEGER j,nold + REAL am,em,en,g,oldg,p,pc,pclog,plog,pold,sq,t,y,gammln,ran1 + SAVE nold,pold,pc,plog,pclog,en,oldg + DATA nold /-1/, pold /-1./ + if(pp.le.0.5)then + p=pp + else + p=1.-pp + endif + am=n*p + if (n.lt.25)then + bnldev=0. + do 11 j=1,n + if(ran1(idum).lt.p)bnldev=bnldev+1. +11 continue + else if (am.lt.1.) then + g=exp(-am) + t=1. + do 12 j=0,n + t=t*ran1(idum) + if (t.lt.g) goto 1 +12 continue + j=n +1 bnldev=j + else + if (n.ne.nold) then + en=n + oldg=gammln(en+1.) + nold=n + endif + if (p.ne.pold) then + pc=1.-p + plog=log(p) + pclog=log(pc) + pold=p + endif + sq=sqrt(2.*am*pc) +2 y=tan(PI*ran1(idum)) + em=sq*y+am + if (em.lt.0..or.em.ge.en+1.) goto 2 + em=int(em) + t=1.2*sq*(1.+y**2)*exp(oldg-gammln(em+1.)-gammln(en-em+1.)+em* + *plog+(en-em)*pclog) + if (ran1(idum).gt.t) goto 2 + bnldev=em + endif + if (p.ne.pp) bnldev=n-bnldev + return + END diff --git a/dataassim/math/numrec/f77_sources/brent.for b/dataassim/math/numrec/f77_sources/brent.for new file mode 100644 index 0000000..13539d8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/brent.for @@ -0,0 +1,83 @@ + FUNCTION brent(ax,bx,cx,f,tol,xmin) + INTEGER ITMAX + REAL brent,ax,bx,cx,tol,xmin,f,CGOLD,ZEPS + EXTERNAL f + PARAMETER (ITMAX=100,CGOLD=.3819660,ZEPS=1.0e-10) + INTEGER iter + REAL a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,tol2,u,v,w,x,xm + a=min(ax,cx) + b=max(ax,cx) + v=bx + w=v + x=v + e=0. + fx=f(x) + fv=fx + fw=fx + do 11 iter=1,ITMAX + xm=0.5*(a+b) + tol1=tol*abs(x)+ZEPS + tol2=2.*tol1 + if(abs(x-xm).le.(tol2-.5*(b-a))) goto 3 + if(abs(e).gt.tol1) then + r=(x-w)*(fx-fv) + q=(x-v)*(fx-fw) + p=(x-v)*q-(x-w)*r + q=2.*(q-r) + if(q.gt.0.) p=-p + q=abs(q) + etemp=e + e=d + if(abs(p).ge.abs(.5*q*etemp).or.p.le.q*(a-x).or.p.ge.q*(b-x)) + *goto 1 + d=p/q + u=x+d + if(u-a.lt.tol2 .or. b-u.lt.tol2) d=sign(tol1,xm-x) + goto 2 + endif +1 if(x.ge.xm) then + e=a-x + else + e=b-x + endif + d=CGOLD*e +2 if(abs(d).ge.tol1) then + u=x+d + else + u=x+sign(tol1,d) + endif + fu=f(u) + if(fu.le.fx) then + if(u.ge.x) then + a=x + else + b=x + endif + v=w + fv=fw + w=x + fw=fx + x=u + fx=fu + else + if(u.lt.x) then + a=u + else + b=u + endif + if(fu.le.fw .or. w.eq.x) then + v=w + fv=fw + w=u + fw=fu + else if(fu.le.fv .or. v.eq.x .or. v.eq.w) then + v=u + fv=fu + endif + endif +11 continue + pause 'brent exceed maximum iterations' +3 xmin=x + brent=fx + return + END diff --git a/dataassim/math/numrec/f77_sources/broydn.for b/dataassim/math/numrec/f77_sources/broydn.for new file mode 100644 index 0000000..754cedb --- /dev/null +++ b/dataassim/math/numrec/f77_sources/broydn.for @@ -0,0 +1,170 @@ + SUBROUTINE broydn(x,n,check) + INTEGER n,nn,NP,MAXITS + REAL x(n),fvec,EPS,TOLF,TOLMIN,TOLX,STPMX + LOGICAL check + PARAMETER (NP=40,MAXITS=200,EPS=1.e-7,TOLF=1.e-4,TOLMIN=1.e-6, + *TOLX=EPS,STPMX=100.) + COMMON /newtv/ fvec(NP),nn +CU USES fdjac,fmin,lnsrch,qrdcmp,qrupdt,rsolv + INTEGER i,its,j,k + REAL den,f,fold,stpmax,sum,temp,test,c(NP),d(NP),fvcold(NP),g(NP), + *p(NP),qt(NP,NP),r(NP,NP),s(NP),t(NP),w(NP),xold(NP),fmin + LOGICAL restrt,sing,skip + EXTERNAL fmin + nn=n + f=fmin(x) + test=0. + do 11 i=1,n + if(abs(fvec(i)).gt.test)test=abs(fvec(i)) +11 continue + if(test.lt..01*TOLF)then + check=.false. + return + endif + sum=0. + do 12 i=1,n + sum=sum+x(i)**2 +12 continue + stpmax=STPMX*max(sqrt(sum),float(n)) + restrt=.true. + do 44 its=1,MAXITS + if(restrt)then + call fdjac(n,x,fvec,NP,r) + call qrdcmp(r,n,NP,c,d,sing) + if(sing) pause 'singular Jacobian in broydn' + do 14 i=1,n + do 13 j=1,n + qt(i,j)=0. +13 continue + qt(i,i)=1. +14 continue + do 18 k=1,n-1 + if(c(k).ne.0.)then + do 17 j=1,n + sum=0. + do 15 i=k,n + sum=sum+r(i,k)*qt(i,j) +15 continue + sum=sum/c(k) + do 16 i=k,n + qt(i,j)=qt(i,j)-sum*r(i,k) +16 continue +17 continue + endif +18 continue + do 21 i=1,n + r(i,i)=d(i) + do 19 j=1,i-1 + r(i,j)=0. +19 continue +21 continue + else + do 22 i=1,n + s(i)=x(i)-xold(i) +22 continue + do 24 i=1,n + sum=0. + do 23 j=i,n + sum=sum+r(i,j)*s(j) +23 continue + t(i)=sum +24 continue + skip=.true. + do 26 i=1,n + sum=0. + do 25 j=1,n + sum=sum+qt(j,i)*t(j) +25 continue + w(i)=fvec(i)-fvcold(i)-sum + if(abs(w(i)).ge.EPS*(abs(fvec(i))+abs(fvcold(i))))then + skip=.false. + else + w(i)=0. + endif +26 continue + if(.not.skip)then + do 28 i=1,n + sum=0. + do 27 j=1,n + sum=sum+qt(i,j)*w(j) +27 continue + t(i)=sum +28 continue + den=0. + do 29 i=1,n + den=den+s(i)**2 +29 continue + do 31 i=1,n + s(i)=s(i)/den +31 continue + call qrupdt(r,qt,n,NP,t,s) + do 32 i=1,n + if(r(i,i).eq.0.) pause 'r singular in broydn' + d(i)=r(i,i) +32 continue + endif + endif + do 34 i=1,n + sum=0. + do 33 j=1,n + sum=sum+qt(i,j)*fvec(j) +33 continue + g(i)=sum +34 continue + do 36 i=n,1,-1 + sum=0. + do 35 j=1,i + sum=sum+r(j,i)*g(j) +35 continue + g(i)=sum +36 continue + do 37 i=1,n + xold(i)=x(i) + fvcold(i)=fvec(i) +37 continue + fold=f + do 39 i=1,n + sum=0. + do 38 j=1,n + sum=sum+qt(i,j)*fvec(j) +38 continue + p(i)=-sum +39 continue + call rsolv(r,n,NP,d,p) + call lnsrch(n,xold,fold,g,p,x,f,stpmax,check,fmin) + test=0. + do 41 i=1,n + if(abs(fvec(i)).gt.test)test=abs(fvec(i)) +41 continue + if(test.lt.TOLF)then + check=.false. + return + endif + if(check)then + if(restrt)then + return + else + test=0. + den=max(f,.5*n) + do 42 i=1,n + temp=abs(g(i))*max(abs(x(i)),1.)/den + if(temp.gt.test)test=temp +42 continue + if(test.lt.TOLMIN)then + return + else + restrt=.true. + endif + endif + else + restrt=.false. + test=0. + do 43 i=1,n + temp=(abs(x(i)-xold(i)))/max(abs(x(i)),1.) + if(temp.gt.test)test=temp +43 continue + if(test.lt.TOLX)return + endif +44 continue + pause 'MAXITS exceeded in broydn' + END diff --git a/dataassim/math/numrec/f77_sources/bsstep.for b/dataassim/math/numrec/f77_sources/bsstep.for new file mode 100644 index 0000000..d88e67c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/bsstep.for @@ -0,0 +1,109 @@ + SUBROUTINE bsstep(y,dydx,nv,x,htry,eps,yscal,hdid,hnext,derivs) + INTEGER nv,NMAX,KMAXX,IMAX + REAL eps,hdid,hnext,htry,x,dydx(nv),y(nv),yscal(nv),SAFE1,SAFE2, + *REDMAX,REDMIN,TINY,SCALMX + PARAMETER (NMAX=50,KMAXX=8,IMAX=KMAXX+1,SAFE1=.25,SAFE2=.7, + *REDMAX=1.e-5,REDMIN=.7,TINY=1.e-30,SCALMX=.1) +CU USES derivs,mmid,pzextr + INTEGER i,iq,k,kk,km,kmax,kopt,nseq(IMAX) + REAL eps1,epsold,errmax,fact,h,red,scale,work,wrkmin,xest,xnew, + *a(IMAX),alf(KMAXX,KMAXX),err(KMAXX),yerr(NMAX),ysav(NMAX), + *yseq(NMAX) + LOGICAL first,reduct + SAVE a,alf,epsold,first,kmax,kopt,nseq,xnew + EXTERNAL derivs + DATA first/.true./,epsold/-1./ + DATA nseq /2,4,6,8,10,12,14,16,18/ + if(eps.ne.epsold)then + hnext=-1.e29 + xnew=-1.e29 + eps1=SAFE1*eps + a(1)=nseq(1)+1 + do 11 k=1,KMAXX + a(k+1)=a(k)+nseq(k+1) +11 continue + do 13 iq=2,KMAXX + do 12 k=1,iq-1 + alf(k,iq)=eps1**((a(k+1)-a(iq+1))/((a(iq+1)-a(1)+1.)*(2*k+ + *1))) +12 continue +13 continue + epsold=eps + do 14 kopt=2,KMAXX-1 + if(a(kopt+1).gt.a(kopt)*alf(kopt-1,kopt))goto 1 +14 continue +1 kmax=kopt + endif + h=htry + do 15 i=1,nv + ysav(i)=y(i) +15 continue + if(h.ne.hnext.or.x.ne.xnew)then + first=.true. + kopt=kmax + endif + reduct=.false. +2 do 17 k=1,kmax + xnew=x+h + if(xnew.eq.x)pause 'step size underflow in bsstep' + call mmid(ysav,dydx,nv,x,h,nseq(k),yseq,derivs) + xest=(h/nseq(k))**2 + call pzextr(k,xest,yseq,y,yerr,nv) + if(k.ne.1)then + errmax=TINY + do 16 i=1,nv + errmax=max(errmax,abs(yerr(i)/yscal(i))) +16 continue + errmax=errmax/eps + km=k-1 + err(km)=(errmax/SAFE1)**(1./(2*km+1)) + endif + if(k.ne.1.and.(k.ge.kopt-1.or.first))then + if(errmax.lt.1.)goto 4 + if(k.eq.kmax.or.k.eq.kopt+1)then + red=SAFE2/err(km) + goto 3 + else if(k.eq.kopt)then + if(alf(kopt-1,kopt).lt.err(km))then + red=1./err(km) + goto 3 + endif + else if(kopt.eq.kmax)then + if(alf(km,kmax-1).lt.err(km))then + red=alf(km,kmax-1)*SAFE2/err(km) + goto 3 + endif + else if(alf(km,kopt).lt.err(km))then + red=alf(km,kopt-1)/err(km) + goto 3 + endif + endif +17 continue +3 red=min(red,REDMIN) + red=max(red,REDMAX) + h=h*red + reduct=.true. + goto 2 +4 x=xnew + hdid=h + first=.false. + wrkmin=1.e35 + do 18 kk=1,km + fact=max(err(kk),SCALMX) + work=fact*a(kk+1) + if(work.lt.wrkmin)then + scale=fact + wrkmin=work + kopt=kk+1 + endif +18 continue + hnext=h/scale + if(kopt.ge.k.and.kopt.ne.kmax.and..not.reduct)then + fact=max(scale/alf(kopt-1,kopt),SCALMX) + if(a(kopt+1)*fact.le.wrkmin)then + hnext=h/fact + kopt=kopt+1 + endif + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/caldat.for b/dataassim/math/numrec/f77_sources/caldat.for new file mode 100644 index 0000000..259eb57 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/caldat.for @@ -0,0 +1,22 @@ + SUBROUTINE caldat(julian,mm,id,iyyy) + INTEGER id,iyyy,julian,mm,IGREG + PARAMETER (IGREG=2299161) + INTEGER ja,jalpha,jb,jc,jd,je + if(julian.ge.IGREG)then + jalpha=int(((julian-1867216)-0.25)/36524.25) + ja=julian+1+jalpha-int(0.25*jalpha) + else + ja=julian + endif + jb=ja+1524 + jc=int(6680.+((jb-2439870)-122.1)/365.25) + jd=365*jc+int(0.25*jc) + je=int((jb-jd)/30.6001) + id=jb-jd-int(30.6001*je) + mm=je-1 + if(mm.gt.12)mm=mm-12 + iyyy=jc-4715 + if(mm.gt.2)iyyy=iyyy-1 + if(iyyy.le.0)iyyy=iyyy-1 + return + END diff --git a/dataassim/math/numrec/f77_sources/chder.for b/dataassim/math/numrec/f77_sources/chder.for new file mode 100644 index 0000000..a160def --- /dev/null +++ b/dataassim/math/numrec/f77_sources/chder.for @@ -0,0 +1,16 @@ + SUBROUTINE chder(a,b,c,cder,n) + INTEGER n + REAL a,b,c(n),cder(n) + INTEGER j + REAL con + cder(n)=0. + cder(n-1)=2*(n-1)*c(n) + do 11 j=n-2,1,-1 + cder(j)=cder(j+2)+2*j*c(j+1) +11 continue + con=2./(b-a) + do 12 j=1,n + cder(j)=cder(j)*con +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/chebev.for b/dataassim/math/numrec/f77_sources/chebev.for new file mode 100644 index 0000000..ed9e2b8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/chebev.for @@ -0,0 +1,18 @@ + FUNCTION chebev(a,b,c,m,x) + INTEGER m + REAL chebev,a,b,x,c(m) + INTEGER j + REAL d,dd,sv,y,y2 + if ((x-a)*(x-b).gt.0.) pause 'x not in range in chebev' + d=0. + dd=0. + y=(2.*x-a-b)/(b-a) + y2=2.*y + do 11 j=m,2,-1 + sv=d + d=y2*d-dd+c(j) + dd=sv +11 continue + chebev=y*d-dd+0.5*c(1) + return + END diff --git a/dataassim/math/numrec/f77_sources/chebft.for b/dataassim/math/numrec/f77_sources/chebft.for new file mode 100644 index 0000000..c319968 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/chebft.for @@ -0,0 +1,24 @@ + SUBROUTINE chebft(a,b,c,n,func) + INTEGER n,NMAX + REAL a,b,c(n),func,PI + EXTERNAL func + PARAMETER (NMAX=50, PI=3.141592653589793d0) + INTEGER j,k + REAL bma,bpa,fac,y,f(NMAX) + DOUBLE PRECISION sum + bma=0.5*(b-a) + bpa=0.5*(b+a) + do 11 k=1,n + y=cos(PI*(k-0.5)/n) + f(k)=func(y*bma+bpa) +11 continue + fac=2./n + do 13 j=1,n + sum=0.d0 + do 12 k=1,n + sum=sum+f(k)*cos((PI*(j-1))*((k-0.5d0)/n)) +12 continue + c(j)=fac*sum +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/chebpc.for b/dataassim/math/numrec/f77_sources/chebpc.for new file mode 100644 index 0000000..46cc231 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/chebpc.for @@ -0,0 +1,27 @@ + SUBROUTINE chebpc(c,d,n) + INTEGER n,NMAX + REAL c(n),d(n) + PARAMETER (NMAX=50) + INTEGER j,k + REAL sv,dd(NMAX) + do 11 j=1,n + d(j)=0. + dd(j)=0. +11 continue + d(1)=c(n) + do 13 j=n-1,2,-1 + do 12 k=n-j+1,2,-1 + sv=d(k) + d(k)=2.*d(k-1)-dd(k) + dd(k)=sv +12 continue + sv=d(1) + d(1)=-dd(1)+c(j) + dd(1)=sv +13 continue + do 14 j=n,2,-1 + d(j)=d(j-1)-dd(j) +14 continue + d(1)=-dd(1)+0.5*c(1) + return + END diff --git a/dataassim/math/numrec/f77_sources/chint.for b/dataassim/math/numrec/f77_sources/chint.for new file mode 100644 index 0000000..f98cf05 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/chint.for @@ -0,0 +1,18 @@ + SUBROUTINE chint(a,b,c,cint,n) + INTEGER n + REAL a,b,c(n),cint(n) + INTEGER j + REAL con,fac,sum + con=0.25*(b-a) + sum=0. + fac=1. + do 11 j=2,n-1 + cint(j)=con*(c(j-1)-c(j+1))/(j-1) + sum=sum+fac*cint(j) + fac=-fac +11 continue + cint(n)=con*c(n-1)/(n-1) + sum=sum+fac*cint(n) + cint(1)=2.*sum + return + END diff --git a/dataassim/math/numrec/f77_sources/chixy.for b/dataassim/math/numrec/f77_sources/chixy.for new file mode 100644 index 0000000..4aa0dc2 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/chixy.for @@ -0,0 +1,32 @@ + FUNCTION chixy(bang) + REAL chixy,bang,BIG + INTEGER NMAX + PARAMETER (NMAX=1000,BIG=1.E30) + INTEGER nn,j + REAL xx(NMAX),yy(NMAX),sx(NMAX),sy(NMAX),ww(NMAX),aa,offs,avex, + *avey,sumw,b + COMMON /fitxyc/ xx,yy,sx,sy,ww,aa,offs,nn + b=tan(bang) + avex=0. + avey=0. + sumw=0. + do 11 j=1,nn + ww(j)=(b*sx(j))**2+sy(j)**2 + if(ww(j).lt.1./BIG) then + ww(j)=BIG + else + ww(j)=1./ww(j) + endif + sumw=sumw+ww(j) + avex=avex+ww(j)*xx(j) + avey=avey+ww(j)*yy(j) +11 continue + avex=avex/sumw + avey=avey/sumw + aa=avey-b*avex + chixy=-offs + do 12 j=1,nn + chixy=chixy+ww(j)*(yy(j)-aa-b*xx(j))**2 +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/choldc.for b/dataassim/math/numrec/f77_sources/choldc.for new file mode 100644 index 0000000..02fd80a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/choldc.for @@ -0,0 +1,21 @@ + SUBROUTINE choldc(a,n,np,p) + INTEGER n,np + REAL a(np,np),p(n) + INTEGER i,j,k + REAL sum + do 13 i=1,n + do 12 j=i,n + sum=a(i,j) + do 11 k=i-1,1,-1 + sum=sum-a(i,k)*a(j,k) +11 continue + if(i.eq.j)then + if(sum.le.0.)pause 'choldc failed' + p(i)=sqrt(sum) + else + a(j,i)=sum/p(i) + endif +12 continue +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/cholsl.for b/dataassim/math/numrec/f77_sources/cholsl.for new file mode 100644 index 0000000..aa76521 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/cholsl.for @@ -0,0 +1,21 @@ + SUBROUTINE cholsl(a,n,np,p,b,x) + INTEGER n,np + REAL a(np,np),b(n),p(n),x(n) + INTEGER i,k + REAL sum + do 12 i=1,n + sum=b(i) + do 11 k=i-1,1,-1 + sum=sum-a(i,k)*x(k) +11 continue + x(i)=sum/p(i) +12 continue + do 14 i=n,1,-1 + sum=x(i) + do 13 k=i+1,n + sum=sum-a(k,i)*x(k) +13 continue + x(i)=sum/p(i) +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/chsone.for b/dataassim/math/numrec/f77_sources/chsone.for new file mode 100644 index 0000000..f31485c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/chsone.for @@ -0,0 +1,15 @@ + SUBROUTINE chsone(bins,ebins,nbins,knstrn,df,chsq,prob) + INTEGER knstrn,nbins + REAL chsq,df,prob,bins(nbins),ebins(nbins) +CU USES gammq + INTEGER j + REAL gammq + df=nbins-knstrn + chsq=0. + do 11 j=1,nbins + if(ebins(j).le.0.)pause 'bad expected number in chsone' + chsq=chsq+(bins(j)-ebins(j))**2/ebins(j) +11 continue + prob=gammq(0.5*df,0.5*chsq) + return + END diff --git a/dataassim/math/numrec/f77_sources/chstwo.for b/dataassim/math/numrec/f77_sources/chstwo.for new file mode 100644 index 0000000..2d15e9e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/chstwo.for @@ -0,0 +1,18 @@ + SUBROUTINE chstwo(bins1,bins2,nbins,knstrn,df,chsq,prob) + INTEGER knstrn,nbins + REAL chsq,df,prob,bins1(nbins),bins2(nbins) +CU USES gammq + INTEGER j + REAL gammq + df=nbins-knstrn + chsq=0. + do 11 j=1,nbins + if(bins1(j).eq.0..and.bins2(j).eq.0.)then + df=df-1. + else + chsq=chsq+(bins1(j)-bins2(j))**2/(bins1(j)+bins2(j)) + endif +11 continue + prob=gammq(0.5*df,0.5*chsq) + return + END diff --git a/dataassim/math/numrec/f77_sources/cisi.for b/dataassim/math/numrec/f77_sources/cisi.for new file mode 100644 index 0000000..8c62af7 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/cisi.for @@ -0,0 +1,70 @@ + SUBROUTINE cisi(x,ci,si) + INTEGER MAXIT + REAL ci,si,x,EPS,EULER,PIBY2,FPMIN,TMIN + PARAMETER (EPS=6.e-8,EULER=.57721566,MAXIT=100,PIBY2=1.5707963, + *FPMIN=1.e-30,TMIN=2.) + INTEGER i,k + REAL a,err,fact,sign,sum,sumc,sums,t,term,absc + COMPLEX h,b,c,d,del + LOGICAL odd + absc(h)=abs(real(h))+abs(aimag(h)) + t=abs(x) + if(t.eq.0.)then + si=0. + ci=-1./FPMIN + return + endif + if(t.gt.TMIN)then + b=cmplx(1.,t) + c=1./FPMIN + d=1./b + h=d + do 11 i=2,MAXIT + a=-(i-1)**2 + b=b+2. + d=1./(a*d+b) + c=b+a/c + del=c*d + h=h*del + if(absc(del-1.).lt.EPS)goto 1 +11 continue + pause 'cf failed in cisi' +1 continue + h=cmplx(cos(t),-sin(t))*h + ci=-real(h) + si=PIBY2+aimag(h) + else + if(t.lt.sqrt(FPMIN))then + sumc=0. + sums=t + else + sum=0. + sums=0. + sumc=0. + sign=1. + fact=1. + odd=.true. + do 12 k=1,MAXIT + fact=fact*t/k + term=fact/k + sum=sum+sign*term + err=term/abs(sum) + if(odd)then + sign=-sign + sums=sum + sum=sumc + else + sumc=sum + sum=sums + endif + if(err.lt.EPS)goto 2 + odd=.not.odd +12 continue + pause 'maxits exceeded in cisi' + endif +2 si=sums + ci=sumc+log(t)+EULER + endif + if(x.lt.0.)si=-si + return + END diff --git a/dataassim/math/numrec/f77_sources/cntab1.for b/dataassim/math/numrec/f77_sources/cntab1.for new file mode 100644 index 0000000..593ca8e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/cntab1.for @@ -0,0 +1,38 @@ + SUBROUTINE cntab1(nn,ni,nj,chisq,df,prob,cramrv,ccc) + INTEGER ni,nj,nn(ni,nj),MAXI,MAXJ + REAL ccc,chisq,cramrv,df,prob,TINY + PARAMETER (MAXI=100,MAXJ=100,TINY=1.e-30) +CU USES gammq + INTEGER i,j,nni,nnj + REAL expctd,sum,sumi(MAXI),sumj(MAXJ),gammq + sum=0 + nni=ni + nnj=nj + do 12 i=1,ni + sumi(i)=0. + do 11 j=1,nj + sumi(i)=sumi(i)+nn(i,j) + sum=sum+nn(i,j) +11 continue + if(sumi(i).eq.0.)nni=nni-1 +12 continue + do 14 j=1,nj + sumj(j)=0. + do 13 i=1,ni + sumj(j)=sumj(j)+nn(i,j) +13 continue + if(sumj(j).eq.0.)nnj=nnj-1 +14 continue + df=nni*nnj-nni-nnj+1 + chisq=0. + do 16 i=1,ni + do 15 j=1,nj + expctd=sumj(j)*sumi(i)/sum + chisq=chisq+(nn(i,j)-expctd)**2/(expctd+TINY) +15 continue +16 continue + prob=gammq(0.5*df,0.5*chisq) + cramrv=sqrt(chisq/(sum*min(nni-1,nnj-1))) + ccc=sqrt(chisq/(chisq+sum)) + return + END diff --git a/dataassim/math/numrec/f77_sources/cntab2.for b/dataassim/math/numrec/f77_sources/cntab2.for new file mode 100644 index 0000000..187bf4f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/cntab2.for @@ -0,0 +1,50 @@ + SUBROUTINE cntab2(nn,ni,nj,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy) + INTEGER ni,nj,nn(ni,nj),MAXI,MAXJ + REAL h,hx,hxgy,hy,hygx,uxgy,uxy,uygx,TINY + PARAMETER (MAXI=100,MAXJ=100,TINY=1.e-30) + INTEGER i,j + REAL p,sum,sumi(MAXI),sumj(MAXJ) + sum=0 + do 12 i=1,ni + sumi(i)=0.0 + do 11 j=1,nj + sumi(i)=sumi(i)+nn(i,j) + sum=sum+nn(i,j) +11 continue +12 continue + do 14 j=1,nj + sumj(j)=0. + do 13 i=1,ni + sumj(j)=sumj(j)+nn(i,j) +13 continue +14 continue + hx=0. + do 15 i=1,ni + if(sumi(i).ne.0.)then + p=sumi(i)/sum + hx=hx-p*log(p) + endif +15 continue + hy=0. + do 16 j=1,nj + if(sumj(j).ne.0.)then + p=sumj(j)/sum + hy=hy-p*log(p) + endif +16 continue + h=0. + do 18 i=1,ni + do 17 j=1,nj + if(nn(i,j).ne.0)then + p=nn(i,j)/sum + h=h-p*log(p) + endif +17 continue +18 continue + hygx=h-hx + hxgy=h-hy + uygx=(hy-hygx)/(hy+TINY) + uxgy=(hx-hxgy)/(hx+TINY) + uxy=2.*(hx+hy-h)/(hx+hy+TINY) + return + END diff --git a/dataassim/math/numrec/f77_sources/convlv.for b/dataassim/math/numrec/f77_sources/convlv.for new file mode 100644 index 0000000..e15c7eb --- /dev/null +++ b/dataassim/math/numrec/f77_sources/convlv.for @@ -0,0 +1,31 @@ + SUBROUTINE convlv(data,n,respns,m,isign,ans) + INTEGER isign,m,n,NMAX + REAL data(n),respns(n) + COMPLEX ans(n) + PARAMETER (NMAX=4096) +CU USES realft,twofft + INTEGER i,no2 + COMPLEX fft(NMAX) + do 11 i=1,(m-1)/2 + respns(n+1-i)=respns(m+1-i) +11 continue + do 12 i=(m+3)/2,n-(m-1)/2 + respns(i)=0.0 +12 continue + call twofft(data,respns,fft,ans,n) + no2=n/2 + do 13 i=1,no2+1 + if (isign.eq.1) then + ans(i)=fft(i)*ans(i)/no2 + else if (isign.eq.-1) then + if (abs(ans(i)).eq.0.0) pause + *'deconvolving at response zero in convlv' + ans(i)=fft(i)/ans(i)/no2 + else + pause 'no meaning for isign in convlv' + endif +13 continue + ans(1)=cmplx(real(ans(1)),real(ans(no2+1))) + call realft(ans,n,-1) + return + END diff --git a/dataassim/math/numrec/f77_sources/copy.for b/dataassim/math/numrec/f77_sources/copy.for new file mode 100644 index 0000000..5891679 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/copy.for @@ -0,0 +1,11 @@ + SUBROUTINE copy(aout,ain,n) + INTEGER n + DOUBLE PRECISION ain(n,n),aout(n,n) + INTEGER i,j + do 12 i=1,n + do 11 j=1,n + aout(j,i)=ain(j,i) +11 continue +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/correl.for b/dataassim/math/numrec/f77_sources/correl.for new file mode 100644 index 0000000..3210173 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/correl.for @@ -0,0 +1,17 @@ + SUBROUTINE correl(data1,data2,n,ans) + INTEGER n,NMAX + REAL data1(n),data2(n) + COMPLEX ans(n) + PARAMETER (NMAX=4096) +CU USES realft,twofft + INTEGER i,no2 + COMPLEX fft(NMAX) + call twofft(data1,data2,fft,ans,n) + no2=n/2 + do 11 i=1,no2+1 + ans(i)=fft(i)*conjg(ans(i))/float(no2) +11 continue + ans(1)=cmplx(real(ans(1)),real(ans(no2+1))) + call realft(ans,n,-1) + return + END diff --git a/dataassim/math/numrec/f77_sources/cosft1.for b/dataassim/math/numrec/f77_sources/cosft1.for new file mode 100644 index 0000000..f678146 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/cosft1.for @@ -0,0 +1,33 @@ + SUBROUTINE cosft1(y,n) + INTEGER n + REAL y(n+1) +CU USES realft + INTEGER j + REAL sum,y1,y2 + DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp + theta=3.141592653589793d0/n + wr=1.0d0 + wi=0.0d0 + wpr=-2.0d0*sin(0.5d0*theta)**2 + wpi=sin(theta) + sum=0.5*(y(1)-y(n+1)) + y(1)=0.5*(y(1)+y(n+1)) + do 11 j=1,n/2-1 + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi + y1=0.5*(y(j+1)+y(n-j+1)) + y2=(y(j+1)-y(n-j+1)) + y(j+1)=y1-wi*y2 + y(n-j+1)=y1+wi*y2 + sum=sum+wr*y2 +11 continue + call realft(y,n,+1) + y(n+1)=y(2) + y(2)=sum + do 12 j=4,n,2 + sum=sum+y(j) + y(j)=sum +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/cosft2.for b/dataassim/math/numrec/f77_sources/cosft2.for new file mode 100644 index 0000000..786dd3a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/cosft2.for @@ -0,0 +1,69 @@ + SUBROUTINE cosft2(y,n,isign) + INTEGER isign,n + REAL y(n) +CU USES realft + INTEGER i + REAL sum,sum1,y1,y2,ytemp + DOUBLE PRECISION theta,wi,wi1,wpi,wpr,wr,wr1,wtemp,PI + PARAMETER (PI=3.141592653589793d0) + theta=0.5d0*PI/n + wr=1.0d0 + wi=0.0d0 + wr1=cos(theta) + wi1=sin(theta) + wpr=-2.0d0*wi1**2 + wpi=sin(2.d0*theta) + if(isign.eq.1)then + do 11 i=1,n/2 + y1=0.5*(y(i)+y(n-i+1)) + y2=wi1*(y(i)-y(n-i+1)) + y(i)=y1+y2 + y(n-i+1)=y1-y2 + wtemp=wr1 + wr1=wr1*wpr-wi1*wpi+wr1 + wi1=wi1*wpr+wtemp*wpi+wi1 +11 continue + call realft(y,n,1) + do 12 i=3,n,2 + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi + y1=y(i)*wr-y(i+1)*wi + y2=y(i+1)*wr+y(i)*wi + y(i)=y1 + y(i+1)=y2 +12 continue + sum=0.5*y(2) + do 13 i=n,2,-2 + sum1=sum + sum=sum+y(i) + y(i)=sum1 +13 continue + else if(isign.eq.-1)then + ytemp=y(n) + do 14 i=n,4,-2 + y(i)=y(i-2)-y(i) +14 continue + y(2)=2.0*ytemp + do 15 i=3,n,2 + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi + y1=y(i)*wr+y(i+1)*wi + y2=y(i+1)*wr-y(i)*wi + y(i)=y1 + y(i+1)=y2 +15 continue + call realft(y,n,-1) + do 16 i=1,n/2 + y1=y(i)+y(n-i+1) + y2=(0.5/wi1)*(y(i)-y(n-i+1)) + y(i)=0.5*(y1+y2) + y(n-i+1)=0.5*(y1-y2) + wtemp=wr1 + wr1=wr1*wpr-wi1*wpi+wr1 + wi1=wi1*wpr+wtemp*wpi+wi1 +16 continue + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/covsrt.for b/dataassim/math/numrec/f77_sources/covsrt.for new file mode 100644 index 0000000..0a93cc8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/covsrt.for @@ -0,0 +1,29 @@ + SUBROUTINE covsrt(covar,npc,ma,ia,mfit) + INTEGER ma,mfit,npc,ia(ma) + REAL covar(npc,npc) + INTEGER i,j,k + REAL swap + do 12 i=mfit+1,ma + do 11 j=1,i + covar(i,j)=0. + covar(j,i)=0. +11 continue +12 continue + k=mfit + do 15 j=ma,1,-1 + if(ia(j).ne.0)then + do 13 i=1,ma + swap=covar(i,k) + covar(i,k)=covar(i,j) + covar(i,j)=swap +13 continue + do 14 i=1,ma + swap=covar(k,i) + covar(k,i)=covar(j,i) + covar(j,i)=swap +14 continue + k=k-1 + endif +15 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/crank.for b/dataassim/math/numrec/f77_sources/crank.for new file mode 100644 index 0000000..70201f6 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/crank.for @@ -0,0 +1,29 @@ + SUBROUTINE crank(n,w,s) + INTEGER n + REAL s,w(n) + INTEGER j,ji,jt + REAL rank,t + s=0. + j=1 +1 if(j.lt.n)then + if(w(j+1).ne.w(j))then + w(j)=j + j=j+1 + else + do 11 jt=j+1,n + if(w(jt).ne.w(j))goto 2 +11 continue + jt=n+1 +2 rank=0.5*(j+jt-1) + do 12 ji=j,jt-1 + w(ji)=rank +12 continue + t=jt-j + s=s+t**3-t + j=jt + endif + goto 1 + endif + if(j.eq.n)w(n)=n + return + END diff --git a/dataassim/math/numrec/f77_sources/cyclic.for b/dataassim/math/numrec/f77_sources/cyclic.for new file mode 100644 index 0000000..4537e3d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/cyclic.for @@ -0,0 +1,28 @@ + SUBROUTINE cyclic(a,b,c,alpha,beta,r,x,n) + INTEGER n,NMAX + REAL alpha,beta,a(n),b(n),c(n),r(n),x(n) + PARAMETER (NMAX=500) +CU USES tridag + INTEGER i + REAL fact,gamma,bb(NMAX),u(NMAX),z(NMAX) + if(n.le.2)pause 'n too small in cyclic' + if(n.gt.NMAX)pause 'NMAX too small in cyclic' + gamma=-b(1) + bb(1)=b(1)-gamma + bb(n)=b(n)-alpha*beta/gamma + do 11 i=2,n-1 + bb(i)=b(i) +11 continue + call tridag(a,bb,c,r,x,n) + u(1)=gamma + u(n)=alpha + do 12 i=2,n-1 + u(i)=0. +12 continue + call tridag(a,bb,c,u,z,n) + fact=(x(1)+beta*x(n)/gamma)/(1.+z(1)+beta*z(n)/gamma) + do 13 i=1,n + x(i)=x(i)-fact*z(i) +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/daub4.for b/dataassim/math/numrec/f77_sources/daub4.for new file mode 100644 index 0000000..ce5e615 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/daub4.for @@ -0,0 +1,35 @@ + SUBROUTINE daub4(a,n,isign) + INTEGER n,isign,NMAX + REAL a(n),C3,C2,C1,C0 + PARAMETER (C0=0.4829629131445341,C1=0.8365163037378079, + *C2=0.2241438680420134,C3=-0.1294095225512604,NMAX=1024) + REAL wksp(NMAX) + INTEGER nh,nh1,i,j + if(n.lt.4)return + if(n.gt.NMAX) pause 'wksp too small in daub4' + nh=n/2 + nh1=nh+1 + if (isign.ge.0) then + i=1 + do 11 j=1,n-3,2 + wksp(i)=C0*a(j)+C1*a(j+1)+C2*a(j+2)+C3*a(j+3) + wksp(i+nh)=C3*a(j)-C2*a(j+1)+C1*a(j+2)-C0*a(j+3) + i=i+1 +11 continue + wksp(i)=C0*a(n-1)+C1*a(n)+C2*a(1)+C3*a(2) + wksp(i+nh)=C3*a(n-1)-C2*a(n)+C1*a(1)-C0*a(2) + else + wksp(1)=C2*a(nh)+C1*a(n)+C0*a(1)+C3*a(nh1) + wksp(2)=C3*a(nh)-C0*a(n)+C1*a(1)-C2*a(nh1) + j=3 + do 12 i=1,nh-1 + wksp(j)=C2*a(i)+C1*a(i+nh)+C0*a(i+1)+C3*a(i+nh1) + wksp(j+1)=C3*a(i)-C0*a(i+nh)+C1*a(i+1)-C2*a(i+nh1) + j=j+2 +12 continue + endif + do 13 i=1,n + a(i)=wksp(i) +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/dawson.for b/dataassim/math/numrec/f77_sources/dawson.for new file mode 100644 index 0000000..e30c726 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dawson.for @@ -0,0 +1,36 @@ + FUNCTION dawson(x) + INTEGER NMAX + REAL dawson,x,H,A1,A2,A3 + PARAMETER (NMAX=6,H=0.4,A1=2./3.,A2=0.4,A3=2./7.) + INTEGER i,init,n0 + REAL d1,d2,e1,e2,sum,x2,xp,xx,c(NMAX) + SAVE init,c + DATA init/0/ + if(init.eq.0)then + init=1 + do 11 i=1,NMAX + c(i)=exp(-((2.*float(i)-1.)*H)**2) +11 continue + endif + if(abs(x).lt.0.2)then + x2=x**2 + dawson=x*(1.-A1*x2*(1.-A2*x2*(1.-A3*x2))) + else + xx=abs(x) + n0=2*nint(0.5*xx/H) + xp=xx-float(n0)*H + e1=exp(2.*xp*H) + e2=e1**2 + d1=float(n0+1) + d2=d1-2. + sum=0. + do 12 i=1,NMAX + sum=sum+c(i)*(e1/d1+1./(d2*e1)) + d1=d1+2. + d2=d2-2. + e1=e2*e1 +12 continue + dawson=0.5641895835*sign(exp(-xp**2),x)*sum + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/dbrent.for b/dataassim/math/numrec/f77_sources/dbrent.for new file mode 100644 index 0000000..ab62cee --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dbrent.for @@ -0,0 +1,110 @@ + FUNCTION dbrent(ax,bx,cx,f,df,tol,xmin) + INTEGER ITMAX + REAL dbrent,ax,bx,cx,tol,xmin,df,f,ZEPS + EXTERNAL df,f + PARAMETER (ITMAX=100,ZEPS=1.0e-10) + INTEGER iter + REAL a,b,d,d1,d2,du,dv,dw,dx,e,fu,fv,fw,fx,olde,tol1,tol2,u,u1,u2, + *v,w,x,xm + LOGICAL ok1,ok2 + a=min(ax,cx) + b=max(ax,cx) + v=bx + w=v + x=v + e=0. + fx=f(x) + fv=fx + fw=fx + dx=df(x) + dv=dx + dw=dx + do 11 iter=1,ITMAX + xm=0.5*(a+b) + tol1=tol*abs(x)+ZEPS + tol2=2.*tol1 + if(abs(x-xm).le.(tol2-.5*(b-a))) goto 3 + if(abs(e).gt.tol1) then + d1=2.*(b-a) + d2=d1 + if(dw.ne.dx) d1=(w-x)*dx/(dx-dw) + if(dv.ne.dx) d2=(v-x)*dx/(dx-dv) + u1=x+d1 + u2=x+d2 + ok1=((a-u1)*(u1-b).gt.0.).and.(dx*d1.le.0.) + ok2=((a-u2)*(u2-b).gt.0.).and.(dx*d2.le.0.) + olde=e + e=d + if(.not.(ok1.or.ok2))then + goto 1 + else if (ok1.and.ok2)then + if(abs(d1).lt.abs(d2))then + d=d1 + else + d=d2 + endif + else if (ok1)then + d=d1 + else + d=d2 + endif + if(abs(d).gt.abs(0.5*olde))goto 1 + u=x+d + if(u-a.lt.tol2 .or. b-u.lt.tol2) d=sign(tol1,xm-x) + goto 2 + endif +1 if(dx.ge.0.) then + e=a-x + else + e=b-x + endif + d=0.5*e +2 if(abs(d).ge.tol1) then + u=x+d + fu=f(u) + else + u=x+sign(tol1,d) + fu=f(u) + if(fu.gt.fx)goto 3 + endif + du=df(u) + if(fu.le.fx) then + if(u.ge.x) then + a=x + else + b=x + endif + v=w + fv=fw + dv=dw + w=x + fw=fx + dw=dx + x=u + fx=fu + dx=du + else + if(u.lt.x) then + a=u + else + b=u + endif + if(fu.le.fw .or. w.eq.x) then + v=w + fv=fw + dv=dw + w=u + fw=fu + dw=du + else if(fu.le.fv .or. v.eq.x .or. v.eq.w) then + v=u + fv=fu + dv=du + endif + endif +11 continue + pause 'dbrent exceeded maximum iterations' +3 xmin=x + dbrent=fx + return + END diff --git a/dataassim/math/numrec/f77_sources/ddpoly.for b/dataassim/math/numrec/f77_sources/ddpoly.for new file mode 100644 index 0000000..25aaf6b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ddpoly.for @@ -0,0 +1,23 @@ + SUBROUTINE ddpoly(c,nc,x,pd,nd) + INTEGER nc,nd + REAL x,c(nc),pd(nd) + INTEGER i,j,nnd + REAL const + pd(1)=c(nc) + do 11 j=2,nd + pd(j)=0. +11 continue + do 13 i=nc-1,1,-1 + nnd=min(nd,nc+1-i) + do 12 j=nnd,2,-1 + pd(j)=pd(j)*x+pd(j-1) +12 continue + pd(1)=pd(1)*x+c(i) +13 continue + const=2. + do 14 i=3,nd + pd(i)=const*pd(i) + const=const*i +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/decchk.for b/dataassim/math/numrec/f77_sources/decchk.for new file mode 100644 index 0000000..66bc1db --- /dev/null +++ b/dataassim/math/numrec/f77_sources/decchk.for @@ -0,0 +1,27 @@ + LOGICAL FUNCTION decchk(string,n,ch) + INTEGER n + CHARACTER string*(*),ch*1 + INTEGER ij(10,10),ip(10,8),i,j,k,m + SAVE ij,ip + DATA ip/0,1,2,3,4,5,6,7,8,9,1,5,7,6,2,8,3,0,9,4,5,8,0,3,7,9,6,1,4, + *2,8,9,1,6,0,4,3,5,2,7,9,4,5,3,1,2,6,8,7,0,4,2,8,6,5,7,3,9,0,1,2,7, + *9,3,8,0,6,4,1,5,7,0,4,6,9,1,3,2,5,8/,ij/0,1,2,3,4,5,6,7,8,9,1,2,3, + *4,0,9,5,6,7,8,2,3,4,0,1,8,9,5,6,7,3,4,0,1,2,7,8,9,5,6,4,0,1,2,3,6, + *7,8,9,5,5,6,7,8,9,0,1,2,3,4,6,7,8,9,5,4,0,1,2,3,7,8,9,5,6,3,4,0,1, + *2,8,9,5,6,7,2,3,4,0,1,9,5,6,7,8,1,2,3,4,0/ + k=0 + m=0 + do 11 j=1,n + i=ichar(string(j:j)) + if (i.ge.48.and.i.le.57)then + k=ij(k+1,ip(mod(i+2,10)+1,mod(m,8)+1)+1) + m=m+1 + endif +11 continue + decchk=(k.eq.0) + do 12 i=0,9 + if (ij(k+1,ip(i+1,mod(m,8)+1)+1).eq.0) goto 1 +12 continue +1 ch=char(i+48) + return + end diff --git a/dataassim/math/numrec/f77_sources/df1dim.for b/dataassim/math/numrec/f77_sources/df1dim.for new file mode 100644 index 0000000..2ad6a0a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/df1dim.for @@ -0,0 +1,18 @@ + FUNCTION df1dim(x) + INTEGER NMAX + REAL df1dim,x + PARAMETER (NMAX=50) +CU USES dfunc + INTEGER j,ncom + REAL df(NMAX),pcom(NMAX),xicom(NMAX),xt(NMAX) + COMMON /f1com/ pcom,xicom,ncom + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call dfunc(xt,df) + df1dim=0. + do 12 j=1,ncom + df1dim=df1dim+df(j)*xicom(j) +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/dfour1.for b/dataassim/math/numrec/f77_sources/dfour1.for new file mode 100644 index 0000000..c9eadcd --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dfour1.for @@ -0,0 +1,52 @@ + SUBROUTINE dfour1(data,nn,isign) + INTEGER isign,nn + DOUBLE PRECISION data(2*nn) + INTEGER i,istep,j,m,mmax,n + DOUBLE PRECISION tempi,tempr + DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp + n=2*nn + j=1 + do 11 i=1,n,2 + if(j.gt.i)then + tempr=data(j) + tempi=data(j+1) + data(j)=data(i) + data(j+1)=data(i+1) + data(i)=tempr + data(i+1)=tempi + endif + m=n/2 +1 if ((m.ge.2).and.(j.gt.m)) then + j=j-m + m=m/2 + goto 1 + endif + j=j+m +11 continue + mmax=2 +2 if (n.gt.mmax) then + istep=2*mmax + theta=6.28318530717959d0/(isign*mmax) + wpr=-2.d0*sin(0.5d0*theta)**2 + wpi=sin(theta) + wr=1.d0 + wi=0.d0 + do 13 m=1,mmax,2 + do 12 i=m,n,istep + j=i+mmax + tempr=wr*data(j)-wi*data(j+1) + tempi=wr*data(j+1)+wi*data(j) + data(j)=data(i)-tempr + data(j+1)=data(i+1)-tempi + data(i)=data(i)+tempr + data(i+1)=data(i+1)+tempi +12 continue + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi +13 continue + mmax=istep + goto 2 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/dfpmin.for b/dataassim/math/numrec/f77_sources/dfpmin.for new file mode 100644 index 0000000..28c6da4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dfpmin.for @@ -0,0 +1,89 @@ + SUBROUTINE dfpmin(p,n,gtol,iter,fret,func,dfunc) + INTEGER iter,n,NMAX,ITMAX + REAL fret,gtol,p(n),func,EPS,STPMX,TOLX + PARAMETER (NMAX=50,ITMAX=200,STPMX=100.,EPS=3.e-8,TOLX=4.*EPS) + EXTERNAL dfunc,func +CU USES dfunc,func,lnsrch + INTEGER i,its,j + LOGICAL check + REAL den,fac,fad,fae,fp,stpmax,sum,sumdg,sumxi,temp,test,dg(NMAX), + *g(NMAX),hdg(NMAX),hessin(NMAX,NMAX),pnew(NMAX),xi(NMAX) + fp=func(p) + call dfunc(p,g) + sum=0. + do 12 i=1,n + do 11 j=1,n + hessin(i,j)=0. +11 continue + hessin(i,i)=1. + xi(i)=-g(i) + sum=sum+p(i)**2 +12 continue + stpmax=STPMX*max(sqrt(sum),float(n)) + do 27 its=1,ITMAX + iter=its + call lnsrch(n,p,fp,g,xi,pnew,fret,stpmax,check,func) + fp=fret + do 13 i=1,n + xi(i)=pnew(i)-p(i) + p(i)=pnew(i) +13 continue + test=0. + do 14 i=1,n + temp=abs(xi(i))/max(abs(p(i)),1.) + if(temp.gt.test)test=temp +14 continue + if(test.lt.TOLX)return + do 15 i=1,n + dg(i)=g(i) +15 continue + call dfunc(p,g) + test=0. + den=max(fret,1.) + do 16 i=1,n + temp=abs(g(i))*max(abs(p(i)),1.)/den + if(temp.gt.test)test=temp +16 continue + if(test.lt.gtol)return + do 17 i=1,n + dg(i)=g(i)-dg(i) +17 continue + do 19 i=1,n + hdg(i)=0. + do 18 j=1,n + hdg(i)=hdg(i)+hessin(i,j)*dg(j) +18 continue +19 continue + fac=0. + fae=0. + sumdg=0. + sumxi=0. + do 21 i=1,n + fac=fac+dg(i)*xi(i) + fae=fae+dg(i)*hdg(i) + sumdg=sumdg+dg(i)**2 + sumxi=sumxi+xi(i)**2 +21 continue + if(fac**2.gt.EPS*sumdg*sumxi)then + fac=1./fac + fad=1./fae + do 22 i=1,n + dg(i)=fac*xi(i)-fad*hdg(i) +22 continue + do 24 i=1,n + do 23 j=1,n + hessin(i,j)=hessin(i,j)+fac*xi(i)*xi(j)-fad*hdg(i)*hdg(j)+ + *fae*dg(i)*dg(j) +23 continue +24 continue + endif + do 26 i=1,n + xi(i)=0. + do 25 j=1,n + xi(i)=xi(i)-hessin(i,j)*g(j) +25 continue +26 continue +27 continue + pause 'too many iterations in dfpmin' + return + END diff --git a/dataassim/math/numrec/f77_sources/dfridr.for b/dataassim/math/numrec/f77_sources/dfridr.for new file mode 100644 index 0000000..08bd980 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dfridr.for @@ -0,0 +1,29 @@ + FUNCTION dfridr(func,x,h,err) + INTEGER NTAB + REAL dfridr,err,h,x,func,CON,CON2,BIG,SAFE + PARAMETER (CON=1.4,CON2=CON*CON,BIG=1.E30,NTAB=10,SAFE=2.) + EXTERNAL func +CU USES func + INTEGER i,j + REAL errt,fac,hh,a(NTAB,NTAB) + if(h.eq.0.) pause 'h must be nonzero in dfridr' + hh=h + a(1,1)=(func(x+hh)-func(x-hh))/(2.0*hh) + err=BIG + do 12 i=2,NTAB + hh=hh/CON + a(1,i)=(func(x+hh)-func(x-hh))/(2.0*hh) + fac=CON2 + do 11 j=2,i + a(j,i)=(a(j-1,i)*fac-a(j-1,i-1))/(fac-1.) + fac=CON2*fac + errt=max(abs(a(j,i)-a(j-1,i)),abs(a(j,i)-a(j-1,i-1))) + if (errt.le.err) then + err=errt + dfridr=a(j,i) + endif +11 continue + if(abs(a(i,i)-a(i-1,i-1)).ge.SAFE*err)return +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/dftcor.for b/dataassim/math/numrec/f77_sources/dftcor.for new file mode 100644 index 0000000..382dae1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dftcor.for @@ -0,0 +1,55 @@ + SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac) + REAL a,b,corfac,corim,corre,delta,w,endpts(8) + REAL a0i,a0r,a1i,a1r,a2i,a2r,a3i,a3r,arg,c,cl,cr,s,sl,sr,t,t2,t4, + *t6 + DOUBLE PRECISION cth,ctth,spth2,sth,sth4i,stth,th,th2,th4,tmth2, + *tth4i + th=w*delta + if (a.ge.b.or.th.lt.0.d0.or.th.gt.3.1416d0)pause + *'bad arguments to dftcor' + if(abs(th).lt.5.d-2)then + t=th + t2=t*t + t4=t2*t2 + t6=t4*t2 + corfac=1.-(11./720.)*t4+(23./15120.)*t6 + a0r=(-2./3.)+t2/45.+(103./15120.)*t4-(169./226800.)*t6 + a1r=(7./24.)-(7./180.)*t2+(5./3456.)*t4-(7./259200.)*t6 + a2r=(-1./6.)+t2/45.-(5./6048.)*t4+t6/64800. + a3r=(1./24.)-t2/180.+(5./24192.)*t4-t6/259200. + a0i=t*(2./45.+(2./105.)*t2-(8./2835.)*t4+(86./467775.)*t6) + a1i=t*(7./72.-t2/168.+(11./72576.)*t4-(13./5987520.)*t6) + a2i=t*(-7./90.+t2/210.-(11./90720.)*t4+(13./7484400.)*t6) + a3i=t*(7./360.-t2/840.+(11./362880.)*t4-(13./29937600.)*t6) + else + cth=cos(th) + sth=sin(th) + ctth=cth**2-sth**2 + stth=2.d0*sth*cth + th2=th*th + th4=th2*th2 + tmth2=3.d0-th2 + spth2=6.d0+th2 + sth4i=1./(6.d0*th4) + tth4i=2.d0*sth4i + corfac=tth4i*spth2*(3.d0-4.d0*cth+ctth) + a0r=sth4i*(-42.d0+5.d0*th2+spth2*(8.d0*cth-ctth)) + a0i=sth4i*(th*(-12.d0+6.d0*th2)+spth2*stth) + a1r=sth4i*(14.d0*tmth2-7.d0*spth2*cth) + a1i=sth4i*(30.d0*th-5.d0*spth2*sth) + a2r=tth4i*(-4.d0*tmth2+2.d0*spth2*cth) + a2i=tth4i*(-12.d0*th+2.d0*spth2*sth) + a3r=sth4i*(2.d0*tmth2-spth2*cth) + a3i=sth4i*(6.d0*th-spth2*sth) + endif + cl=a0r*endpts(1)+a1r*endpts(2)+a2r*endpts(3)+a3r*endpts(4) + sl=a0i*endpts(1)+a1i*endpts(2)+a2i*endpts(3)+a3i*endpts(4) + cr=a0r*endpts(8)+a1r*endpts(7)+a2r*endpts(6)+a3r*endpts(5) + sr=-a0i*endpts(8)-a1i*endpts(7)-a2i*endpts(6)-a3i*endpts(5) + arg=w*(b-a) + c=cos(arg) + s=sin(arg) + corre=cl+c*cr-s*sr + corim=sl+s*cr+c*sr + return + END diff --git a/dataassim/math/numrec/f77_sources/dftint.for b/dataassim/math/numrec/f77_sources/dftint.for new file mode 100644 index 0000000..7dd2f23 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dftint.for @@ -0,0 +1,48 @@ + SUBROUTINE dftint(func,a,b,w,cosint,sinint) + INTEGER M,NDFT,MPOL + REAL a,b,cosint,sinint,w,func,TWOPI + PARAMETER (M=64,NDFT=1024,MPOL=6,TWOPI=2.*3.14159265) + EXTERNAL func +CU USES dftcor,func,polint,realft + INTEGER init,j,nn + REAL aold,bold,c,cdft,cerr,corfac,corim,corre,delta,en,s,sdft, + *serr,cpol(MPOL),data(NDFT),endpts(8),spol(MPOL),xpol(MPOL) + SAVE init,aold,bold,delta,data,endpts + DATA init/0/,aold/-1.e30/,bold/-1.e30/ + if (init.ne.1.or.a.ne.aold.or.b.ne.bold) then + init=1 + aold=a + bold=b + delta=(b-a)/M + do 11 j=1,M+1 + data(j)=func(a+(j-1)*delta) +11 continue + do 12 j=M+2,NDFT + data(j)=0. +12 continue + do 13 j=1,4 + endpts(j)=data(j) + endpts(j+4)=data(M-3+j) +13 continue + call realft(data,NDFT,1) + data(2)=0. + endif + en=w*delta*NDFT/TWOPI+1. + nn=min(max(int(en-0.5*MPOL+1.),1),NDFT/2-MPOL+1) + do 14 j=1,MPOL + cpol(j)=data(2*nn-1) + spol(j)=data(2*nn) + xpol(j)=nn + nn=nn+1 +14 continue + call polint(xpol,cpol,MPOL,en,cdft,cerr) + call polint(xpol,spol,MPOL,en,sdft,serr) + call dftcor(w,delta,a,b,endpts,corre,corim,corfac) + cdft=cdft*corfac+corre + sdft=sdft*corfac+corim + c=delta*cos(w*a) + s=delta*sin(w*a) + cosint=c*cdft-s*sdft + sinint=s*cdft+c*sdft + return + END diff --git a/dataassim/math/numrec/f77_sources/difeq.for b/dataassim/math/numrec/f77_sources/difeq.for new file mode 100644 index 0000000..1348b15 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/difeq.for @@ -0,0 +1,57 @@ + SUBROUTINE difeq(k,k1,k2,jsf,is1,isf,indexv,ne,s,nsi,nsj,y,nyj, + *nyk) + INTEGER is1,isf,jsf,k,k1,k2,ne,nsi,nsj,nyj,nyk,indexv(nyj),M + REAL s(nsi,nsj),y(nyj,nyk) + COMMON /sfrcom/ x,h,mm,n,c2,anorm + PARAMETER (M=41) + INTEGER mm,n + REAL anorm,c2,h,temp,temp2,x(M) + if(k.eq.k1) then + if(mod(n+mm,2).eq.1)then + s(3,3+indexv(1))=1. + s(3,3+indexv(2))=0. + s(3,3+indexv(3))=0. + s(3,jsf)=y(1,1) + else + s(3,3+indexv(1))=0. + s(3,3+indexv(2))=1. + s(3,3+indexv(3))=0. + s(3,jsf)=y(2,1) + endif + else if(k.gt.k2) then + s(1,3+indexv(1))=-(y(3,M)-c2)/(2.*(mm+1.)) + s(1,3+indexv(2))=1. + s(1,3+indexv(3))=-y(1,M)/(2.*(mm+1.)) + s(1,jsf)=y(2,M)-(y(3,M)-c2)*y(1,M)/(2.*(mm+1.)) + s(2,3+indexv(1))=1. + s(2,3+indexv(2))=0. + s(2,3+indexv(3))=0. + s(2,jsf)=y(1,M)-anorm + else + s(1,indexv(1))=-1. + s(1,indexv(2))=-.5*h + s(1,indexv(3))=0. + s(1,3+indexv(1))=1. + s(1,3+indexv(2))=-.5*h + s(1,3+indexv(3))=0. + temp=h/(1.-(x(k)+x(k-1))**2*.25) + temp2=.5*(y(3,k)+y(3,k-1))-c2*.25*(x(k)+x(k-1))**2 + s(2,indexv(1))=temp*temp2*.5 + s(2,indexv(2))=-1.-.5*temp*(mm+1.)*(x(k)+x(k-1)) + s(2,indexv(3))=.25*temp*(y(1,k)+y(1,k-1)) + s(2,3+indexv(1))=s(2,indexv(1)) + s(2,3+indexv(2))=2.+s(2,indexv(2)) + s(2,3+indexv(3))=s(2,indexv(3)) + s(3,indexv(1))=0. + s(3,indexv(2))=0. + s(3,indexv(3))=-1. + s(3,3+indexv(1))=0. + s(3,3+indexv(2))=0. + s(3,3+indexv(3))=1. + s(1,jsf)=y(1,k)-y(1,k-1)-.5*h*(y(2,k)+y(2,k-1)) + s(2,jsf)=y(2,k)-y(2,k-1)-temp*((x(k)+x(k-1))*.5*(mm+1.)*(y(2,k)+ + *y(2,k-1))-temp2*.5*(y(1,k)+y(1,k-1))) + s(3,jsf)=y(3,k)-y(3,k-1) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/dpythag.for b/dataassim/math/numrec/f77_sources/dpythag.for new file mode 100644 index 0000000..e8f0905 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dpythag.for @@ -0,0 +1,16 @@ + FUNCTION dpythag(a,b) + DOUBLE PRECISION a,b,dpythag + DOUBLE PRECISION absa,absb + absa=abs(a) + absb=abs(b) + if(absa.gt.absb)then + dpythag=absa*sqrt(1.0d0+(absb/absa)**2) + else + if(absb.eq.0.0d0)then + dpythag=0.0d0 + else + dpythag=absb*sqrt(1.0d0+(absa/absb)**2) + endif + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/drealft.for b/dataassim/math/numrec/f77_sources/drealft.for new file mode 100644 index 0000000..8f7ae0d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/drealft.for @@ -0,0 +1,52 @@ + SUBROUTINE drealft(data,n,isign) + INTEGER isign,n + DOUBLE PRECISION data(n) +CU USES dfour1 + INTEGER i,i1,i2,i3,i4,n2p3 + DOUBLE PRECISION c1,c2,h1i,h1r,h2i,h2r,wis,wrs + DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp + theta=3.141592653589793d0/dble(n/2) + c1=0.5d0 + if (isign.eq.1) then + c2=-0.5d0 + call dfour1(data,n/2,+1) + else + c2=0.5d0 + theta=-theta + endif + wpr=-2.0d0*sin(0.5d0*theta)**2 + wpi=sin(theta) + wr=1.0d0+wpr + wi=wpi + n2p3=n+3 + do 11 i=2,n/4 + i1=2*i-1 + i2=i1+1 + i3=n2p3-i2 + i4=i3+1 + wrs=wr + wis=wi + h1r=c1*(data(i1)+data(i3)) + h1i=c1*(data(i2)-data(i4)) + h2r=-c2*(data(i2)+data(i4)) + h2i=c2*(data(i1)-data(i3)) + data(i1)=h1r+wrs*h2r-wis*h2i + data(i2)=h1i+wrs*h2i+wis*h2r + data(i3)=h1r-wrs*h2r+wis*h2i + data(i4)=-h1i+wrs*h2i+wis*h2r + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi +11 continue + if (isign.eq.1) then + h1r=data(1) + data(1)=h1r+data(2) + data(2)=h1r-data(2) + else + h1r=data(1) + data(1)=c1*(h1r+data(2)) + data(2)=c1*(h1r-data(2)) + call dfour1(data,n/2,-1) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/dsprsax.for b/dataassim/math/numrec/f77_sources/dsprsax.for new file mode 100644 index 0000000..d08d73f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dsprsax.for @@ -0,0 +1,13 @@ + SUBROUTINE dsprsax(sa,ija,x,b,n) + INTEGER n,ija(*) + DOUBLE PRECISION b(n),sa(*),x(n) + INTEGER i,k + if (ija(1).ne.n+2) pause 'mismatched vector and matrix in sprsax' + do 12 i=1,n + b(i)=sa(i)*x(i) + do 11 k=ija(i),ija(i+1)-1 + b(i)=b(i)+sa(k)*x(ija(k)) +11 continue +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/dsprstx.for b/dataassim/math/numrec/f77_sources/dsprstx.for new file mode 100644 index 0000000..e10cae4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dsprstx.for @@ -0,0 +1,16 @@ + SUBROUTINE dsprstx(sa,ija,x,b,n) + INTEGER n,ija(*) + DOUBLE PRECISION b(n),sa(*),x(n) + INTEGER i,j,k + if (ija(1).ne.n+2) pause 'mismatched vector and matrix in sprstx' + do 11 i=1,n + b(i)=sa(i)*x(i) +11 continue + do 13 i=1,n + do 12 k=ija(i),ija(i+1)-1 + j=ija(k) + b(j)=b(j)+sa(k)*x(i) +12 continue +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/dsvbksb.for b/dataassim/math/numrec/f77_sources/dsvbksb.for new file mode 100644 index 0000000..a655fa0 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dsvbksb.for @@ -0,0 +1,25 @@ + SUBROUTINE dsvbksb(u,w,v,m,n,mp,np,b,x) + INTEGER m,mp,n,np,NMAX + DOUBLE PRECISION b(mp),u(mp,np),v(np,np),w(np),x(np) + PARAMETER (NMAX=500) + INTEGER i,j,jj + DOUBLE PRECISION s,tmp(NMAX) + do 12 j=1,n + s=0.0d0 + if(w(j).ne.0.0d0)then + do 11 i=1,m + s=s+u(i,j)*b(i) +11 continue + s=s/w(j) + endif + tmp(j)=s +12 continue + do 14 j=1,n + s=0.0d0 + do 13 jj=1,n + s=s+v(j,jj)*tmp(jj) +13 continue + x(j)=s +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/dsvdcmp.for b/dataassim/math/numrec/f77_sources/dsvdcmp.for new file mode 100644 index 0000000..ac4a391 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/dsvdcmp.for @@ -0,0 +1,224 @@ + SUBROUTINE dsvdcmp(a,m,n,mp,np,w,v) + INTEGER m,mp,n,np,NMAX + DOUBLE PRECISION a(mp,np),v(np,np),w(np) + PARAMETER (NMAX=500) +CU USES dpythag + INTEGER i,its,j,jj,k,l,nm + DOUBLE PRECISION anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX),dpythag + g=0.0d0 + scale=0.0d0 + anorm=0.0d0 + do 25 i=1,n + l=i+1 + rv1(i)=scale*g + g=0.0d0 + s=0.0d0 + scale=0.0d0 + if(i.le.m)then + do 11 k=i,m + scale=scale+abs(a(k,i)) +11 continue + if(scale.ne.0.0d0)then + do 12 k=i,m + a(k,i)=a(k,i)/scale + s=s+a(k,i)*a(k,i) +12 continue + f=a(i,i) + g=-sign(sqrt(s),f) + h=f*g-s + a(i,i)=f-g + do 15 j=l,n + s=0.0d0 + do 13 k=i,m + s=s+a(k,i)*a(k,j) +13 continue + f=s/h + do 14 k=i,m + a(k,j)=a(k,j)+f*a(k,i) +14 continue +15 continue + do 16 k=i,m + a(k,i)=scale*a(k,i) +16 continue + endif + endif + w(i)=scale *g + g=0.0d0 + s=0.0d0 + scale=0.0d0 + if((i.le.m).and.(i.ne.n))then + do 17 k=l,n + scale=scale+abs(a(i,k)) +17 continue + if(scale.ne.0.0d0)then + do 18 k=l,n + a(i,k)=a(i,k)/scale + s=s+a(i,k)*a(i,k) +18 continue + f=a(i,l) + g=-sign(sqrt(s),f) + h=f*g-s + a(i,l)=f-g + do 19 k=l,n + rv1(k)=a(i,k)/h +19 continue + do 23 j=l,m + s=0.0d0 + do 21 k=l,n + s=s+a(j,k)*a(i,k) +21 continue + do 22 k=l,n + a(j,k)=a(j,k)+s*rv1(k) +22 continue +23 continue + do 24 k=l,n + a(i,k)=scale*a(i,k) +24 continue + endif + endif + anorm=max(anorm,(abs(w(i))+abs(rv1(i)))) +25 continue + do 32 i=n,1,-1 + if(i.lt.n)then + if(g.ne.0.0d0)then + do 26 j=l,n + v(j,i)=(a(i,j)/a(i,l))/g +26 continue + do 29 j=l,n + s=0.0d0 + do 27 k=l,n + s=s+a(i,k)*v(k,j) +27 continue + do 28 k=l,n + v(k,j)=v(k,j)+s*v(k,i) +28 continue +29 continue + endif + do 31 j=l,n + v(i,j)=0.0d0 + v(j,i)=0.0d0 +31 continue + endif + v(i,i)=1.0d0 + g=rv1(i) + l=i +32 continue + do 39 i=min(m,n),1,-1 + l=i+1 + g=w(i) + do 33 j=l,n + a(i,j)=0.0d0 +33 continue + if(g.ne.0.0d0)then + g=1.0d0/g + do 36 j=l,n + s=0.0d0 + do 34 k=l,m + s=s+a(k,i)*a(k,j) +34 continue + f=(s/a(i,i))*g + do 35 k=i,m + a(k,j)=a(k,j)+f*a(k,i) +35 continue +36 continue + do 37 j=i,m + a(j,i)=a(j,i)*g +37 continue + else + do 38 j= i,m + a(j,i)=0.0d0 +38 continue + endif + a(i,i)=a(i,i)+1.0d0 +39 continue + do 49 k=n,1,-1 + do 48 its=1,30 + do 41 l=k,1,-1 + nm=l-1 + if((abs(rv1(l))+anorm).eq.anorm) goto 2 + if((abs(w(nm))+anorm).eq.anorm) goto 1 +41 continue +1 c=0.0d0 + s=1.0d0 + do 43 i=l,k + f=s*rv1(i) + rv1(i)=c*rv1(i) + if((abs(f)+anorm).eq.anorm) goto 2 + g=w(i) + h=dpythag(f,g) + w(i)=h + h=1.0d0/h + c= (g*h) + s=-(f*h) + do 42 j=1,m + y=a(j,nm) + z=a(j,i) + a(j,nm)=(y*c)+(z*s) + a(j,i)=-(y*s)+(z*c) +42 continue +43 continue +2 z=w(k) + if(l.eq.k)then + if(z.lt.0.0d0)then + w(k)=-z + do 44 j=1,n + v(j,k)=-v(j,k) +44 continue + endif + goto 3 + endif + if(its.eq.30) pause 'no convergence in svdcmp' + x=w(l) + nm=k-1 + y=w(nm) + g=rv1(nm) + h=rv1(k) + f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0d0*h*y) + g=dpythag(f,1.0d0) + f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x + c=1.0d0 + s=1.0d0 + do 47 j=l,nm + i=j+1 + g=rv1(i) + y=w(i) + h=s*g + g=c*g + z=dpythag(f,h) + rv1(j)=z + c=f/z + s=h/z + f= (x*c)+(g*s) + g=-(x*s)+(g*c) + h=y*s + y=y*c + do 45 jj=1,n + x=v(jj,j) + z=v(jj,i) + v(jj,j)= (x*c)+(z*s) + v(jj,i)=-(x*s)+(z*c) +45 continue + z=dpythag(f,h) + w(j)=z + if(z.ne.0.0d0)then + z=1.0d0/z + c=f*z + s=h*z + endif + f= (c*g)+(s*y) + x=-(s*g)+(c*y) + do 46 jj=1,m + y=a(jj,j) + z=a(jj,i) + a(jj,j)= (y*c)+(z*s) + a(jj,i)=-(y*s)+(z*c) +46 continue +47 continue + rv1(l)=0.0d0 + rv1(k)=f + w(k)=x +48 continue +3 continue +49 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/eclass.for b/dataassim/math/numrec/f77_sources/eclass.for new file mode 100644 index 0000000..219ec2e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/eclass.for @@ -0,0 +1,27 @@ + SUBROUTINE eclass(nf,n,lista,listb,m) + INTEGER m,n,lista(m),listb(m),nf(n) + INTEGER j,k,l + do 11 k=1,n + nf(k)=k +11 continue + do 12 l=1,m + j=lista(l) +1 if(nf(j).ne.j)then + j=nf(j) + goto 1 + endif + k=listb(l) +2 if(nf(k).ne.k)then + k=nf(k) + goto 2 + endif + if(j.ne.k)nf(j)=k +12 continue + do 13 j=1,n +3 if(nf(j).ne.nf(nf(j)))then + nf(j)=nf(nf(j)) + goto 3 + endif +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/eclazz.for b/dataassim/math/numrec/f77_sources/eclazz.for new file mode 100644 index 0000000..3cffc88 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/eclazz.for @@ -0,0 +1,18 @@ + SUBROUTINE eclazz(nf,n,equiv) + INTEGER n,nf(n) + LOGICAL equiv + EXTERNAL equiv + INTEGER jj,kk + nf(1)=1 + do 12 jj=2,n + nf(jj)=jj + do 11 kk=1,jj-1 + nf(kk)=nf(nf(kk)) + if (equiv(jj,kk)) nf(nf(nf(kk)))=jj +11 continue +12 continue + do 13 jj=1,n + nf(jj)=nf(nf(jj)) +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/ei.for b/dataassim/math/numrec/f77_sources/ei.for new file mode 100644 index 0000000..4bbc328 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ei.for @@ -0,0 +1,38 @@ + FUNCTION ei(x) + INTEGER MAXIT + REAL ei,x,EPS,EULER,FPMIN + PARAMETER (EPS=6.e-8,EULER=.57721566,MAXIT=100,FPMIN=1.e-30) + INTEGER k + REAL fact,prev,sum,term + if(x.le.0.) pause 'bad argument in ei' + if(x.lt.FPMIN)then + ei=log(x)+EULER + else if(x.le.-log(EPS))then + sum=0. + fact=1. + do 11 k=1,MAXIT + fact=fact*x/k + term=fact/k + sum=sum+term + if(term.lt.EPS*sum)goto 1 +11 continue + pause 'series failed in ei' +1 ei=sum+log(x)+EULER + else + sum=0. + term=1. + do 12 k=1,MAXIT + prev=term + term=term*k/x + if(term.lt.EPS)goto 2 + if(term.lt.prev)then + sum=sum+term + else + sum=sum-prev + goto 2 + endif +12 continue +2 ei=exp(x)*(1.+sum)/x + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/eigsrt.for b/dataassim/math/numrec/f77_sources/eigsrt.for new file mode 100644 index 0000000..7394245 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/eigsrt.for @@ -0,0 +1,26 @@ + SUBROUTINE eigsrt(d,v,n,np) + INTEGER n,np + REAL d(np),v(np,np) + INTEGER i,j,k + REAL p + do 13 i=1,n-1 + k=i + p=d(i) + do 11 j=i+1,n + if(d(j).ge.p)then + k=j + p=d(j) + endif +11 continue + if(k.ne.i)then + d(k)=d(i) + d(i)=p + do 12 j=1,n + p=v(j,i) + v(j,i)=v(j,k) + v(j,k)=p +12 continue + endif +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/elle.for b/dataassim/math/numrec/f77_sources/elle.for new file mode 100644 index 0000000..c060ffe --- /dev/null +++ b/dataassim/math/numrec/f77_sources/elle.for @@ -0,0 +1,10 @@ + FUNCTION elle(phi,ak) + REAL elle,ak,phi +CU USES rd,rf + REAL cc,q,s,rd,rf + s=sin(phi) + cc=cos(phi)**2 + q=(1.-s*ak)*(1.+s*ak) + elle=s*(rf(cc,q,1.)-((s*ak)**2)*rd(cc,q,1.)/3.) + return + END diff --git a/dataassim/math/numrec/f77_sources/ellf.for b/dataassim/math/numrec/f77_sources/ellf.for new file mode 100644 index 0000000..e2b8430 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ellf.for @@ -0,0 +1,8 @@ + FUNCTION ellf(phi,ak) + REAL ellf,ak,phi +CU USES rf + REAL s,rf + s=sin(phi) + ellf=s*rf(cos(phi)**2,(1.-s*ak)*(1.+s*ak),1.) + return + END diff --git a/dataassim/math/numrec/f77_sources/ellpi.for b/dataassim/math/numrec/f77_sources/ellpi.for new file mode 100644 index 0000000..d4e5aa9 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ellpi.for @@ -0,0 +1,11 @@ + FUNCTION ellpi(phi,en,ak) + REAL ellpi,ak,en,phi +CU USES rf,rj + REAL cc,enss,q,s,rf,rj + s=sin(phi) + enss=en*s*s + cc=cos(phi)**2 + q=(1.-s*ak)*(1.+s*ak) + ellpi=s*(rf(cc,q,1.)-enss*rj(cc,q,1.,1.+enss)/3.) + return + END diff --git a/dataassim/math/numrec/f77_sources/elmhes.for b/dataassim/math/numrec/f77_sources/elmhes.for new file mode 100644 index 0000000..fdc461c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/elmhes.for @@ -0,0 +1,44 @@ + SUBROUTINE elmhes(a,n,np) + INTEGER n,np + REAL a(np,np) + INTEGER i,j,m + REAL x,y + do 17 m=2,n-1 + x=0. + i=m + do 11 j=m,n + if(abs(a(j,m-1)).gt.abs(x))then + x=a(j,m-1) + i=j + endif +11 continue + if(i.ne.m)then + do 12 j=m-1,n + y=a(i,j) + a(i,j)=a(m,j) + a(m,j)=y +12 continue + do 13 j=1,n + y=a(j,i) + a(j,i)=a(j,m) + a(j,m)=y +13 continue + endif + if(x.ne.0.)then + do 16 i=m+1,n + y=a(i,m-1) + if(y.ne.0.)then + y=y/x + a(i,m-1)=y + do 14 j=m,n + a(i,j)=a(i,j)-y*a(m,j) +14 continue + do 15 j=1,n + a(j,m)=a(j,m)+y*a(j,i) +15 continue + endif +16 continue + endif +17 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/erf.for b/dataassim/math/numrec/f77_sources/erf.for new file mode 100644 index 0000000..0c8dca7 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/erf.for @@ -0,0 +1,11 @@ + FUNCTION erf(x) + REAL erf,x +CU USES gammp + REAL gammp + if(x.lt.0.)then + erf=-gammp(.5,x**2) + else + erf=gammp(.5,x**2) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/erfc.for b/dataassim/math/numrec/f77_sources/erfc.for new file mode 100644 index 0000000..de729ae --- /dev/null +++ b/dataassim/math/numrec/f77_sources/erfc.for @@ -0,0 +1,11 @@ + FUNCTION erfc(x) + REAL erfc,x +CU USES gammp,gammq + REAL gammp,gammq + if(x.lt.0.)then + erfc=1.+gammp(.5,x**2) + else + erfc=gammq(.5,x**2) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/erfcc.for b/dataassim/math/numrec/f77_sources/erfcc.for new file mode 100644 index 0000000..c37a991 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/erfcc.for @@ -0,0 +1,11 @@ + FUNCTION erfcc(x) + REAL erfcc,x + REAL t,z + z=abs(x) + t=1./(1.+0.5*z) + erfcc=t*exp(-z*z-1.26551223+t*(1.00002368+t*(.37409196+t* + *(.09678418+t*(-.18628806+t*(.27886807+t*(-1.13520398+t* + *(1.48851587+t*(-.82215223+t*.17087277))))))))) + if (x.lt.0.) erfcc=2.-erfcc + return + END diff --git a/dataassim/math/numrec/f77_sources/eulsum.for b/dataassim/math/numrec/f77_sources/eulsum.for new file mode 100644 index 0000000..07e3e07 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/eulsum.for @@ -0,0 +1,28 @@ + SUBROUTINE eulsum(sum,term,jterm,wksp) + INTEGER jterm + REAL sum,term,wksp(jterm) + INTEGER j,nterm + REAL dum,tmp + SAVE nterm + if(jterm.eq.1)then + nterm=1 + wksp(1)=term + sum=0.5*term + else + tmp=wksp(1) + wksp(1)=term + do 11 j=1,nterm-1 + dum=wksp(j+1) + wksp(j+1)=0.5*(wksp(j)+tmp) + tmp=dum +11 continue + wksp(nterm+1)=0.5*(wksp(nterm)+tmp) + if(abs(wksp(nterm+1)).le.abs(wksp(nterm)))then + sum=sum+0.5*wksp(nterm+1) + nterm=nterm+1 + else + sum=sum+wksp(nterm+1) + endif + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/evlmem.for b/dataassim/math/numrec/f77_sources/evlmem.for new file mode 100644 index 0000000..3d796d1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/evlmem.for @@ -0,0 +1,23 @@ + FUNCTION evlmem(fdt,d,m,xms) + INTEGER m + REAL evlmem,fdt,xms,d(m) + INTEGER i + REAL sumi,sumr + DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp + theta=6.28318530717959d0*fdt + wpr=cos(theta) + wpi=sin(theta) + wr=1.d0 + wi=0.d0 + sumr=1. + sumi=0. + do 11 i=1,m + wtemp=wr + wr=wr*wpr-wi*wpi + wi=wi*wpr+wtemp*wpi + sumr=sumr-d(i)*sngl(wr) + sumi=sumi-d(i)*sngl(wi) +11 continue + evlmem=xms/(sumr**2+sumi**2) + return + END diff --git a/dataassim/math/numrec/f77_sources/expdev.for b/dataassim/math/numrec/f77_sources/expdev.for new file mode 100644 index 0000000..759e468 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/expdev.for @@ -0,0 +1,10 @@ + FUNCTION expdev(idum) + INTEGER idum + REAL expdev +CU USES ran1 + REAL dum,ran1 +1 dum=ran1(idum) + if(dum.eq.0.)goto 1 + expdev=-log(dum) + return + END diff --git a/dataassim/math/numrec/f77_sources/expint.for b/dataassim/math/numrec/f77_sources/expint.for new file mode 100644 index 0000000..c55002b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/expint.for @@ -0,0 +1,56 @@ + FUNCTION expint(n,x) + INTEGER n,MAXIT + REAL expint,x,EPS,FPMIN,EULER + PARAMETER (MAXIT=100,EPS=1.e-7,FPMIN=1.e-30,EULER=.5772156649) + INTEGER i,ii,nm1 + REAL a,b,c,d,del,fact,h,psi + nm1=n-1 + if(n.lt.0.or.x.lt.0..or.(x.eq.0..and.(n.eq.0.or.n.eq.1)))then + pause 'bad arguments in expint' + else if(n.eq.0)then + expint=exp(-x)/x + else if(x.eq.0.)then + expint=1./nm1 + else if(x.gt.1.)then + b=x+n + c=1./FPMIN + d=1./b + h=d + do 11 i=1,MAXIT + a=-i*(nm1+i) + b=b+2. + d=1./(a*d+b) + c=b+a/c + del=c*d + h=h*del + if(abs(del-1.).lt.EPS)then + expint=h*exp(-x) + return + endif +11 continue + pause 'continued fraction failed in expint' + else + if(nm1.ne.0)then + expint=1./nm1 + else + expint=-log(x)-EULER + endif + fact=1. + do 13 i=1,MAXIT + fact=-fact*x/i + if(i.ne.nm1)then + del=-fact/(i-nm1) + else + psi=-EULER + do 12 ii=1,nm1 + psi=psi+1./ii +12 continue + del=fact*(-log(x)+psi) + endif + expint=expint+del + if(abs(del).lt.abs(expint)*EPS) return +13 continue + pause 'series failed in expint' + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/f1dim.for b/dataassim/math/numrec/f77_sources/f1dim.for new file mode 100644 index 0000000..a13be5e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/f1dim.for @@ -0,0 +1,14 @@ + FUNCTION f1dim(x) + INTEGER NMAX + REAL f1dim,func,x + PARAMETER (NMAX=50) +CU USES func + INTEGER j,ncom + REAL pcom(NMAX),xicom(NMAX),xt(NMAX) + COMMON /f1com/ pcom,xicom,ncom + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + f1dim=func(xt) + return + END diff --git a/dataassim/math/numrec/f77_sources/factln.for b/dataassim/math/numrec/f77_sources/factln.for new file mode 100644 index 0000000..7bc0b16 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/factln.for @@ -0,0 +1,16 @@ + FUNCTION factln(n) + INTEGER n + REAL factln +CU USES gammln + REAL a(100),gammln + SAVE a + DATA a/100*-1./ + if (n.lt.0) pause 'negative factorial in factln' + if (n.le.99) then + if (a(n+1).lt.0.) a(n+1)=gammln(n+1.) + factln=a(n+1) + else + factln=gammln(n+1.) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/factrl.for b/dataassim/math/numrec/f77_sources/factrl.for new file mode 100644 index 0000000..0ac3026 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/factrl.for @@ -0,0 +1,23 @@ + FUNCTION factrl(n) + INTEGER n + REAL factrl +CU USES gammln + INTEGER j,ntop + REAL a(33),gammln + SAVE ntop,a + DATA ntop,a(1)/0,1./ + if (n.lt.0) then + pause 'negative factorial in factrl' + else if (n.le.ntop) then + factrl=a(n+1) + else if (n.le.32) then + do 11 j=ntop+1,n + a(j+1)=j*a(j) +11 continue + ntop=n + factrl=a(n+1) + else + factrl=exp(gammln(n+1.)) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/fasper.for b/dataassim/math/numrec/f77_sources/fasper.for new file mode 100644 index 0000000..5b2fe00 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fasper.for @@ -0,0 +1,66 @@ + SUBROUTINE fasper(x,y,n,ofac,hifac,wk1,wk2,nwk,nout,jmax,prob) + INTEGER jmax,n,nout,nwk,MACC + REAL hifac,ofac,prob,wk1(nwk),wk2(nwk),x(n),y(n) + PARAMETER (MACC=4) +CU USES avevar,realft,spread + INTEGER j,k,ndim,nfreq,nfreqt + REAL ave,ck,ckk,cterm,cwt,den,df,effm,expy,fac,fndim,hc2wt,hs2wt, + *hypo,pmax,sterm,swt,var,xdif,xmax,xmin + EXTERNAL spread + nout=0.5*ofac*hifac*n + nfreqt=ofac*hifac*n*MACC + nfreq=64 +1 if (nfreq.lt.nfreqt) then + nfreq=nfreq*2 + goto 1 + endif + ndim=2*nfreq + if(ndim.gt.nwk) pause 'workspaces too small in fasper' + call avevar(y,n,ave,var) + xmin=x(1) + xmax=xmin + do 11 j=2,n + if(x(j).lt.xmin)xmin=x(j) + if(x(j).gt.xmax)xmax=x(j) +11 continue + xdif=xmax-xmin + do 12 j=1,ndim + wk1(j)=0. + wk2(j)=0. +12 continue + fac=ndim/(xdif*ofac) + fndim=ndim + do 13 j=1,n + ck=1.+mod((x(j)-xmin)*fac,fndim) + ckk=1.+mod(2.*(ck-1.),fndim) + call spread(y(j)-ave,wk1,ndim,ck,MACC) + call spread(1.,wk2,ndim,ckk,MACC) +13 continue + call realft(wk1,ndim,1) + call realft(wk2,ndim,1) + df=1./(xdif*ofac) + k=3 + pmax=-1. + do 14 j=1,nout + hypo=sqrt(wk2(k)**2+wk2(k+1)**2) + hc2wt=0.5*wk2(k)/hypo + hs2wt=0.5*wk2(k+1)/hypo + cwt=sqrt(0.5+hc2wt) + swt=sign(sqrt(0.5-hc2wt),hs2wt) + den=0.5*n+hc2wt*wk2(k)+hs2wt*wk2(k+1) + cterm=(cwt*wk1(k)+swt*wk1(k+1))**2/den + sterm=(cwt*wk1(k+1)-swt*wk1(k))**2/(n-den) + wk1(j)=j*df + wk2(j)=(cterm+sterm)/(2.*var) + if (wk2(j).gt.pmax) then + pmax=wk2(j) + jmax=j + endif + k=k+2 +14 continue + expy=exp(-pmax) + effm=2.*nout/ofac + prob=effm*expy + if(prob.gt.0.01)prob=1.-(1.-expy)**effm + return + END diff --git a/dataassim/math/numrec/f77_sources/fdjac.for b/dataassim/math/numrec/f77_sources/fdjac.for new file mode 100644 index 0000000..d1bca8f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fdjac.for @@ -0,0 +1,21 @@ + SUBROUTINE fdjac(n,x,fvec,np,df) + INTEGER n,np,NMAX + REAL df(np,np),fvec(n),x(n),EPS + PARAMETER (NMAX=40,EPS=1.e-4) +CU USES funcv + INTEGER i,j + REAL h,temp,f(NMAX) + do 12 j=1,n + temp=x(j) + h=EPS*abs(temp) + if(h.eq.0.)h=EPS + x(j)=temp+h + h=x(j)-temp + call funcv(n,x,f) + x(j)=temp + do 11 i=1,n + df(i,j)=(f(i)-fvec(i))/h +11 continue +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/fgauss.for b/dataassim/math/numrec/f77_sources/fgauss.for new file mode 100644 index 0000000..a256bbf --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fgauss.for @@ -0,0 +1,17 @@ + SUBROUTINE fgauss(x,a,y,dyda,na) + INTEGER na + REAL x,y,a(na),dyda(na) + INTEGER i + REAL arg,ex,fac + y=0. + do 11 i=1,na-1,3 + arg=(x-a(i+1))/a(i+2) + ex=exp(-arg**2) + fac=a(i)*ex*2.*arg + y=y+a(i)*ex + dyda(i)=ex + dyda(i+1)=fac/a(i+2) + dyda(i+2)=fac*arg/a(i+2) +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/fill0.for b/dataassim/math/numrec/f77_sources/fill0.for new file mode 100644 index 0000000..244489a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fill0.for @@ -0,0 +1,11 @@ + SUBROUTINE fill0(u,n) + INTEGER n + DOUBLE PRECISION u(n,n) + INTEGER i,j + do 12 j=1,n + do 11 i=1,n + u(i,j)=0.d0 +11 continue +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/fit.for b/dataassim/math/numrec/f77_sources/fit.for new file mode 100644 index 0000000..002819b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fit.for @@ -0,0 +1,60 @@ + SUBROUTINE fit(x,y,ndata,sig,mwt,a,b,siga,sigb,chi2,q) + INTEGER mwt,ndata + REAL a,b,chi2,q,siga,sigb,sig(ndata),x(ndata),y(ndata) +CU USES gammq + INTEGER i + REAL sigdat,ss,st2,sx,sxoss,sy,t,wt,gammq + sx=0. + sy=0. + st2=0. + b=0. + if(mwt.ne.0) then + ss=0. + do 11 i=1,ndata + wt=1./(sig(i)**2) + ss=ss+wt + sx=sx+x(i)*wt + sy=sy+y(i)*wt +11 continue + else + do 12 i=1,ndata + sx=sx+x(i) + sy=sy+y(i) +12 continue + ss=float(ndata) + endif + sxoss=sx/ss + if(mwt.ne.0) then + do 13 i=1,ndata + t=(x(i)-sxoss)/sig(i) + st2=st2+t*t + b=b+t*y(i)/sig(i) +13 continue + else + do 14 i=1,ndata + t=x(i)-sxoss + st2=st2+t*t + b=b+t*y(i) +14 continue + endif + b=b/st2 + a=(sy-sx*b)/ss + siga=sqrt((1.+sx*sx/(ss*st2))/ss) + sigb=sqrt(1./st2) + chi2=0. + if(mwt.eq.0) then + do 15 i=1,ndata + chi2=chi2+(y(i)-a-b*x(i))**2 +15 continue + q=1. + sigdat=sqrt(chi2/(ndata-2)) + siga=siga*sigdat + sigb=sigb*sigdat + else + do 16 i=1,ndata + chi2=chi2+((y(i)-a-b*x(i))/sig(i))**2 +16 continue + q=gammq(0.5*(ndata-2),0.5*chi2) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/fitexy.for b/dataassim/math/numrec/f77_sources/fitexy.for new file mode 100644 index 0000000..c4014fc --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fitexy.for @@ -0,0 +1,76 @@ + SUBROUTINE fitexy(x,y,ndat,sigx,sigy,a,b,siga,sigb,chi2,q) + INTEGER ndat,NMAX + REAL x(ndat),y(ndat),sigx(ndat),sigy(ndat),a,b,siga,sigb,chi2,q, + *POTN,PI,BIG,ACC + PARAMETER (NMAX=1000,POTN=1.571000,BIG=1.e30,PI=3.14159265, + *ACC=1.e-3) +CU USES avevar,brent,chixy,fit,gammq,mnbrak,zbrent + INTEGER j,nn + REAL xx(NMAX),yy(NMAX),sx(NMAX),sy(NMAX),ww(NMAX),swap,amx,amn, + *varx,vary,aa,offs,ang(6),ch(6),scale,bmn,bmx,d1,d2,r2,dum1,dum2, + *dum3,dum4,dum5,brent,chixy,gammq,zbrent + COMMON /fitxyc/ xx,yy,sx,sy,ww,aa,offs,nn + EXTERNAL chixy + if (ndat.gt.NMAX) pause 'NMAX too small in fitexy' + call avevar(x,ndat,dum1,varx) + call avevar(y,ndat,dum1,vary) + scale=sqrt(varx/vary) + nn=ndat + do 11 j=1,ndat + xx(j)=x(j) + yy(j)=y(j)*scale + sx(j)=sigx(j) + sy(j)=sigy(j)*scale + ww(j)=sqrt(sx(j)**2+sy(j)**2) +11 continue + call fit(xx,yy,nn,ww,1,dum1,b,dum2,dum3,dum4,dum5) + offs=0. + ang(1)=0. + ang(2)=atan(b) + ang(4)=0. + ang(5)=ang(2) + ang(6)=POTN + do 12 j=4,6 + ch(j)=chixy(ang(j)) +12 continue + call mnbrak(ang(1),ang(2),ang(3),ch(1),ch(2),ch(3),chixy) + chi2=brent(ang(1),ang(2),ang(3),chixy,ACC,b) + chi2=chixy(b) + a=aa + q=gammq(0.5*(nn-2),0.5*chi2) + r2=0. + do 13 j=1,nn + r2=r2+ww(j) +13 continue + r2=1./r2 + bmx=BIG + bmn=BIG + offs=chi2+1. + do 14 j=1,6 + if (ch(j).gt.offs) then + d1=mod(abs(ang(j)-b),PI) + d2=PI-d1 + if(ang(j).lt.b)then + swap=d1 + d1=d2 + d2=swap + endif + if (d1.lt.bmx) bmx=d1 + if (d2.lt.bmn) bmn=d2 + endif +14 continue + if (bmx.lt. BIG) then + bmx=zbrent(chixy,b,b+bmx,ACC)-b + amx=aa-a + bmn=zbrent(chixy,b,b-bmn,ACC)-b + amn=aa-a + sigb=sqrt(0.5*(bmx**2+bmn**2))/(scale*cos(b)**2) + siga=sqrt(0.5*(amx**2+amn**2)+r2)/scale + else + sigb=BIG + siga=BIG + endif + a=a/scale + b=tan(b)/scale + return + END diff --git a/dataassim/math/numrec/f77_sources/fixrts.for b/dataassim/math/numrec/f77_sources/fixrts.for new file mode 100644 index 0000000..688477d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fixrts.for @@ -0,0 +1,33 @@ + SUBROUTINE fixrts(d,m) + INTEGER m,MMAX + REAL d(m) + PARAMETER (MMAX=100) +CU USES zroots + INTEGER i,j + LOGICAL polish + COMPLEX a(MMAX),roots(MMAX) + a(m+1)=cmplx(1.,0.) + do 11 j=m,1,-1 + a(j)=cmplx(-d(m+1-j),0.) +11 continue + polish=.true. + call zroots(a,m,roots,polish) + do 12 j=1,m + if(abs(roots(j)).gt.1.)then + roots(j)=1./conjg(roots(j)) + endif +12 continue + a(1)=-roots(1) + a(2)=cmplx(1.,0.) + do 14 j=2,m + a(j+1)=cmplx(1.,0.) + do 13 i=j,2,-1 + a(i)=a(i-1)-roots(j)*a(i) +13 continue + a(1)=-roots(j)*a(1) +14 continue + do 15 j=1,m + d(m+1-j)=-real(a(j)) +15 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/fleg.for b/dataassim/math/numrec/f77_sources/fleg.for new file mode 100644 index 0000000..3f53b66 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fleg.for @@ -0,0 +1,20 @@ + SUBROUTINE fleg(x,pl,nl) + INTEGER nl + REAL x,pl(nl) + INTEGER j + REAL d,f1,f2,twox + pl(1)=1. + pl(2)=x + if(nl.gt.2) then + twox=2.*x + f2=x + d=1. + do 11 j=3,nl + f1=d + f2=f2+twox + d=d+1. + pl(j)=(f2*pl(j-1)-f1*pl(j-2))/d +11 continue + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/flmoon.for b/dataassim/math/numrec/f77_sources/flmoon.for new file mode 100644 index 0000000..e34dea2 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/flmoon.for @@ -0,0 +1,29 @@ + SUBROUTINE flmoon(n,nph,jd,frac) + INTEGER jd,n,nph + REAL frac,RAD + PARAMETER (RAD=3.14159265/180.) + INTEGER i + REAL am,as,c,t,t2,xtra + c=n+nph/4. + t=c/1236.85 + t2=t**2 + as=359.2242+29.105356*c + am=306.0253+385.816918*c+0.010730*t2 + jd=2415020+28*n+7*nph + xtra=0.75933+1.53058868*c+(1.178e-4-1.55e-7*t)*t2 + if(nph.eq.0.or.nph.eq.2)then + xtra=xtra+(0.1734-3.93e-4*t)*sin(RAD*as)-0.4068*sin(RAD*am) + else if(nph.eq.1.or.nph.eq.3)then + xtra=xtra+(0.1721-4.e-4*t)*sin(RAD*as)-0.6280*sin(RAD*am) + else + pause 'nph is unknown in flmoon' + endif + if(xtra.ge.0.)then + i=int(xtra) + else + i=int(xtra-1.) + endif + jd=jd+i + frac=xtra-i + return + END diff --git a/dataassim/math/numrec/f77_sources/fmin.for b/dataassim/math/numrec/f77_sources/fmin.for new file mode 100644 index 0000000..01228ee --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fmin.for @@ -0,0 +1,17 @@ + FUNCTION fmin(x) + INTEGER n,NP + REAL fmin,x(*),fvec + PARAMETER (NP=40) + COMMON /newtv/ fvec(NP),n + SAVE /newtv/ +CU USES funcv + INTEGER i + REAL sum + call funcv(n,x,fvec) + sum=0. + do 11 i=1,n + sum=sum+fvec(i)**2 +11 continue + fmin=0.5*sum + return + END diff --git a/dataassim/math/numrec/f77_sources/four1.for b/dataassim/math/numrec/f77_sources/four1.for new file mode 100644 index 0000000..8d6018d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/four1.for @@ -0,0 +1,52 @@ + SUBROUTINE four1(data,nn,isign) + INTEGER isign,nn + REAL data(2*nn) + INTEGER i,istep,j,m,mmax,n + REAL tempi,tempr + DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp + n=2*nn + j=1 + do 11 i=1,n,2 + if(j.gt.i)then + tempr=data(j) + tempi=data(j+1) + data(j)=data(i) + data(j+1)=data(i+1) + data(i)=tempr + data(i+1)=tempi + endif + m=n/2 +1 if ((m.ge.2).and.(j.gt.m)) then + j=j-m + m=m/2 + goto 1 + endif + j=j+m +11 continue + mmax=2 +2 if (n.gt.mmax) then + istep=2*mmax + theta=6.28318530717959d0/(isign*mmax) + wpr=-2.d0*sin(0.5d0*theta)**2 + wpi=sin(theta) + wr=1.d0 + wi=0.d0 + do 13 m=1,mmax,2 + do 12 i=m,n,istep + j=i+mmax + tempr=sngl(wr)*data(j)-sngl(wi)*data(j+1) + tempi=sngl(wr)*data(j+1)+sngl(wi)*data(j) + data(j)=data(i)-tempr + data(j+1)=data(i+1)-tempi + data(i)=data(i)+tempr + data(i+1)=data(i+1)+tempi +12 continue + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi +13 continue + mmax=istep + goto 2 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/fourew.for b/dataassim/math/numrec/f77_sources/fourew.for new file mode 100644 index 0000000..d460d4c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fourew.for @@ -0,0 +1,17 @@ + SUBROUTINE fourew(iunit,na,nb,nc,nd) + INTEGER na,nb,nc,nd,iunit(4),ii + do 11 ii=1,4 + rewind(unit=iunit(ii)) +11 continue + ii=iunit(2) + iunit(2)=iunit(4) + iunit(4)=ii + ii=iunit(1) + iunit(1)=iunit(3) + iunit(3)=ii + na=3 + nb=4 + nc=1 + nd=2 + return + END diff --git a/dataassim/math/numrec/f77_sources/fourfs.for b/dataassim/math/numrec/f77_sources/fourfs.for new file mode 100644 index 0000000..3c4afdf --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fourfs.for @@ -0,0 +1,145 @@ + SUBROUTINE fourfs(iunit,nn,ndim,isign) + INTEGER ndim,nn(ndim),isign,iunit(4),KBF + PARAMETER (KBF=128) +CU USES fourew + INTEGER j,j12,jk,k,kk,n,mm,kc,kd,ks,kr,nr,ns,nv,jx,mate(4),na,nb, + *nc,nd + REAL tempr,tempi,afa(KBF),afb(KBF),afc(KBF) + DOUBLE PRECISION wr,wi,wpr,wpi,wtemp,theta + SAVE mate + DATA mate /2,1,4,3/ + n=1 + do 11 j=1,ndim + n=n*nn(j) + if (nn(j).le.1)pause 'invalid dimension or wrong ndim in fourfs' +11 continue + nv=ndim + jk=nn(nv) + mm=n + ns=n/KBF + nr=ns/2 + kc=0 + kd=KBF/2 + ks=n + call fourew(iunit,na,nb,nc,nd) +1 continue + theta=3.141592653589793d0/(isign*n/mm) + wpr=-2.d0*sin(0.5d0*theta)**2 + wpi=sin(theta) + wr=1.d0 + wi=0.d0 + mm=mm/2 + do 13 j12=1,2 + kr=0 +2 continue + read (iunit(na)) (afa(jx),jx=1,KBF) + read (iunit(nb)) (afb(jx),jx=1,KBF) + do 12 j=1,KBF,2 + tempr=sngl(wr)*afb(j)-sngl(wi)*afb(j+1) + tempi=sngl(wi)*afb(j)+sngl(wr)*afb(j+1) + afb(j)=afa(j)-tempr + afa(j)=afa(j)+tempr + afb(j+1)=afa(j+1)-tempi + afa(j+1)=afa(j+1)+tempi +12 continue + kc=kc+kd + if (kc.eq.mm) then + kc=0 + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi + endif + write (iunit(nc)) (afa(jx),jx=1,KBF) + write (iunit(nd)) (afb(jx),jx=1,KBF) + kr=kr+1 + if (kr.lt.nr) goto 2 + if(j12.eq.1.and.ks.ne.n.and.ks.eq.KBF) then + na=mate(na) + nb=na + endif + if (nr.eq.0) goto 3 +13 continue +3 call fourew(iunit,na,nb,nc,nd) + jk=jk/2 +4 if (jk.eq.1) then + mm=n + nv=nv-1 + jk=nn(nv) + goto 4 + endif + ks=ks/2 + if (ks.gt.KBF) then + do 16 j12=1,2 + do 15 kr=1,ns,ks/KBF + do 14 k=1,ks,KBF + read (iunit(na)) (afa(jx),jx=1,KBF) + write (iunit(nc)) (afa(jx),jx=1,KBF) +14 continue + nc=mate(nc) +15 continue + na=mate(na) +16 continue + call fourew(iunit,na,nb,nc,nd) + goto 1 + else if (ks.eq.KBF) then + nb=na + goto 1 + endif + continue + j=1 +5 continue + theta=3.141592653589793d0/(isign*n/mm) + wpr=-2.d0*sin(0.5d0*theta)**2 + wpi=sin(theta) + wr=1.d0 + wi=0.d0 + mm=mm/2 + ks=kd + kd=kd/2 + do 18 j12=1,2 + do 17 kr=1,ns + read (iunit(na)) (afc(jx),jx=1,KBF) + kk=1 + k=ks+1 +6 continue + tempr=sngl(wr)*afc(kk+ks)-sngl(wi)*afc(kk+ks+1) + tempi=sngl(wi)*afc(kk+ks)+sngl(wr)*afc(kk+ks+1) + afa(j)=afc(kk)+tempr + afb(j)=afc(kk)-tempr + afa(j+1)=afc(kk+1)+tempi + afb(j+1)=afc(kk+1)-tempi + j=j+2 + kk=kk+2 + if (kk.lt.k) goto 6 + kc=kc+kd + if (kc.eq.mm) then + kc=0 + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi + endif + kk=kk+ks + if (kk.le.KBF) then + k=kk+ks + goto 6 + endif + if (j.gt.KBF) then + write (iunit(nc)) (afa(jx),jx=1,KBF) + write (iunit(nd)) (afb(jx),jx=1,KBF) + j=1 + endif +17 continue + na=mate(na) +18 continue + call fourew(iunit,na,nb,nc,nd) + jk=jk/2 + if (jk.gt.1) goto 5 + mm=n +7 if (nv.gt.1) then + nv=nv-1 + jk=nn(nv) + if (jk.eq.1) goto 7 + goto 5 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/fourn.for b/dataassim/math/numrec/f77_sources/fourn.for new file mode 100644 index 0000000..b14aa78 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fourn.for @@ -0,0 +1,73 @@ + SUBROUTINE fourn(data,nn,ndim,isign) + INTEGER isign,ndim,nn(ndim) + REAL data(*) + INTEGER i1,i2,i2rev,i3,i3rev,ibit,idim,ifp1,ifp2,ip1,ip2,ip3,k1, + *k2,n,nprev,nrem,ntot + REAL tempi,tempr + DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp + ntot=1 + do 11 idim=1,ndim + ntot=ntot*nn(idim) +11 continue + nprev=1 + do 18 idim=1,ndim + n=nn(idim) + nrem=ntot/(n*nprev) + ip1=2*nprev + ip2=ip1*n + ip3=ip2*nrem + i2rev=1 + do 14 i2=1,ip2,ip1 + if(i2.lt.i2rev)then + do 13 i1=i2,i2+ip1-2,2 + do 12 i3=i1,ip3,ip2 + i3rev=i2rev+i3-i2 + tempr=data(i3) + tempi=data(i3+1) + data(i3)=data(i3rev) + data(i3+1)=data(i3rev+1) + data(i3rev)=tempr + data(i3rev+1)=tempi +12 continue +13 continue + endif + ibit=ip2/2 +1 if ((ibit.ge.ip1).and.(i2rev.gt.ibit)) then + i2rev=i2rev-ibit + ibit=ibit/2 + goto 1 + endif + i2rev=i2rev+ibit +14 continue + ifp1=ip1 +2 if(ifp1.lt.ip2)then + ifp2=2*ifp1 + theta=isign*6.28318530717959d0/(ifp2/ip1) + wpr=-2.d0*sin(0.5d0*theta)**2 + wpi=sin(theta) + wr=1.d0 + wi=0.d0 + do 17 i3=1,ifp1,ip1 + do 16 i1=i3,i3+ip1-2,2 + do 15 i2=i1,ip3,ifp2 + k1=i2 + k2=k1+ifp1 + tempr=sngl(wr)*data(k2)-sngl(wi)*data(k2+1) + tempi=sngl(wr)*data(k2+1)+sngl(wi)*data(k2) + data(k2)=data(k1)-tempr + data(k2+1)=data(k1+1)-tempi + data(k1)=data(k1)+tempr + data(k1+1)=data(k1+1)+tempi +15 continue +16 continue + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi +17 continue + ifp1=ifp2 + goto 2 + endif + nprev=n*nprev +18 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/fpoly.for b/dataassim/math/numrec/f77_sources/fpoly.for new file mode 100644 index 0000000..c39bfe9 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fpoly.for @@ -0,0 +1,10 @@ + SUBROUTINE fpoly(x,p,np) + INTEGER np + REAL x,p(np) + INTEGER j + p(1)=1. + do 11 j=2,np + p(j)=p(j-1)*x +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/fred2.for b/dataassim/math/numrec/f77_sources/fred2.for new file mode 100644 index 0000000..72d076f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fred2.for @@ -0,0 +1,25 @@ + SUBROUTINE fred2(n,a,b,t,f,w,g,ak) + INTEGER n,NMAX + REAL a,b,f(n),t(n),w(n),g,ak + EXTERNAL ak,g + PARAMETER (NMAX=200) +CU USES ak,g,gauleg,lubksb,ludcmp + INTEGER i,j,indx(NMAX) + REAL d,omk(NMAX,NMAX) + if(n.gt.NMAX) pause 'increase NMAX in fred2' + call gauleg(a,b,t,w,n) + do 12 i=1,n + do 11 j=1,n + if(i.eq.j)then + omk(i,j)=1. + else + omk(i,j)=0. + endif + omk(i,j)=omk(i,j)-ak(t(i),t(j))*w(j) +11 continue + f(i)=g(t(i)) +12 continue + call ludcmp(omk,n,NMAX,indx,d) + call lubksb(omk,n,NMAX,indx,f) + return + END diff --git a/dataassim/math/numrec/f77_sources/fredex.for b/dataassim/math/numrec/f77_sources/fredex.for new file mode 100644 index 0000000..d147ebd --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fredex.for @@ -0,0 +1,21 @@ + PROGRAM fredex + INTEGER NMAX + REAL PI + PARAMETER (NMAX=100,PI=3.14159265) + INTEGER indx(NMAX),j,n + REAL a(NMAX,NMAX),g(NMAX),x,d +CU USES quadmx,ludcmp,lubksb + n=40 + call quadmx(a,n,NMAX) + call ludcmp(a,n,NMAX,indx,d) + do 11 j=1,n + x=(j-1)*PI/(n-1) + g(j)=sin(x) +11 continue + call lubksb(a,n,NMAX,indx,g) + do 12 j=1,n + x=(j-1)*PI/(n-1) + write (*,*) j,x,g(j) +12 continue + write (*,*) 'normal completion' + END diff --git a/dataassim/math/numrec/f77_sources/fredin.for b/dataassim/math/numrec/f77_sources/fredin.for new file mode 100644 index 0000000..8e97682 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/fredin.for @@ -0,0 +1,14 @@ + FUNCTION fredin(x,n,a,b,t,f,w,g,ak) + INTEGER n + REAL fredin,a,b,x,f(n),t(n),w(n),g,ak + EXTERNAL ak,g +CU USES ak,g + INTEGER i + REAL sum + sum=0. + do 11 i=1,n + sum=sum+ak(x,t(i))*w(i)*f(i) +11 continue + fredin=g(x)+sum + return + END diff --git a/dataassim/math/numrec/f77_sources/frenel.for b/dataassim/math/numrec/f77_sources/frenel.for new file mode 100644 index 0000000..7909eed --- /dev/null +++ b/dataassim/math/numrec/f77_sources/frenel.for @@ -0,0 +1,71 @@ + SUBROUTINE frenel(x,s,c) + INTEGER MAXIT + REAL c,s,x,EPS,FPMIN,PI,PIBY2,XMIN + PARAMETER (EPS=6.e-8,MAXIT=100,FPMIN=1.e-30,XMIN=1.5,PI=3.1415927, + *PIBY2=1.5707963) + INTEGER k,n + REAL a,absc,ax,fact,pix2,sign,sum,sumc,sums,term,test + COMPLEX b,cc,d,h,del,cs + LOGICAL odd + absc(h)=abs(real(h))+abs(aimag(h)) + ax=abs(x) + if(ax.lt.sqrt(FPMIN))then + s=0. + c=ax + else if(ax.le.XMIN)then + sum=0. + sums=0. + sumc=ax + sign=1. + fact=PIBY2*ax*ax + odd=.true. + term=ax + n=3 + do 11 k=1,MAXIT + term=term*fact/k + sum=sum+sign*term/n + test=abs(sum)*EPS + if(odd)then + sign=-sign + sums=sum + sum=sumc + else + sumc=sum + sum=sums + endif + if(term.lt.test)goto 1 + odd=.not.odd + n=n+2 +11 continue + pause 'series failed in frenel' +1 s=sums + c=sumc + else + pix2=PI*ax*ax + b=cmplx(1.,-pix2) + cc=1./FPMIN + d=1./b + h=d + n=-1 + do 12 k=2,MAXIT + n=n+2 + a=-n*(n+1) + b=b+4. + d=1./(a*d+b) + cc=b+a/cc + del=cc*d + h=h*del + if(absc(del-1.).lt.EPS)goto 2 +12 continue + pause 'cf failed in frenel' +2 h=h*cmplx(ax,-ax) + cs=cmplx(.5,.5)*(1.-cmplx(cos(.5*pix2),sin(.5*pix2))*h) + c=real(cs) + s=aimag(cs) + endif + if(x.lt.0.)then + c=-c + s=-s + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/frprmn.for b/dataassim/math/numrec/f77_sources/frprmn.for new file mode 100644 index 0000000..c5ab762 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/frprmn.for @@ -0,0 +1,39 @@ + SUBROUTINE frprmn(p,n,ftol,iter,fret) + INTEGER iter,n,NMAX,ITMAX + REAL fret,ftol,p(n),EPS,func + EXTERNAL func + PARAMETER (NMAX=50,ITMAX=200,EPS=1.e-10) +CU USES dfunc,func,linmin + INTEGER its,j + REAL dgg,fp,gam,gg,g(NMAX),h(NMAX),xi(NMAX) + fp=func(p) + call dfunc(p,xi) + do 11 j=1,n + g(j)=-xi(j) + h(j)=g(j) + xi(j)=h(j) +11 continue + do 14 its=1,ITMAX + iter=its + call linmin(p,xi,n,fret) + if(2.*abs(fret-fp).le.ftol*(abs(fret)+abs(fp)+EPS))return + fp=func(p) + call dfunc(p,xi) + gg=0. + dgg=0. + do 12 j=1,n + gg=gg+g(j)**2 +C dgg=dgg+xi(j)**2 + dgg=dgg+(xi(j)+g(j))*xi(j) +12 continue + if(gg.eq.0.)return + gam=dgg/gg + do 13 j=1,n + g(j)=-xi(j) + h(j)=g(j)+gam*h(j) + xi(j)=h(j) +13 continue +14 continue + pause 'frprmn maximum iterations exceeded' + return + END diff --git a/dataassim/math/numrec/f77_sources/ftest.for b/dataassim/math/numrec/f77_sources/ftest.for new file mode 100644 index 0000000..5825c12 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ftest.for @@ -0,0 +1,20 @@ + SUBROUTINE ftest(data1,n1,data2,n2,f,prob) + INTEGER n1,n2 + REAL f,prob,data1(n1),data2(n2) +CU USES avevar,betai + REAL ave1,ave2,df1,df2,var1,var2,betai + call avevar(data1,n1,ave1,var1) + call avevar(data2,n2,ave2,var2) + if(var1.gt.var2)then + f=var1/var2 + df1=n1-1 + df2=n2-1 + else + f=var2/var1 + df1=n2-1 + df2=n1-1 + endif + prob=2.*betai(0.5*df2,0.5*df1,df2/(df2+df1*f)) + if(prob.gt.1.)prob=2.-prob + return + END diff --git a/dataassim/math/numrec/f77_sources/gamdev.for b/dataassim/math/numrec/f77_sources/gamdev.for new file mode 100644 index 0000000..0d7170d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gamdev.for @@ -0,0 +1,28 @@ + FUNCTION gamdev(ia,idum) + INTEGER ia,idum + REAL gamdev +CU USES ran1 + INTEGER j + REAL am,e,s,v1,v2,x,y,ran1 + if(ia.lt.1)pause 'bad argument in gamdev' + if(ia.lt.6)then + x=1. + do 11 j=1,ia + x=x*ran1(idum) +11 continue + x=-log(x) + else +1 v1=ran1(idum) + v2=2.*ran1(idum)-1. + if(v1**2+v2**2.gt.1.)goto 1 + y=v2/v1 + am=ia-1 + s=sqrt(2.*am+1.) + x=s*y+am + if(x.le.0.)goto 1 + e=(1.+y**2)*exp(am*log(x/am)-s*y) + if(ran1(idum).gt.e)goto 1 + endif + gamdev=x + return + END diff --git a/dataassim/math/numrec/f77_sources/gammln.for b/dataassim/math/numrec/f77_sources/gammln.for new file mode 100644 index 0000000..52f4ab1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gammln.for @@ -0,0 +1,20 @@ + FUNCTION gammln(xx) + REAL gammln,xx + INTEGER j + DOUBLE PRECISION ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d0,-86.50532032941677d0, + *24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2, + *-.5395239384953d-5,2.5066282746310005d0/ + x=xx + y=x + tmp=x+5.5d0 + tmp=(x+0.5d0)*log(tmp)-tmp + ser=1.000000000190015d0 + do 11 j=1,6 + y=y+1.d0 + ser=ser+cof(j)/y +11 continue + gammln=tmp+log(stp*ser/x) + return + END diff --git a/dataassim/math/numrec/f77_sources/gammp.for b/dataassim/math/numrec/f77_sources/gammp.for new file mode 100644 index 0000000..bba9ea6 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gammp.for @@ -0,0 +1,14 @@ + FUNCTION gammp(a,x) + REAL a,gammp,x +CU USES gcf,gser + REAL gammcf,gamser,gln + if(x.lt.0..or.a.le.0.)pause 'bad arguments in gammp' + if(x.lt.a+1.)then + call gser(gamser,a,x,gln) + gammp=gamser + else + call gcf(gammcf,a,x,gln) + gammp=1.-gammcf + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/gammq.for b/dataassim/math/numrec/f77_sources/gammq.for new file mode 100644 index 0000000..04dfd20 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gammq.for @@ -0,0 +1,14 @@ + FUNCTION gammq(a,x) + REAL a,gammq,x +CU USES gcf,gser + REAL gammcf,gamser,gln + if(x.lt.0..or.a.le.0.)pause 'bad arguments in gammq' + if(x.lt.a+1.)then + call gser(gamser,a,x,gln) + gammq=1.-gamser + else + call gcf(gammcf,a,x,gln) + gammq=gammcf + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/gasdev.for b/dataassim/math/numrec/f77_sources/gasdev.for new file mode 100644 index 0000000..6e9533f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gasdev.for @@ -0,0 +1,23 @@ + FUNCTION gasdev(idum) + INTEGER idum + REAL gasdev +CU USES ran1 + INTEGER iset + REAL fac,gset,rsq,v1,v2,ran1 + SAVE iset,gset + DATA iset/0/ + if (iset.eq.0) then +1 v1=2.*ran1(idum)-1. + v2=2.*ran1(idum)-1. + rsq=v1**2+v2**2 + if(rsq.ge.1..or.rsq.eq.0.)goto 1 + fac=sqrt(-2.*log(rsq)/rsq) + gset=v1*fac + gasdev=v2*fac + iset=1 + else + gasdev=gset + iset=0 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/gaucof.for b/dataassim/math/numrec/f77_sources/gaucof.for new file mode 100644 index 0000000..fc19b7b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gaucof.for @@ -0,0 +1,25 @@ + SUBROUTINE gaucof(n,a,b,amu0,x,w) + INTEGER n,NMAX + REAL amu0,a(n),b(n),w(n),x(n) + PARAMETER (NMAX=64) +CU USES eigsrt,tqli + INTEGER i,j + REAL z(NMAX,NMAX) + do 12 i=1,n + if(i.ne.1)b(i)=sqrt(b(i)) + do 11 j=1,n + if(i.eq.j)then + z(i,j)=1. + else + z(i,j)=0. + endif +11 continue +12 continue + call tqli(a,b,n,NMAX,z) + call eigsrt(a,z,n,NMAX) + do 13 i=1,n + x(i)=a(i) + w(i)=amu0*z(1,i)**2 +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/gauher.for b/dataassim/math/numrec/f77_sources/gauher.for new file mode 100644 index 0000000..799459a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gauher.for @@ -0,0 +1,41 @@ + SUBROUTINE gauher(x,w,n) + INTEGER n,MAXIT + REAL w(n),x(n) + DOUBLE PRECISION EPS,PIM4 + PARAMETER (EPS=3.D-14,PIM4=.7511255444649425D0,MAXIT=10) + INTEGER i,its,j,m + DOUBLE PRECISION p1,p2,p3,pp,z,z1 + m=(n+1)/2 + do 13 i=1,m + if(i.eq.1)then + z=sqrt(float(2*n+1))-1.85575*(2*n+1)**(-.16667) + else if(i.eq.2)then + z=z-1.14*n**.426/z + else if (i.eq.3)then + z=1.86*z-.86*x(1) + else if (i.eq.4)then + z=1.91*z-.91*x(2) + else + z=2.*z-x(i-2) + endif + do 12 its=1,MAXIT + p1=PIM4 + p2=0.d0 + do 11 j=1,n + p3=p2 + p2=p1 + p1=z*sqrt(2.d0/j)*p2-sqrt(dble(j-1)/dble(j))*p3 +11 continue + pp=sqrt(2.d0*n)*p2 + z1=z + z=z1-p1/pp + if(abs(z-z1).le.EPS)goto 1 +12 continue + pause 'too many iterations in gauher' +1 x(i)=z + x(n+1-i)=-z + w(i)=2.d0/(pp*pp) + w(n+1-i)=w(i) +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/gaujac.for b/dataassim/math/numrec/f77_sources/gaujac.for new file mode 100644 index 0000000..c3842f6 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gaujac.for @@ -0,0 +1,66 @@ + SUBROUTINE gaujac(x,w,n,alf,bet) + INTEGER n,MAXIT + REAL alf,bet,w(n),x(n) + DOUBLE PRECISION EPS + PARAMETER (EPS=3.D-14,MAXIT=10) +CU USES gammln + INTEGER i,its,j + REAL alfbet,an,bn,r1,r2,r3,gammln + DOUBLE PRECISION a,b,c,p1,p2,p3,pp,temp,z,z1 + do 13 i=1,n + if(i.eq.1)then + an=alf/n + bn=bet/n + r1=(1.+alf)*(2.78/(4.+n*n)+.768*an/n) + r2=1.+1.48*an+.96*bn+.452*an*an+.83*an*bn + z=1.-r1/r2 + else if(i.eq.2)then + r1=(4.1+alf)/((1.+alf)*(1.+.156*alf)) + r2=1.+.06*(n-8.)*(1.+.12*alf)/n + r3=1.+.012*bet*(1.+.25*abs(alf))/n + z=z-(1.-z)*r1*r2*r3 + else if(i.eq.3)then + r1=(1.67+.28*alf)/(1.+.37*alf) + r2=1.+.22*(n-8.)/n + r3=1.+8.*bet/((6.28+bet)*n*n) + z=z-(x(1)-z)*r1*r2*r3 + else if(i.eq.n-1)then + r1=(1.+.235*bet)/(.766+.119*bet) + r2=1./(1.+.639*(n-4.)/(1.+.71*(n-4.))) + r3=1./(1.+20.*alf/((7.5+alf)*n*n)) + z=z+(z-x(n-3))*r1*r2*r3 + else if(i.eq.n)then + r1=(1.+.37*bet)/(1.67+.28*bet) + r2=1./(1.+.22*(n-8.)/n) + r3=1./(1.+8.*alf/((6.28+alf)*n*n)) + z=z+(z-x(n-2))*r1*r2*r3 + else + z=3.*x(i-1)-3.*x(i-2)+x(i-3) + endif + alfbet=alf+bet + do 12 its=1,MAXIT + temp=2.d0+alfbet + p1=(alf-bet+temp*z)/2.d0 + p2=1.d0 + do 11 j=2,n + p3=p2 + p2=p1 + temp=2*j+alfbet + a=2*j*(j+alfbet)*(temp-2.d0) + b=(temp-1.d0)*(alf*alf-bet*bet+temp*(temp-2.d0)*z) + c=2.d0*(j-1+alf)*(j-1+bet)*temp + p1=(b*p2-c*p3)/a +11 continue + pp=(n*(alf-bet-temp*z)*p1+2.d0*(n+alf)*(n+bet)*p2)/(temp* + *(1.d0-z*z)) + z1=z + z=z1-p1/pp + if(abs(z-z1).le.EPS)goto 1 +12 continue + pause 'too many iterations in gaujac' +1 x(i)=z + w(i)=exp(gammln(alf+n)+gammln(bet+n)-gammln(n+1.)-gammln(n+ + *alfbet+1.))*temp*2.**alfbet/(pp*p2) +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/gaulag.for b/dataassim/math/numrec/f77_sources/gaulag.for new file mode 100644 index 0000000..00d89e1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gaulag.for @@ -0,0 +1,38 @@ + SUBROUTINE gaulag(x,w,n,alf) + INTEGER n,MAXIT + REAL alf,w(n),x(n) + DOUBLE PRECISION EPS + PARAMETER (EPS=3.D-14,MAXIT=10) +CU USES gammln + INTEGER i,its,j + REAL ai,gammln + DOUBLE PRECISION p1,p2,p3,pp,z,z1 + do 13 i=1,n + if(i.eq.1)then + z=(1.+alf)*(3.+.92*alf)/(1.+2.4*n+1.8*alf) + else if(i.eq.2)then + z=z+(15.+6.25*alf)/(1.+.9*alf+2.5*n) + else + ai=i-2 + z=z+((1.+2.55*ai)/(1.9*ai)+1.26*ai*alf/(1.+3.5*ai))* + *(z-x(i-2))/(1.+.3*alf) + endif + do 12 its=1,MAXIT + p1=1.d0 + p2=0.d0 + do 11 j=1,n + p3=p2 + p2=p1 + p1=((2*j-1+alf-z)*p2-(j-1+alf)*p3)/j +11 continue + pp=(n*p1-(n+alf)*p2)/z + z1=z + z=z1-p1/pp + if(abs(z-z1).le.EPS)goto 1 +12 continue + pause 'too many iterations in gaulag' +1 x(i)=z + w(i)=-exp(gammln(alf+n)-gammln(float(n)))/(pp*n*p2) +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/gauleg.for b/dataassim/math/numrec/f77_sources/gauleg.for new file mode 100644 index 0000000..4c13448 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gauleg.for @@ -0,0 +1,31 @@ + SUBROUTINE gauleg(x1,x2,x,w,n) + INTEGER n + REAL x1,x2,x(n),w(n) + DOUBLE PRECISION EPS + PARAMETER (EPS=3.d-14) + INTEGER i,j,m + DOUBLE PRECISION p1,p2,p3,pp,xl,xm,z,z1 + m=(n+1)/2 + xm=0.5d0*(x2+x1) + xl=0.5d0*(x2-x1) + do 12 i=1,m + z=cos(3.141592654d0*(i-.25d0)/(n+.5d0)) +1 continue + p1=1.d0 + p2=0.d0 + do 11 j=1,n + p3=p2 + p2=p1 + p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j +11 continue + pp=n*(z*p1-p2)/(z*z-1.d0) + z1=z + z=z1-p1/pp + if(abs(z-z1).gt.EPS)goto 1 + x(i)=xm-xl*z + x(n+1-i)=xm+xl*z + w(i)=2.d0*xl/((1.d0-z*z)*pp*pp) + w(n+1-i)=w(i) +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/gaussj.for b/dataassim/math/numrec/f77_sources/gaussj.for new file mode 100644 index 0000000..9d6f120 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gaussj.for @@ -0,0 +1,74 @@ + SUBROUTINE gaussj(a,n,np,b,m,mp) + INTEGER m,mp,n,np,NMAX + REAL a(np,np),b(np,mp) + PARAMETER (NMAX=50) + INTEGER i,icol,irow,j,k,l,ll,indxc(NMAX),indxr(NMAX),ipiv(NMAX) + REAL big,dum,pivinv + do 11 j=1,n + ipiv(j)=0 +11 continue + do 22 i=1,n + big=0. + do 13 j=1,n + if(ipiv(j).ne.1)then + do 12 k=1,n + if (ipiv(k).eq.0) then + if (abs(a(j,k)).ge.big)then + big=abs(a(j,k)) + irow=j + icol=k + endif + else if (ipiv(k).gt.1) then + pause 'singular matrix in gaussj' + endif +12 continue + endif +13 continue + ipiv(icol)=ipiv(icol)+1 + if (irow.ne.icol) then + do 14 l=1,n + dum=a(irow,l) + a(irow,l)=a(icol,l) + a(icol,l)=dum +14 continue + do 15 l=1,m + dum=b(irow,l) + b(irow,l)=b(icol,l) + b(icol,l)=dum +15 continue + endif + indxr(i)=irow + indxc(i)=icol + if (a(icol,icol).eq.0.) pause 'singular matrix in gaussj' + pivinv=1./a(icol,icol) + a(icol,icol)=1. + do 16 l=1,n + a(icol,l)=a(icol,l)*pivinv +16 continue + do 17 l=1,m + b(icol,l)=b(icol,l)*pivinv +17 continue + do 21 ll=1,n + if(ll.ne.icol)then + dum=a(ll,icol) + a(ll,icol)=0. + do 18 l=1,n + a(ll,l)=a(ll,l)-a(icol,l)*dum +18 continue + do 19 l=1,m + b(ll,l)=b(ll,l)-b(icol,l)*dum +19 continue + endif +21 continue +22 continue + do 24 l=n,1,-1 + if(indxr(l).ne.indxc(l))then + do 23 k=1,n + dum=a(k,indxr(l)) + a(k,indxr(l))=a(k,indxc(l)) + a(k,indxc(l))=dum +23 continue + endif +24 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/gcf.for b/dataassim/math/numrec/f77_sources/gcf.for new file mode 100644 index 0000000..727ad3f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gcf.for @@ -0,0 +1,28 @@ + SUBROUTINE gcf(gammcf,a,x,gln) + INTEGER ITMAX + REAL a,gammcf,gln,x,EPS,FPMIN + PARAMETER (ITMAX=100,EPS=3.e-7,FPMIN=1.e-30) +CU USES gammln + INTEGER i + REAL an,b,c,d,del,h,gammln + gln=gammln(a) + b=x+1.-a + c=1./FPMIN + d=1./b + h=d + do 11 i=1,ITMAX + an=-i*(i-a) + b=b+2. + d=an*d+b + if(abs(d).lt.FPMIN)d=FPMIN + c=b+an/c + if(abs(c).lt.FPMIN)c=FPMIN + d=1./d + del=d*c + h=h*del + if(abs(del-1.).lt.EPS)goto 1 +11 continue + pause 'a too large, ITMAX too small in gcf' +1 gammcf=exp(-x+a*log(x)-gln)*h + return + END diff --git a/dataassim/math/numrec/f77_sources/golden.for b/dataassim/math/numrec/f77_sources/golden.for new file mode 100644 index 0000000..c89d54f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/golden.for @@ -0,0 +1,41 @@ + FUNCTION golden(ax,bx,cx,f,tol,xmin) + REAL golden,ax,bx,cx,tol,xmin,f,R,C + EXTERNAL f + PARAMETER (R=.61803399,C=1.-R) + REAL f1,f2,x0,x1,x2,x3 + x0=ax + x3=cx + if(abs(cx-bx).gt.abs(bx-ax))then + x1=bx + x2=bx+C*(cx-bx) + else + x2=bx + x1=bx-C*(bx-ax) + endif + f1=f(x1) + f2=f(x2) +1 if(abs(x3-x0).gt.tol*(abs(x1)+abs(x2)))then + if(f2.lt.f1)then + x0=x1 + x1=x2 + x2=R*x1+C*x3 + f1=f2 + f2=f(x2) + else + x3=x2 + x2=x1 + x1=R*x2+C*x0 + f2=f1 + f1=f(x1) + endif + goto 1 + endif + if(f1.lt.f2)then + golden=f1 + xmin=x1 + else + golden=f2 + xmin=x2 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/gser.for b/dataassim/math/numrec/f77_sources/gser.for new file mode 100644 index 0000000..09477d9 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/gser.for @@ -0,0 +1,26 @@ + SUBROUTINE gser(gamser,a,x,gln) + INTEGER ITMAX + REAL a,gamser,gln,x,EPS + PARAMETER (ITMAX=100,EPS=3.e-7) +CU USES gammln + INTEGER n + REAL ap,del,sum,gammln + gln=gammln(a) + if(x.le.0.)then + if(x.lt.0.)pause 'x < 0 in gser' + gamser=0. + return + endif + ap=a + sum=1./a + del=sum + do 11 n=1,ITMAX + ap=ap+1. + del=del*x/ap + sum=sum+del + if(abs(del).lt.abs(sum)*EPS)goto 1 +11 continue + pause 'a too large, ITMAX too small in gser' +1 gamser=sum*exp(-x+a*log(x)-gln) + return + END diff --git a/dataassim/math/numrec/f77_sources/hpsel.for b/dataassim/math/numrec/f77_sources/hpsel.for new file mode 100644 index 0000000..7df7098 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hpsel.for @@ -0,0 +1,32 @@ + SUBROUTINE hpsel(m,n,arr,heap) + INTEGER m,n + REAL arr(n),heap(m) +CU USES sort + INTEGER i,j,k + REAL swap + if (m.gt.n/2.or.m.lt.1) pause 'probable misuse of hpsel' + do 11 i=1,m + heap(i)=arr(i) +11 continue + call sort(m,heap) + do 12 i=m+1,n + if(arr(i).gt.heap(1))then + heap(1)=arr(i) + j=1 +1 continue + k=2*j + if(k.gt.m)goto 2 + if(k.ne.m)then + if(heap(k).gt.heap(k+1))k=k+1 + endif + if(heap(j).le.heap(k))goto 2 + swap=heap(k) + heap(k)=heap(j) + heap(j)=swap + j=k + goto 1 +2 continue + endif +12 continue + return + end diff --git a/dataassim/math/numrec/f77_sources/hpsort.for b/dataassim/math/numrec/f77_sources/hpsort.for new file mode 100644 index 0000000..3983df0 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hpsort.for @@ -0,0 +1,39 @@ + SUBROUTINE hpsort(n,ra) + INTEGER n + REAL ra(n) + INTEGER i,ir,j,l + REAL rra + if (n.lt.2) return + l=n/2+1 + ir=n +10 continue + if(l.gt.1)then + l=l-1 + rra=ra(l) + else + rra=ra(ir) + ra(ir)=ra(1) + ir=ir-1 + if(ir.eq.1)then + ra(1)=rra + return + endif + endif + i=l + j=l+l +20 if(j.le.ir)then + if(j.lt.ir)then + if(ra(j).lt.ra(j+1))j=j+1 + endif + if(rra.lt.ra(j))then + ra(i)=ra(j) + i=j + j=j+j + else + j=ir+1 + endif + goto 20 + endif + ra(i)=rra + goto 10 + END diff --git a/dataassim/math/numrec/f77_sources/hqr.for b/dataassim/math/numrec/f77_sources/hqr.for new file mode 100644 index 0000000..68beea8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hqr.for @@ -0,0 +1,134 @@ + SUBROUTINE hqr(a,n,np,wr,wi) + INTEGER n,np + REAL a(np,np),wi(np),wr(np) + INTEGER i,its,j,k,l,m,nn + REAL anorm,p,q,r,s,t,u,v,w,x,y,z + anorm=0. + do 12 i=1,n + do 11 j=max(i-1,1),n + anorm=anorm+abs(a(i,j)) +11 continue +12 continue + nn=n + t=0. +1 if(nn.ge.1)then + its=0 +2 do 13 l=nn,2,-1 + s=abs(a(l-1,l-1))+abs(a(l,l)) + if(s.eq.0.)s=anorm + if(abs(a(l,l-1))+s.eq.s)goto 3 +13 continue + l=1 +3 x=a(nn,nn) + if(l.eq.nn)then + wr(nn)=x+t + wi(nn)=0. + nn=nn-1 + else + y=a(nn-1,nn-1) + w=a(nn,nn-1)*a(nn-1,nn) + if(l.eq.nn-1)then + p=0.5*(y-x) + q=p**2+w + z=sqrt(abs(q)) + x=x+t + if(q.ge.0.)then + z=p+sign(z,p) + wr(nn)=x+z + wr(nn-1)=wr(nn) + if(z.ne.0.)wr(nn)=x-w/z + wi(nn)=0. + wi(nn-1)=0. + else + wr(nn)=x+p + wr(nn-1)=wr(nn) + wi(nn)=z + wi(nn-1)=-z + endif + nn=nn-2 + else + if(its.eq.30)pause 'too many iterations in hqr' + if(its.eq.10.or.its.eq.20)then + t=t+x + do 14 i=1,nn + a(i,i)=a(i,i)-x +14 continue + s=abs(a(nn,nn-1))+abs(a(nn-1,nn-2)) + x=0.75*s + y=x + w=-0.4375*s**2 + endif + its=its+1 + do 15 m=nn-2,l,-1 + z=a(m,m) + r=x-z + s=y-z + p=(r*s-w)/a(m+1,m)+a(m,m+1) + q=a(m+1,m+1)-z-r-s + r=a(m+2,m+1) + s=abs(p)+abs(q)+abs(r) + p=p/s + q=q/s + r=r/s + if(m.eq.l)goto 4 + u=abs(a(m,m-1))*(abs(q)+abs(r)) + v=abs(p)*(abs(a(m-1,m-1))+abs(z)+abs(a(m+1,m+1))) + if(u+v.eq.v)goto 4 +15 continue +4 do 16 i=m+2,nn + a(i,i-2)=0. + if (i.ne.m+2) a(i,i-3)=0. +16 continue + do 19 k=m,nn-1 + if(k.ne.m)then + p=a(k,k-1) + q=a(k+1,k-1) + r=0. + if(k.ne.nn-1)r=a(k+2,k-1) + x=abs(p)+abs(q)+abs(r) + if(x.ne.0.)then + p=p/x + q=q/x + r=r/x + endif + endif + s=sign(sqrt(p**2+q**2+r**2),p) + if(s.ne.0.)then + if(k.eq.m)then + if(l.ne.m)a(k,k-1)=-a(k,k-1) + else + a(k,k-1)=-s*x + endif + p=p+s + x=p/s + y=q/s + z=r/s + q=q/p + r=r/p + do 17 j=k,nn + p=a(k,j)+q*a(k+1,j) + if(k.ne.nn-1)then + p=p+r*a(k+2,j) + a(k+2,j)=a(k+2,j)-p*z + endif + a(k+1,j)=a(k+1,j)-p*y + a(k,j)=a(k,j)-p*x +17 continue + do 18 i=l,min(nn,k+3) + p=x*a(i,k)+y*a(i,k+1) + if(k.ne.nn-1)then + p=p+z*a(i,k+2) + a(i,k+2)=a(i,k+2)-p*r + endif + a(i,k+1)=a(i,k+1)-p*q + a(i,k)=a(i,k)-p +18 continue + endif +19 continue + goto 2 + endif + endif + goto 1 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/hufapp.for b/dataassim/math/numrec/f77_sources/hufapp.for new file mode 100644 index 0000000..626e6ee --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hufapp.for @@ -0,0 +1,19 @@ + SUBROUTINE hufapp(index,nprob,m,l) + INTEGER m,l,MC,MQ + PARAMETER (MC=512,MQ=2*MC-1) + INTEGER index(MQ),nprob(MQ) + INTEGER i,j,k,n + n=m + i=l + k=index(i) +2 if(i.le.n/2)then + j=i+i + if (j.lt.n.and.nprob(index(j)).gt.nprob(index(j+1))) j=j+1 + if (nprob(k).le.nprob(index(j))) goto 3 + index(i)=index(j) + i=j + goto 2 + endif +3 index(i)=k + return + END diff --git a/dataassim/math/numrec/f77_sources/hufdec.for b/dataassim/math/numrec/f77_sources/hufdec.for new file mode 100644 index 0000000..fbd63f8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hufdec.for @@ -0,0 +1,29 @@ + SUBROUTINE hufdec(ich,code,lcode,nb) + INTEGER ich,lcode,nb,MC,MQ + PARAMETER (MC=512,MQ=2*MC-1) + INTEGER l,nc,nch,node,nodemx + INTEGER icod(MQ),left(MQ),iright(MQ),ncod(MQ),nprob(MQ) + LOGICAL btest + CHARACTER*1 code(lcode) + COMMON /hufcom/ icod,ncod,nprob,left,iright,nch,nodemx + SAVE /hufcom/ + node=nodemx +1 continue + nc=nb/8+1 + if (nc.gt.lcode)then + ich=nch + return + endif + l=mod(nb,8) + nb=nb+1 + if(btest(ichar(code(nc)),l))then + node=iright(node) + else + node=left(node) + endif + if(node.le.nch)then + ich=node-1 + return + endif + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/hufenc.for b/dataassim/math/numrec/f77_sources/hufenc.for new file mode 100644 index 0000000..4f514f7 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hufenc.for @@ -0,0 +1,24 @@ + SUBROUTINE hufenc(ich,code,lcode,nb) + INTEGER ich,lcode,nb,MC,MQ + PARAMETER (MC=512,MQ=2*MC-1) + INTEGER k,l,n,nc,nch,nodemx,ntmp,ibset + INTEGER icod(MQ),left(MQ),iright(MQ),ncod(MQ),nprob(MQ) + LOGICAL btest + CHARACTER*1 code(*) + COMMON /hufcom/ icod,ncod,nprob,left,iright,nch,nodemx + SAVE /hufcom/ + k=ich+1 + if(k.gt.nch.or.k.lt.1)pause 'ich out of range in hufenc.' + do 11 n=ncod(k),1,-1 + nc=nb/8+1 + if (nc.gt.lcode) pause 'lcode too small in hufenc.' + l=mod(nb,8) + if (l.eq.0) code(nc)=char(0) + if(btest(icod(k),n-1))then + ntmp=ibset(ichar(code(nc)),l) + code(nc)=char(ntmp) + endif + nb=nb+1 +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/hufmak.for b/dataassim/math/numrec/f77_sources/hufmak.for new file mode 100644 index 0000000..ff302b8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hufmak.for @@ -0,0 +1,67 @@ + SUBROUTINE hufmak(nfreq,nchin,ilong,nlong) + INTEGER ilong,nchin,nlong,nfreq(nchin),MC,MQ + PARAMETER (MC=512,MQ=2*MC-1) +CU USES hufapp + INTEGER ibit,j,k,n,nch,node,nodemx,nused,ibset,index(MQ),iup(MQ), + *icod(MQ),left(MQ),iright(MQ),ncod(MQ),nprob(MQ) + COMMON /hufcom/ icod,ncod,nprob,left,iright,nch,nodemx + SAVE /hufcom/ + nch=nchin + nused=0 + do 11 j=1,nch + nprob(j)=nfreq(j) + icod(j)=0 + ncod(j)=0 + if(nfreq(j).ne.0)then + nused=nused+1 + index(nused)=j + endif +11 continue + do 12 j=nused,1,-1 + call hufapp(index,nprob,nused,j) +12 continue + k=nch +1 if(nused.gt.1)then + node=index(1) + index(1)=index(nused) + nused=nused-1 + call hufapp(index,nprob,nused,1) + k=k+1 + nprob(k)=nprob(index(1))+nprob(node) + left(k)=node + iright(k)=index(1) + iup(index(1)) = -k + iup(node)=k + index(1)=k + call hufapp(index,nprob,nused,1) + goto 1 + endif + nodemx=k + iup(nodemx)=0 + do 13 j=1,nch + if(nprob(j).ne.0)then + n=0 + ibit=0 + node=iup(j) +2 if(node.ne.0)then + if(node.lt.0)then + n=ibset(n,ibit) + node = -node + endif + node=iup(node) + ibit=ibit+1 + goto 2 + endif + icod(j)=n + ncod(j)=ibit + endif +13 continue + nlong=0 + do 14 j=1,nch + if(ncod(j).gt.nlong)then + nlong=ncod(j) + ilong=j-1 + endif +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/hunt.for b/dataassim/math/numrec/f77_sources/hunt.for new file mode 100644 index 0000000..45509d0 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hunt.for @@ -0,0 +1,45 @@ + SUBROUTINE hunt(xx,n,x,jlo) + INTEGER jlo,n + REAL x,xx(n) + INTEGER inc,jhi,jm + LOGICAL ascnd + ascnd=xx(n).ge.xx(1) + if(jlo.le.0.or.jlo.gt.n)then + jlo=0 + jhi=n+1 + goto 3 + endif + inc=1 + if(x.ge.xx(jlo).eqv.ascnd)then +1 jhi=jlo+inc + if(jhi.gt.n)then + jhi=n+1 + else if(x.ge.xx(jhi).eqv.ascnd)then + jlo=jhi + inc=inc+inc + goto 1 + endif + else + jhi=jlo +2 jlo=jhi-inc + if(jlo.lt.1)then + jlo=0 + else if(x.lt.xx(jlo).eqv.ascnd)then + jhi=jlo + inc=inc+inc + goto 2 + endif + endif +3 if(jhi-jlo.eq.1)then + if(x.eq.xx(n))jlo=n-1 + if(x.eq.xx(1))jlo=1 + return + endif + jm=(jhi+jlo)/2 + if(x.ge.xx(jm).eqv.ascnd)then + jlo=jm + else + jhi=jm + endif + goto 3 + END diff --git a/dataassim/math/numrec/f77_sources/hypdrv.for b/dataassim/math/numrec/f77_sources/hypdrv.for new file mode 100644 index 0000000..b681e12 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hypdrv.for @@ -0,0 +1,9 @@ + SUBROUTINE hypdrv(s,y,dyds) + REAL s + COMPLEX y(2),dyds(2),aa,bb,cc,z0,dz,z + COMMON /hypg/ aa,bb,cc,z0,dz + z=z0+s*dz + dyds(1)=y(2)*dz + dyds(2)=((aa*bb)*y(1)-(cc-((aa+bb)+1.)*z)*y(2))*dz/(z*(1.-z)) + return + END diff --git a/dataassim/math/numrec/f77_sources/hypgeo.for b/dataassim/math/numrec/f77_sources/hypgeo.for new file mode 100644 index 0000000..96f5b9b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hypgeo.for @@ -0,0 +1,30 @@ + FUNCTION hypgeo(a,b,c,z) + COMPLEX hypgeo,a,b,c,z + REAL EPS + PARAMETER (EPS=1.e-6) +CU USES bsstep,hypdrv,hypser,odeint + INTEGER kmax,nbad,nok + EXTERNAL bsstep,hypdrv + COMPLEX z0,dz,aa,bb,cc,y(2) + COMMON /hypg/ aa,bb,cc,z0,dz + COMMON /path/ kmax + kmax=0 + if (real(z)**2+aimag(z)**2.le.0.25) then + call hypser(a,b,c,z,hypgeo,y(2)) + return + else if (real(z).lt.0.) then + z0=cmplx(-0.5,0.) + else if (real(z).le.1.0) then + z0=cmplx(0.5,0.) + else + z0=cmplx(0.,sign(0.5,aimag(z))) + endif + aa=a + bb=b + cc=c + dz=z-z0 + call hypser(aa,bb,cc,z0,y(1),y(2)) + call odeint(y,4,0.,1.,EPS,.1,.0001,nok,nbad,hypdrv,bsstep) + hypgeo=y(1) + return + END diff --git a/dataassim/math/numrec/f77_sources/hypser.for b/dataassim/math/numrec/f77_sources/hypser.for new file mode 100644 index 0000000..3c27a1c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/hypser.for @@ -0,0 +1,22 @@ + SUBROUTINE hypser(a,b,c,z,series,deriv) + INTEGER n + COMPLEX a,b,c,z,series,deriv,aa,bb,cc,fac,temp + deriv=cmplx(0.,0.) + fac=cmplx(1.,0.) + temp=fac + aa=a + bb=b + cc=c + do 11 n=1,1000 + fac=((aa*bb)/cc)*fac + deriv=deriv+fac + fac=fac*z/n + series=temp+fac + if (series.eq.temp) return + temp=series + aa=aa+1. + bb=bb+1. + cc=cc+1. +11 continue + pause 'convergence failure in hypser' + END diff --git a/dataassim/math/numrec/f77_sources/icrc.for b/dataassim/math/numrec/f77_sources/icrc.for new file mode 100644 index 0000000..ee5aaf1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/icrc.for @@ -0,0 +1,51 @@ + FUNCTION icrc(crc,bufptr,len,jinit,jrev) + INTEGER icrc,jinit,jrev,len + CHARACTER*1 bufptr(*),crc(2) +CU USES icrc1 + INTEGER ich,init,ireg,j,icrctb(0:255),it(0:15),icrc1,ib1,ib2,ib3 + CHARACTER*1 creg(4),rchr(0:255) + SAVE icrctb,rchr,init,it,ib1,ib2,ib3 + EQUIVALENCE (creg,ireg) + DATA it/0,8,4,12,2,10,6,14,1,9,5,13,3,11,7,15/, init /0/ + if (init.eq.0) then + init=1 + ireg=256*(256*ichar('3')+ichar('2'))+ichar('1') + do 11 j=1,4 + if (creg(j).eq.'1') ib1=j + if (creg(j).eq.'2') ib2=j + if (creg(j).eq.'3') ib3=j +11 continue + do 12 j=0,255 + ireg=j*256 + icrctb(j)=icrc1(creg,char(0),ib1,ib2,ib3) + ich=it(mod(j,16))*16+it(j/16) + rchr(j)=char(ich) +12 continue + endif + if (jinit.ge.0) then + crc(1)=char(jinit) + crc(2)=char(jinit) + else if (jrev.lt.0) then + ich=ichar(crc(1)) + crc(1)=rchr(ichar(crc(2))) + crc(2)=rchr(ich) + endif + do 13 j=1,len + ich=ichar(bufptr(j)) + if(jrev.lt.0)ich=ichar(rchr(ich)) + ireg=icrctb(ieor(ich,ichar(crc(2)))) + crc(2)=char(ieor(ichar(creg(ib2)),ichar(crc(1)))) + crc(1)=creg(ib1) +13 continue + if (jrev.ge.0) then + creg(ib1)=crc(1) + creg(ib2)=crc(2) + else + creg(ib2)=rchr(ichar(crc(1))) + creg(ib1)=rchr(ichar(crc(2))) + crc(1)=creg(ib1) + crc(2)=creg(ib2) + endif + icrc=ireg + return + END diff --git a/dataassim/math/numrec/f77_sources/icrc1.for b/dataassim/math/numrec/f77_sources/icrc1.for new file mode 100644 index 0000000..5c7cd58 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/icrc1.for @@ -0,0 +1,17 @@ + FUNCTION icrc1(crc,onech,ib1,ib2,ib3) + INTEGER icrc1,ib1,ib2,ib3 + INTEGER i,ichr,ireg + CHARACTER*1 onech,crc(4),creg(4) + EQUIVALENCE (creg,ireg) + ireg=0 + creg(ib1)=crc(ib1) + creg(ib2)=char(ieor(ichar(crc(ib2)),ichar(onech))) + do 11 i=1,8 + ichr=ichar(creg(ib2)) + ireg=ireg+ireg + creg(ib3)=char(0) + if(ichr.gt.127)ireg=ieor(ireg,4129) +11 continue + icrc1=ireg + return + END diff --git a/dataassim/math/numrec/f77_sources/igray.for b/dataassim/math/numrec/f77_sources/igray.for new file mode 100644 index 0000000..81cfe69 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/igray.for @@ -0,0 +1,17 @@ + FUNCTION igray(n,is) + INTEGER igray,is,n + INTEGER idiv,ish + if (is.ge.0) then + igray=ieor(n,n/2) + else + ish=-1 + igray=n +1 continue + idiv=ishft(igray,ish) + igray=ieor(igray,idiv) + if(idiv.le.1.or.ish.eq.-16)return + ish=ish+ish + goto 1 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/iindexx.for b/dataassim/math/numrec/f77_sources/iindexx.for new file mode 100644 index 0000000..52be913 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/iindexx.for @@ -0,0 +1,78 @@ + SUBROUTINE iindexx(n,arr,indx) + INTEGER n,indx(n),M,NSTACK + INTEGER arr(n) + PARAMETER (M=7,NSTACK=50) + INTEGER i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) + INTEGER a + do 11 j=1,n + indx(j)=j +11 continue + jstack=0 + l=1 + ir=n +1 if(ir-l.lt.M)then + do 13 j=l+1,ir + indxt=indx(j) + a=arr(indxt) + do 12 i=j-1,1,-1 + if(arr(indx(i)).le.a)goto 2 + indx(i+1)=indx(i) +12 continue + i=0 +2 indx(i+1)=indxt +13 continue + if(jstack.eq.0)return + ir=istack(jstack) + l=istack(jstack-1) + jstack=jstack-2 + else + k=(l+ir)/2 + itemp=indx(k) + indx(k)=indx(l+1) + indx(l+1)=itemp + if(arr(indx(l+1)).gt.arr(indx(ir)))then + itemp=indx(l+1) + indx(l+1)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l)).gt.arr(indx(ir)))then + itemp=indx(l) + indx(l)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l+1)).gt.arr(indx(l)))then + itemp=indx(l+1) + indx(l+1)=indx(l) + indx(l)=itemp + endif + i=l+1 + j=ir + indxt=indx(l) + a=arr(indxt) +3 continue + i=i+1 + if(arr(indx(i)).lt.a)goto 3 +4 continue + j=j-1 + if(arr(indx(j)).gt.a)goto 4 + if(j.lt.i)goto 5 + itemp=indx(i) + indx(i)=indx(j) + indx(j)=itemp + goto 3 +5 indx(l)=indx(j) + indx(j)=indxt + jstack=jstack+2 + if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' + if(ir-i+1.ge.j-l)then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif + endif + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/indexx.for b/dataassim/math/numrec/f77_sources/indexx.for new file mode 100644 index 0000000..545bfa8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/indexx.for @@ -0,0 +1,78 @@ + SUBROUTINE indexx(n,arr,indx) + INTEGER n,indx(n),M,NSTACK + REAL arr(n) + PARAMETER (M=7,NSTACK=50) + INTEGER i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) + REAL a + do 11 j=1,n + indx(j)=j +11 continue + jstack=0 + l=1 + ir=n +1 if(ir-l.lt.M)then + do 13 j=l+1,ir + indxt=indx(j) + a=arr(indxt) + do 12 i=j-1,l,-1 + if(arr(indx(i)).le.a)goto 2 + indx(i+1)=indx(i) +12 continue + i=l-1 +2 indx(i+1)=indxt +13 continue + if(jstack.eq.0)return + ir=istack(jstack) + l=istack(jstack-1) + jstack=jstack-2 + else + k=(l+ir)/2 + itemp=indx(k) + indx(k)=indx(l+1) + indx(l+1)=itemp + if(arr(indx(l)).gt.arr(indx(ir)))then + itemp=indx(l) + indx(l)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l+1)).gt.arr(indx(ir)))then + itemp=indx(l+1) + indx(l+1)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l)).gt.arr(indx(l+1)))then + itemp=indx(l) + indx(l)=indx(l+1) + indx(l+1)=itemp + endif + i=l+1 + j=ir + indxt=indx(l+1) + a=arr(indxt) +3 continue + i=i+1 + if(arr(indx(i)).lt.a)goto 3 +4 continue + j=j-1 + if(arr(indx(j)).gt.a)goto 4 + if(j.lt.i)goto 5 + itemp=indx(i) + indx(i)=indx(j) + indx(j)=itemp + goto 3 +5 indx(l+1)=indx(j) + indx(j)=indxt + jstack=jstack+2 + if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' + if(ir-i+1.ge.j-l)then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif + endif + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/interp.for b/dataassim/math/numrec/f77_sources/interp.for new file mode 100644 index 0000000..05e2498 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/interp.for @@ -0,0 +1,23 @@ + SUBROUTINE interp(uf,uc,nf) + INTEGER nf + DOUBLE PRECISION uc(nf/2+1,nf/2+1),uf(nf,nf) + INTEGER ic,if,jc,jf,nc + nc=nf/2+1 + do 12 jc=1,nc + jf=2*jc-1 + do 11 ic=1,nc + uf(2*ic-1,jf)=uc(ic,jc) +11 continue +12 continue + do 14 jf=1,nf,2 + do 13 if=2,nf-1,2 + uf(if,jf)=.5d0*(uf(if+1,jf)+uf(if-1,jf)) +13 continue +14 continue + do 16 jf=2,nf-1,2 + do 15 if=1,nf + uf(if,jf)=.5d0*(uf(if,jf+1)+uf(if,jf-1)) +15 continue +16 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/irbit1.for b/dataassim/math/numrec/f77_sources/irbit1.for new file mode 100644 index 0000000..f430b9d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/irbit1.for @@ -0,0 +1,16 @@ + FUNCTION irbit1(iseed) + INTEGER irbit1,iseed,IB1,IB2,IB5,IB18 + PARAMETER (IB1=1,IB2=2,IB5=16,IB18=131072) + LOGICAL newbit + newbit=iand(iseed,IB18).ne.0 + if(iand(iseed,IB5).ne.0)newbit=.not.newbit + if(iand(iseed,IB2).ne.0)newbit=.not.newbit + if(iand(iseed,IB1).ne.0)newbit=.not.newbit + irbit1=0 + iseed=iand(ishft(iseed,1),not(IB1)) + if(newbit)then + irbit1=1 + iseed=ior(iseed,IB1) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/irbit2.for b/dataassim/math/numrec/f77_sources/irbit2.for new file mode 100644 index 0000000..f2d084a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/irbit2.for @@ -0,0 +1,12 @@ + FUNCTION irbit2(iseed) + INTEGER irbit2,iseed,IB1,IB2,IB5,IB18,MASK + PARAMETER (IB1=1,IB2=2,IB5=16,IB18=131072,MASK=IB1+IB2+IB5) + if(iand(iseed,IB18).ne.0)then + iseed=ior(ishft(ieor(iseed,MASK),1),IB1) + irbit2=1 + else + iseed=iand(ishft(iseed,1),not(IB1)) + irbit2=0 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/jacobi.for b/dataassim/math/numrec/f77_sources/jacobi.for new file mode 100644 index 0000000..33a55f9 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/jacobi.for @@ -0,0 +1,92 @@ + SUBROUTINE jacobi(a,n,np,d,v,nrot) + INTEGER n,np,nrot,NMAX + REAL a(np,np),d(np),v(np,np) + PARAMETER (NMAX=500) + INTEGER i,ip,iq,j + REAL c,g,h,s,sm,t,tau,theta,tresh,b(NMAX),z(NMAX) + do 12 ip=1,n + do 11 iq=1,n + v(ip,iq)=0. +11 continue + v(ip,ip)=1. +12 continue + do 13 ip=1,n + b(ip)=a(ip,ip) + d(ip)=b(ip) + z(ip)=0. +13 continue + nrot=0 + do 24 i=1,50 + sm=0. + do 15 ip=1,n-1 + do 14 iq=ip+1,n + sm=sm+abs(a(ip,iq)) +14 continue +15 continue + if(sm.eq.0.)return + if(i.lt.4)then + tresh=0.2*sm/n**2 + else + tresh=0. + endif + do 22 ip=1,n-1 + do 21 iq=ip+1,n + g=100.*abs(a(ip,iq)) + if((i.gt.4).and.(abs(d(ip))+ + *g.eq.abs(d(ip))).and.(abs(d(iq))+g.eq.abs(d(iq))))then + a(ip,iq)=0. + else if(abs(a(ip,iq)).gt.tresh)then + h=d(iq)-d(ip) + if(abs(h)+g.eq.abs(h))then + t=a(ip,iq)/h + else + theta=0.5*h/a(ip,iq) + t=1./(abs(theta)+sqrt(1.+theta**2)) + if(theta.lt.0.)t=-t + endif + c=1./sqrt(1+t**2) + s=t*c + tau=s/(1.+c) + h=t*a(ip,iq) + z(ip)=z(ip)-h + z(iq)=z(iq)+h + d(ip)=d(ip)-h + d(iq)=d(iq)+h + a(ip,iq)=0. + do 16 j=1,ip-1 + g=a(j,ip) + h=a(j,iq) + a(j,ip)=g-s*(h+g*tau) + a(j,iq)=h+s*(g-h*tau) +16 continue + do 17 j=ip+1,iq-1 + g=a(ip,j) + h=a(j,iq) + a(ip,j)=g-s*(h+g*tau) + a(j,iq)=h+s*(g-h*tau) +17 continue + do 18 j=iq+1,n + g=a(ip,j) + h=a(iq,j) + a(ip,j)=g-s*(h+g*tau) + a(iq,j)=h+s*(g-h*tau) +18 continue + do 19 j=1,n + g=v(j,ip) + h=v(j,iq) + v(j,ip)=g-s*(h+g*tau) + v(j,iq)=h+s*(g-h*tau) +19 continue + nrot=nrot+1 + endif +21 continue +22 continue + do 23 ip=1,n + b(ip)=b(ip)+z(ip) + d(ip)=b(ip) + z(ip)=0. +23 continue +24 continue + pause 'too many iterations in jacobi' + return + END diff --git a/dataassim/math/numrec/f77_sources/jacobn.for b/dataassim/math/numrec/f77_sources/jacobn.for new file mode 100644 index 0000000..97b939a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/jacobn.for @@ -0,0 +1,24 @@ + SUBROUTINE jacobn(x,y,dfdx,dfdy,n,nmax) + INTEGER n,nmax,i + REAL x,y(*),dfdx(*),dfdy(nmax,nmax) + do 11 i=1,3 + dfdx(i)=0. +11 continue + dfdy(1,1)=-.013-1000.*y(3) + dfdy(1,2)=0. + dfdy(1,3)=-1000.*y(1) + dfdy(2,1)=0. + dfdy(2,2)=-2500.*y(3) + dfdy(2,3)=-2500.*y(2) + dfdy(3,1)=-.013-1000.*y(3) + dfdy(3,2)=-2500.*y(3) + dfdy(3,3)=-1000.*y(1)-2500.*y(2) + return + END + SUBROUTINE derivs(x,y,dydx) + REAL x,y(*),dydx(*) + dydx(1)=-.013*y(1)-1000.*y(1)*y(3) + dydx(2)=-2500.*y(2)*y(3) + dydx(3)=-.013*y(1)-1000.*y(1)*y(3)-2500.*y(2)*y(3) + return + END diff --git a/dataassim/math/numrec/f77_sources/julday.for b/dataassim/math/numrec/f77_sources/julday.for new file mode 100644 index 0000000..127adac --- /dev/null +++ b/dataassim/math/numrec/f77_sources/julday.for @@ -0,0 +1,20 @@ + FUNCTION julday(mm,id,iyyy) + INTEGER julday,id,iyyy,mm,IGREG + PARAMETER (IGREG=15+31*(10+12*1582)) + INTEGER ja,jm,jy + jy=iyyy + if (jy.eq.0) pause 'julday: there is no year zero' + if (jy.lt.0) jy=jy+1 + if (mm.gt.2) then + jm=mm+1 + else + jy=jy-1 + jm=mm+13 + endif + julday=int(365.25*jy)+int(30.6001*jm)+id+1720995 + if (id+31*(mm+12*iyyy).ge.IGREG) then + ja=int(0.01*jy) + julday=julday+2-ja+int(0.25*ja) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/kendl1.for b/dataassim/math/numrec/f77_sources/kendl1.for new file mode 100644 index 0000000..abeb0a4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/kendl1.for @@ -0,0 +1,34 @@ + SUBROUTINE kendl1(data1,data2,n,tau,z,prob) + INTEGER n + REAL prob,tau,z,data1(n),data2(n) +CU USES erfcc + INTEGER is,j,k,n1,n2 + REAL a1,a2,aa,var,erfcc + n1=0 + n2=0 + is=0 + do 12 j=1,n-1 + do 11 k=j+1,n + a1=data1(j)-data1(k) + a2=data2(j)-data2(k) + aa=a1*a2 + if(aa.ne.0.)then + n1=n1+1 + n2=n2+1 + if(aa.gt.0.)then + is=is+1 + else + is=is-1 + endif + else + if(a1.ne.0.)n1=n1+1 + if(a2.ne.0.)n2=n2+1 + endif +11 continue +12 continue + tau=float(is)/sqrt(float(n1)*float(n2)) + var=(4.*n+10.)/(9.*n*(n-1.)) + z=tau/sqrt(var) + prob=erfcc(abs(z)/1.4142136) + return + END diff --git a/dataassim/math/numrec/f77_sources/kendl2.for b/dataassim/math/numrec/f77_sources/kendl2.for new file mode 100644 index 0000000..3cf1fa1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/kendl2.for @@ -0,0 +1,42 @@ + SUBROUTINE kendl2(tab,i,j,ip,jp,tau,z,prob) + INTEGER i,ip,j,jp + REAL prob,tau,z,tab(ip,jp) +CU USES erfcc + INTEGER k,ki,kj,l,li,lj,m1,m2,mm,nn + REAL en1,en2,pairs,points,s,var,erfcc + en1=0. + en2=0. + s=0. + nn=i*j + points=tab(i,j) + do 12 k=0,nn-2 + ki=k/j + kj=k-j*ki + points=points+tab(ki+1,kj+1) + do 11 l=k+1,nn-1 + li=l/j + lj=l-j*li + m1=li-ki + m2=lj-kj + mm=m1*m2 + pairs=tab(ki+1,kj+1)*tab(li+1,lj+1) + if(mm.ne.0)then + en1=en1+pairs + en2=en2+pairs + if(mm.gt.0)then + s=s+pairs + else + s=s-pairs + endif + else + if(m1.ne.0)en1=en1+pairs + if(m2.ne.0)en2=en2+pairs + endif +11 continue +12 continue + tau=s/sqrt(en1*en2) + var=(4.*points+10.)/(9.*points*(points-1.)) + z=tau/sqrt(var) + prob=erfcc(abs(z)/1.4142136) + return + END diff --git a/dataassim/math/numrec/f77_sources/kermom.for b/dataassim/math/numrec/f77_sources/kermom.for new file mode 100644 index 0000000..c3bd4c9 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/kermom.for @@ -0,0 +1,26 @@ + SUBROUTINE kermom(w,y,m) + INTEGER m + DOUBLE PRECISION w(m),y,x,d,df,clog,x2,x3,x4 + COMMON /momcom/ x + if (y.ge.x) then + d=y-x + df=2.d0*sqrt(d)*d + w(1)=df/3.d0 + w(2)=df*(x/3.d0+d/5.d0) + w(3)=df*((x/3.d0 + 0.4d0*d)*x + d**2/7.d0) + w(4)=df*(((x/3.d0 + 0.6d0*d)*x + 3.d0*d**2/7.d0)*x+ d**3/9.d0) + else + x2=x**2 + x3=x2*x + x4=x2*x2 + d=x-y + clog=log(d) + w(1)=d*(clog-1.d0) + w(2)=-0.25d0*(3.d0*x+y-2.d0*clog*(x+y))*d + w(3)=(-11.d0*x3+y*(6.d0*x2+y*(3.d0*x+2.d0*y))+6.d0*clog*(x3-y** + *3))/18.d0 + w(4)=(-25.d0*x4+y*(12.d0*x3+y*(6.d0*x2+y*(4.d0*x+3.d0*y)))+ + *12.d0*clog*(x4-y**4))/48.d0 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/ks2d1s.for b/dataassim/math/numrec/f77_sources/ks2d1s.for new file mode 100644 index 0000000..9b4919f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ks2d1s.for @@ -0,0 +1,19 @@ + SUBROUTINE ks2d1s(x1,y1,n1,quadvl,d1,prob) + INTEGER n1 + REAL d1,prob,x1(n1),y1(n1) + EXTERNAL quadvl +CU USES pearsn,probks,quadct,quadvl + INTEGER j + REAL dum,dumm,fa,fb,fc,fd,ga,gb,gc,gd,r1,rr,sqen,probks + d1=0.0 + do 11 j=1,n1 + call quadct(x1(j),y1(j),x1,y1,n1,fa,fb,fc,fd) + call quadvl(x1(j),y1(j),ga,gb,gc,gd) + d1=max(d1,abs(fa-ga),abs(fb-gb),abs(fc-gc),abs(fd-gd)) +11 continue + call pearsn(x1,y1,n1,r1,dum,dumm) + sqen=sqrt(float(n1)) + rr=sqrt(1.0-r1**2) + prob=probks(d1*sqen/(1.0+rr*(0.25-0.75/sqen))) + return + END diff --git a/dataassim/math/numrec/f77_sources/ks2d2s.for b/dataassim/math/numrec/f77_sources/ks2d2s.for new file mode 100644 index 0000000..1e4dc62 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ks2d2s.for @@ -0,0 +1,26 @@ + SUBROUTINE ks2d2s(x1,y1,n1,x2,y2,n2,d,prob) + INTEGER n1,n2 + REAL d,prob,x1(n1),x2(n2),y1(n1),y2(n2) +CU USES pearsn,probks,quadct + INTEGER j + REAL d1,d2,dum,dumm,fa,fb,fc,fd,ga,gb,gc,gd,r1,r2,rr,sqen,probks + d1=0.0 + do 11 j=1,n1 + call quadct(x1(j),y1(j),x1,y1,n1,fa,fb,fc,fd) + call quadct(x1(j),y1(j),x2,y2,n2,ga,gb,gc,gd) + d1=max(d1,abs(fa-ga),abs(fb-gb),abs(fc-gc),abs(fd-gd)) +11 continue + d2=0.0 + do 12 j=1,n2 + call quadct(x2(j),y2(j),x1,y1,n1,fa,fb,fc,fd) + call quadct(x2(j),y2(j),x2,y2,n2,ga,gb,gc,gd) + d2=max(d2,abs(fa-ga),abs(fb-gb),abs(fc-gc),abs(fd-gd)) +12 continue + d=0.5*(d1+d2) + sqen=sqrt(float(n1)*float(n2)/float(n1+n2)) + call pearsn(x1,y1,n1,r1,dum,dumm) + call pearsn(x2,y2,n2,r2,dum,dumm) + rr=sqrt(1.0-0.5*(r1**2+r2**2)) + prob=probks(d*sqen/(1.0+rr*(0.25-0.75/sqen))) + return + END diff --git a/dataassim/math/numrec/f77_sources/ksone.for b/dataassim/math/numrec/f77_sources/ksone.for new file mode 100644 index 0000000..49be4d6 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ksone.for @@ -0,0 +1,22 @@ + SUBROUTINE ksone(data,n,func,d,prob) + INTEGER n + REAL d,data(n),func,prob + EXTERNAL func +CU USES probks,sort + INTEGER j + REAL dt,en,ff,fn,fo,probks + call sort(n,data) + en=n + d=0. + fo=0. + do 11 j=1,n + fn=j/en + ff=func(data(j)) + dt=max(abs(fo-ff),abs(fn-ff)) + if(dt.gt.d)d=dt + fo=fn +11 continue + en=sqrt(en) + prob=probks((en+0.12+0.11/en)*d) + return + END diff --git a/dataassim/math/numrec/f77_sources/kstwo.for b/dataassim/math/numrec/f77_sources/kstwo.for new file mode 100644 index 0000000..b288a11 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/kstwo.for @@ -0,0 +1,34 @@ + SUBROUTINE kstwo(data1,n1,data2,n2,d,prob) + INTEGER n1,n2 + REAL d,prob,data1(n1),data2(n2) +CU USES probks,sort + INTEGER j1,j2 + REAL d1,d2,dt,en1,en2,en,fn1,fn2,probks + call sort(n1,data1) + call sort(n2,data2) + en1=n1 + en2=n2 + j1=1 + j2=1 + fn1=0. + fn2=0. + d=0. +1 if(j1.le.n1.and.j2.le.n2)then + d1=data1(j1) + d2=data2(j2) + if(d1.le.d2)then + fn1=j1/en1 + j1=j1+1 + endif + if(d2.le.d1)then + fn2=j2/en2 + j2=j2+1 + endif + dt=abs(fn2-fn1) + if(dt.gt.d)d=dt + goto 1 + endif + en=sqrt(en1*en2/(en1+en2)) + prob=probks((en+0.12+0.11/en)*d) + return + END diff --git a/dataassim/math/numrec/f77_sources/laguer.for b/dataassim/math/numrec/f77_sources/laguer.for new file mode 100644 index 0000000..3ed1efb --- /dev/null +++ b/dataassim/math/numrec/f77_sources/laguer.for @@ -0,0 +1,53 @@ + SUBROUTINE laguer(a,m,x,its) + INTEGER m,its,MAXIT,MR,MT + REAL EPSS + COMPLEX a(m+1),x + PARAMETER (EPSS=2.e-7,MR=8,MT=10,MAXIT=MT*MR) + INTEGER iter,j + REAL abx,abp,abm,err,frac(MR) + COMPLEX dx,x1,b,d,f,g,h,sq,gp,gm,g2 + SAVE frac + DATA frac /.5,.25,.75,.13,.38,.62,.88,1./ + do 12 iter=1,MAXIT + its=iter + b=a(m+1) + err=abs(b) + d=cmplx(0.,0.) + f=cmplx(0.,0.) + abx=abs(x) + do 11 j=m,1,-1 + f=x*f+d + d=x*d+b + b=x*b+a(j) + err=abs(b)+abx*err +11 continue + err=EPSS*err + if(abs(b).le.err) then + return + else + g=d/b + g2=g*g + h=g2-2.*f/b + sq=sqrt((m-1)*(m*h-g2)) + gp=g+sq + gm=g-sq + abp=abs(gp) + abm=abs(gm) + if(abp.lt.abm) gp=gm + if (max(abp,abm).gt.0.) then + dx=m/gp + else + dx=exp(cmplx(log(1.+abx),float(iter))) + endif + endif + x1=x-dx + if(x.eq.x1)return + if (mod(iter,MT).ne.0) then + x=x1 + else + x=x-dx*frac(iter/MT) + endif +12 continue + pause 'too many iterations in laguer' + return + END diff --git a/dataassim/math/numrec/f77_sources/lfit.for b/dataassim/math/numrec/f77_sources/lfit.for new file mode 100644 index 0000000..973c553 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/lfit.for @@ -0,0 +1,69 @@ + SUBROUTINE lfit(x,y,sig,ndat,a,ia,ma,covar,npc,chisq,funcs) + INTEGER ma,ia(ma),npc,ndat,MMAX + REAL chisq,a(ma),covar(npc,npc),sig(ndat),x(ndat),y(ndat) + EXTERNAL funcs + PARAMETER (MMAX=50) +CU USES covsrt,gaussj + INTEGER i,j,k,l,m,mfit + REAL sig2i,sum,wt,ym,afunc(MMAX),beta(MMAX) + mfit=0 + do 11 j=1,ma + if(ia(j).ne.0) mfit=mfit+1 +11 continue + if(mfit.eq.0) pause 'lfit: no parameters to be fitted' + do 13 j=1,mfit + do 12 k=1,mfit + covar(j,k)=0. +12 continue + beta(j)=0. +13 continue + do 17 i=1,ndat + call funcs(x(i),afunc,ma) + ym=y(i) + if(mfit.lt.ma) then + do 14 j=1,ma + if(ia(j).eq.0) ym=ym-a(j)*afunc(j) +14 continue + endif + sig2i=1./sig(i)**2 + j=0 + do 16 l=1,ma + if (ia(l).ne.0) then + j=j+1 + wt=afunc(l)*sig2i + k=0 + do 15 m=1,l + if (ia(m).ne.0) then + k=k+1 + covar(j,k)=covar(j,k)+wt*afunc(m) + endif +15 continue + beta(j)=beta(j)+ym*wt + endif +16 continue +17 continue + do 19 j=2,mfit + do 18 k=1,j-1 + covar(k,j)=covar(j,k) +18 continue +19 continue + call gaussj(covar,mfit,npc,beta,1,1) + j=0 + do 21 l=1,ma + if(ia(l).ne.0) then + j=j+1 + a(l)=beta(j) + endif +21 continue + chisq=0. + do 23 i=1,ndat + call funcs(x(i),afunc,ma) + sum=0. + do 22 j=1,ma + sum=sum+a(j)*afunc(j) +22 continue + chisq=chisq+((y(i)-sum)/sig(i))**2 +23 continue + call covsrt(covar,npc,ma,ia,mfit) + return + END diff --git a/dataassim/math/numrec/f77_sources/linbcg.for b/dataassim/math/numrec/f77_sources/linbcg.for new file mode 100644 index 0000000..806ef9a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/linbcg.for @@ -0,0 +1,90 @@ + SUBROUTINE linbcg(n,b,x,itol,tol,itmax,iter,err) + INTEGER iter,itmax,itol,n,NMAX + DOUBLE PRECISION err,tol,b(*),x(*),EPS + PARAMETER (NMAX=1024,EPS=1.d-14) +CU USES atimes,asolve,snrm + INTEGER j + DOUBLE PRECISION ak,akden,bk,bkden,bknum,bnrm,dxnrm,xnrm,zm1nrm, + *znrm,p(NMAX),pp(NMAX),r(NMAX),rr(NMAX),z(NMAX),zz(NMAX),snrm + iter=0 + call atimes(n,x,r,0) + do 11 j=1,n + r(j)=b(j)-r(j) + rr(j)=r(j) +11 continue +C call atimes(n,r,rr,0) + if(itol.eq.1) then + bnrm=snrm(n,b,itol) + call asolve(n,r,z,0) + else if (itol.eq.2) then + call asolve(n,b,z,0) + bnrm=snrm(n,z,itol) + call asolve(n,r,z,0) + else if (itol.eq.3.or.itol.eq.4) then + call asolve(n,b,z,0) + bnrm=snrm(n,z,itol) + call asolve(n,r,z,0) + znrm=snrm(n,z,itol) + else + pause 'illegal itol in linbcg' + endif +100 if (iter.le.itmax) then + iter=iter+1 + call asolve(n,rr,zz,1) + bknum=0.d0 + do 12 j=1,n + bknum=bknum+z(j)*rr(j) +12 continue + if(iter.eq.1) then + do 13 j=1,n + p(j)=z(j) + pp(j)=zz(j) +13 continue + else + bk=bknum/bkden + do 14 j=1,n + p(j)=bk*p(j)+z(j) + pp(j)=bk*pp(j)+zz(j) +14 continue + endif + bkden=bknum + call atimes(n,p,z,0) + akden=0.d0 + do 15 j=1,n + akden=akden+z(j)*pp(j) +15 continue + ak=bknum/akden + call atimes(n,pp,zz,1) + do 16 j=1,n + x(j)=x(j)+ak*p(j) + r(j)=r(j)-ak*z(j) + rr(j)=rr(j)-ak*zz(j) +16 continue + call asolve(n,r,z,0) + if(itol.eq.1)then + err=snrm(n,r,itol)/bnrm + else if(itol.eq.2)then + err=snrm(n,z,itol)/bnrm + else if(itol.eq.3.or.itol.eq.4)then + zm1nrm=znrm + znrm=snrm(n,z,itol) + if(abs(zm1nrm-znrm).gt.EPS*znrm) then + dxnrm=abs(ak)*snrm(n,p,itol) + err=znrm/abs(zm1nrm-znrm)*dxnrm + else + err=znrm/bnrm + goto 100 + endif + xnrm=snrm(n,x,itol) + if(err.le.0.5d0*xnrm) then + err=err/xnrm + else + err=znrm/bnrm + goto 100 + endif + endif + write (*,*) ' iter=',iter,' err=',err + if(err.gt.tol) goto 100 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/linmin.for b/dataassim/math/numrec/f77_sources/linmin.for new file mode 100644 index 0000000..84312ac --- /dev/null +++ b/dataassim/math/numrec/f77_sources/linmin.for @@ -0,0 +1,24 @@ + SUBROUTINE linmin(p,xi,n,fret) + INTEGER n,NMAX + REAL fret,p(n),xi(n),TOL + PARAMETER (NMAX=50,TOL=1.e-4) +CU USES brent,f1dim,mnbrak + INTEGER j,ncom + REAL ax,bx,fa,fb,fx,xmin,xx,pcom(NMAX),xicom(NMAX),brent + COMMON /f1com/ pcom,xicom,ncom + EXTERNAL f1dim + ncom=n + do 11 j=1,n + pcom(j)=p(j) + xicom(j)=xi(j) +11 continue + ax=0. + xx=1. + call mnbrak(ax,xx,bx,fa,fx,fb,f1dim) + fret=brent(ax,xx,bx,f1dim,TOL,xmin) + do 12 j=1,n + xi(j)=xmin*xi(j) + p(j)=p(j)+xi(j) +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/lnsrch.for b/dataassim/math/numrec/f77_sources/lnsrch.for new file mode 100644 index 0000000..ed30a6c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/lnsrch.for @@ -0,0 +1,69 @@ + SUBROUTINE lnsrch(n,xold,fold,g,p,x,f,stpmax,check,func) + INTEGER n + LOGICAL check + REAL f,fold,stpmax,g(n),p(n),x(n),xold(n),func,ALF,TOLX + PARAMETER (ALF=1.e-4,TOLX=1.e-7) + EXTERNAL func +CU USES func + INTEGER i + REAL a,alam,alam2,alamin,b,disc,f2,fold2,rhs1,rhs2,slope,sum,temp, + *test,tmplam + check=.false. + sum=0. + do 11 i=1,n + sum=sum+p(i)*p(i) +11 continue + sum=sqrt(sum) + if(sum.gt.stpmax)then + do 12 i=1,n + p(i)=p(i)*stpmax/sum +12 continue + endif + slope=0. + do 13 i=1,n + slope=slope+g(i)*p(i) +13 continue + test=0. + do 14 i=1,n + temp=abs(p(i))/max(abs(xold(i)),1.) + if(temp.gt.test)test=temp +14 continue + alamin=TOLX/test + alam=1. +1 continue + do 15 i=1,n + x(i)=xold(i)+alam*p(i) +15 continue + f=func(x) + if(alam.lt.alamin)then + do 16 i=1,n + x(i)=xold(i) +16 continue + check=.true. + return + else if(f.le.fold+ALF*alam*slope)then + return + else + if(alam.eq.1.)then + tmplam=-slope/(2.*(f-fold-slope)) + else + rhs1=f-fold-alam*slope + rhs2=f2-fold2-alam2*slope + a=(rhs1/alam**2-rhs2/alam2**2)/(alam-alam2) + b=(-alam2*rhs1/alam**2+alam*rhs2/alam2**2)/(alam-alam2) + if(a.eq.0.)then + tmplam=-slope/(2.*b) + else + disc=b*b-3.*a*slope + if(disc.lt.0.) pause 'roundoff problem in lnsrch' + tmplam=(-b+sqrt(disc))/(3.*a) + endif + if(tmplam.gt..5*alam)tmplam=.5*alam + endif + endif + alam2=alam + f2=f + fold2=fold + alam=max(tmplam,.1*alam) + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/locate.for b/dataassim/math/numrec/f77_sources/locate.for new file mode 100644 index 0000000..6f9b07e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/locate.for @@ -0,0 +1,24 @@ + SUBROUTINE locate(xx,n,x,j) + INTEGER j,n + REAL x,xx(n) + INTEGER jl,jm,ju + jl=0 + ju=n+1 +10 if(ju-jl.gt.1)then + jm=(ju+jl)/2 + if((xx(n).ge.xx(1)).eqv.(x.ge.xx(jm)))then + jl=jm + else + ju=jm + endif + goto 10 + endif + if(x.eq.xx(1))then + j=1 + else if(x.eq.xx(n))then + j=n-1 + else + j=jl + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/lop.for b/dataassim/math/numrec/f77_sources/lop.for new file mode 100644 index 0000000..67c3a22 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/lop.for @@ -0,0 +1,21 @@ + SUBROUTINE lop(out,u,n) + INTEGER n + DOUBLE PRECISION out(n,n),u(n,n) + INTEGER i,j + DOUBLE PRECISION h,h2i + h=1.d0/(n-1) + h2i=1.d0/(h*h) + do 12 j=2,n-1 + do 11 i=2,n-1 + out(i,j)=h2i*(u(i+1,j)+u(i-1,j)+u(i,j+1)+u(i,j-1)-4.d0*u(i, + *j))+u(i,j)**2 +11 continue +12 continue + do 13 i=1,n + out(i,1)=0.d0 + out(i,n)=0.d0 + out(1,i)=0.d0 + out(n,i)=0.d0 +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/lubksb.for b/dataassim/math/numrec/f77_sources/lubksb.for new file mode 100644 index 0000000..871ccfd --- /dev/null +++ b/dataassim/math/numrec/f77_sources/lubksb.for @@ -0,0 +1,28 @@ + SUBROUTINE lubksb(a,n,np,indx,b) + INTEGER n,np,indx(n) + REAL a(np,np),b(n) + INTEGER i,ii,j,ll + REAL sum + ii=0 + do 12 i=1,n + ll=indx(i) + sum=b(ll) + b(ll)=b(i) + if (ii.ne.0)then + do 11 j=ii,i-1 + sum=sum-a(i,j)*b(j) +11 continue + else if (sum.ne.0.) then + ii=i + endif + b(i)=sum +12 continue + do 14 i=n,1,-1 + sum=b(i) + do 13 j=i+1,n + sum=sum-a(i,j)*b(j) +13 continue + b(i)=sum/a(i,i) +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/ludcmp.for b/dataassim/math/numrec/f77_sources/ludcmp.for new file mode 100644 index 0000000..20538bf --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ludcmp.for @@ -0,0 +1,56 @@ + SUBROUTINE ludcmp(a,n,np,indx,d) + INTEGER n,np,indx(n),NMAX + REAL d,a(np,np),TINY + PARAMETER (NMAX=500,TINY=1.0e-20) + INTEGER i,imax,j,k + REAL aamax,dum,sum,vv(NMAX) + d=1. + do 12 i=1,n + aamax=0. + do 11 j=1,n + if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j)) +11 continue + if (aamax.eq.0.) pause 'singular matrix in ludcmp' + vv(i)=1./aamax +12 continue + do 19 j=1,n + do 14 i=1,j-1 + sum=a(i,j) + do 13 k=1,i-1 + sum=sum-a(i,k)*a(k,j) +13 continue + a(i,j)=sum +14 continue + aamax=0. + do 16 i=j,n + sum=a(i,j) + do 15 k=1,j-1 + sum=sum-a(i,k)*a(k,j) +15 continue + a(i,j)=sum + dum=vv(i)*abs(sum) + if (dum.ge.aamax) then + imax=i + aamax=dum + endif +16 continue + if (j.ne.imax)then + do 17 k=1,n + dum=a(imax,k) + a(imax,k)=a(j,k) + a(j,k)=dum +17 continue + d=-d + vv(imax)=vv(j) + endif + indx(j)=imax + if(a(j,j).eq.0.)a(j,j)=TINY + if(j.ne.n)then + dum=1./a(j,j) + do 18 i=j+1,n + a(i,j)=a(i,j)*dum +18 continue + endif +19 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/machar.for b/dataassim/math/numrec/f77_sources/machar.for new file mode 100644 index 0000000..2f0e20c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/machar.for @@ -0,0 +1,132 @@ + SUBROUTINE machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp, + *maxexp,eps,epsneg,xmin,xmax) + INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd + REAL eps,epsneg,xmax,xmin + INTEGER i,itemp,iz,j,k,mx,nxres + REAL a,b,beta,betah,betain,one,t,temp,temp1,tempa,two,y,z,zero, + *CONV + CONV(i)=float(i) + one=CONV(1) + two=one+one + zero=one-one + a=one +1 continue + a=a+a + temp=a+one + temp1=temp-a + if (temp1-one.eq.zero) goto 1 + b=one +2 continue + b=b+b + temp=a+b + itemp=int(temp-a) + if (itemp.eq.0) goto 2 + ibeta=itemp + beta=CONV(ibeta) + it=0 + b=one +3 continue + it=it+1 + b=b*beta + temp=b+one + temp1=temp-b + if (temp1-one.eq.zero) goto 3 + irnd=0 + betah=beta/two + temp=a+betah + if (temp-a.ne.zero) irnd=1 + tempa=a+beta + temp=tempa+betah + if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2 + negep=it+3 + betain=one/beta + a=one + do 11 i=1, negep + a=a*betain +11 continue + b=a +4 continue + temp=one-a + if (temp-one.ne.zero) goto 5 + a=a*beta + negep=negep-1 + goto 4 +5 negep=-negep + epsneg=a + machep=-it-3 + a=b +6 continue + temp=one+a + if (temp-one.ne.zero) goto 7 + a=a*beta + machep=machep+1 + goto 6 +7 eps=a + ngrd=0 + temp=one+eps + if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1 + i=0 + k=1 + z=betain + t=one+eps + nxres=0 +8 continue + y=z + z=y*y + a=z*one + temp=z*t + if ((a+a.eq.zero).or.(abs(z).ge.y)) goto 9 + temp1=temp*betain + if (temp1*beta.eq.z) goto 9 + i=i+1 + k=k+k + goto 8 +9 if (ibeta.ne.10) then + iexp=i+1 + mx=k+k + else + iexp=2 + iz=ibeta +10 if (k.ge.iz) then + iz=iz*ibeta + iexp=iexp+1 + goto 10 + endif + mx=iz+iz-1 + endif +20 xmin=y + y=y*betain + a=y*one + temp=y*t + if (((a+a).ne.zero).and.(abs(y).lt.xmin)) then + k=k+1 + temp1=temp*betain + if ((temp1*beta.ne.y).or.(temp.eq.y)) then + goto 20 + else + nxres=3 + xmin=y + endif + endif + minexp=-k + if ((mx.le.k+k-3).and.(ibeta.ne.10)) then + mx=mx+mx + iexp=iexp+1 + endif + maxexp=mx+minexp + irnd=irnd+nxres + if (irnd.ge.2) maxexp=maxexp-2 + i=maxexp+minexp + if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1 + if (i.gt.20) maxexp=maxexp-1 + if (a.ne.y) maxexp=maxexp-2 + xmax=one-epsneg + if (xmax*one.ne.xmax) xmax=one-beta*epsneg + xmax=xmax/(beta*beta*beta*xmin) + i=maxexp+minexp+3 + do 12 j=1,i + if (ibeta.eq.2) xmax=xmax+xmax + if (ibeta.ne.2) xmax=xmax*beta +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/maloc.for b/dataassim/math/numrec/f77_sources/maloc.for new file mode 100644 index 0000000..316cbf3 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/maloc.for @@ -0,0 +1,13 @@ + FUNCTION maloc(len) + INTEGER maloc,len,NG,MEMLEN + PARAMETER (NG=5,MEMLEN=13*2**(2*NG)/3+14*2**NG+8*NG-100/3) +C PARAMETER (NG=5,MEMLEN=17*2**(2*NG)/3+18*2**NG+10*NG-86/3) + INTEGER mem + DOUBLE PRECISION z + COMMON /memory/ z(MEMLEN),mem + if (mem+len+1.gt.MEMLEN) pause 'insufficient memory in maloc' + z(mem+1)=len + maloc=mem+2 + mem=mem+len+1 + return + END diff --git a/dataassim/math/numrec/f77_sources/matadd.for b/dataassim/math/numrec/f77_sources/matadd.for new file mode 100644 index 0000000..a5b5fc8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/matadd.for @@ -0,0 +1,11 @@ + SUBROUTINE matadd(a,b,c,n) + INTEGER n + DOUBLE PRECISION a(n,n),b(n,n),c(n,n) + INTEGER i,j + do 12 j=1,n + do 11 i=1,n + c(i,j)=a(i,j)+b(i,j) +11 continue +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/matsub.for b/dataassim/math/numrec/f77_sources/matsub.for new file mode 100644 index 0000000..618e934 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/matsub.for @@ -0,0 +1,11 @@ + SUBROUTINE matsub(a,b,c,n) + INTEGER n + DOUBLE PRECISION a(n,n),b(n,n),c(n,n) + INTEGER i,j + do 12 j=1,n + do 11 i=1,n + c(i,j)=a(i,j)-b(i,j) +11 continue +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/medfit.for b/dataassim/math/numrec/f77_sources/medfit.for new file mode 100644 index 0000000..2437e34 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/medfit.for @@ -0,0 +1,67 @@ + SUBROUTINE medfit(x,y,ndata,a,b,abdev) + INTEGER ndata,NMAX,ndatat + PARAMETER (NMAX=1000) + REAL a,abdev,b,x(ndata),y(ndata),arr(NMAX),xt(NMAX),yt(NMAX),aa, + *abdevt + COMMON /arrays/ xt,yt,arr,aa,abdevt,ndatat +CU USES rofunc + INTEGER j + REAL b1,b2,bb,chisq,del,f,f1,f2,sigb,sx,sxx,sxy,sy,rofunc + sx=0. + sy=0. + sxy=0. + sxx=0. + do 11 j=1,ndata + xt(j)=x(j) + yt(j)=y(j) + sx=sx+x(j) + sy=sy+y(j) + sxy=sxy+x(j)*y(j) + sxx=sxx+x(j)**2 +11 continue + ndatat=ndata + del=ndata*sxx-sx**2 + aa=(sxx*sy-sx*sxy)/del + bb=(ndata*sxy-sx*sy)/del + chisq=0. + do 12 j=1,ndata + chisq=chisq+(y(j)-(aa+bb*x(j)))**2 +12 continue + sigb=sqrt(chisq/del) + b1=bb + f1=rofunc(b1) + b2=bb+sign(3.*sigb,f1) + f2=rofunc(b2) + if(b2.eq.b1)then + a=aa + b=bb + abdev=abdevt/ndata + return + endif +1 if(f1*f2.gt.0.)then + bb=b2+1.6*(b2-b1) + b1=b2 + f1=f2 + b2=bb + f2=rofunc(b2) + goto 1 + endif + sigb=0.01*sigb +2 if(abs(b2-b1).gt.sigb)then + bb=b1+0.5*(b2-b1) + if(bb.eq.b1.or.bb.eq.b2)goto 3 + f=rofunc(bb) + if(f*f1.ge.0.)then + f1=f + b1=bb + else + f2=f + b2=bb + endif + goto 2 + endif +3 a=aa + b=bb + abdev=abdevt/ndata + return + END diff --git a/dataassim/math/numrec/f77_sources/memcof.for b/dataassim/math/numrec/f77_sources/memcof.for new file mode 100644 index 0000000..ca0928f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/memcof.for @@ -0,0 +1,41 @@ + SUBROUTINE memcof(data,n,m,xms,d) + INTEGER m,n,MMAX,NMAX + REAL xms,d(m),data(n) + PARAMETER (MMAX=60,NMAX=2000) + INTEGER i,j,k + REAL denom,p,pneum,wk1(NMAX),wk2(NMAX),wkm(MMAX) + if (m.gt.MMAX.or.n.gt.NMAX) pause 'workspace too small in memcof' + p=0. + do 11 j=1,n + p=p+data(j)**2 +11 continue + xms=p/n + wk1(1)=data(1) + wk2(n-1)=data(n) + do 12 j=2,n-1 + wk1(j)=data(j) + wk2(j-1)=data(j) +12 continue + do 17 k=1,m + pneum=0. + denom=0. + do 13 j=1,n-k + pneum=pneum+wk1(j)*wk2(j) + denom=denom+wk1(j)**2+wk2(j)**2 +13 continue + d(k)=2.*pneum/denom + xms=xms*(1.-d(k)**2) + do 14 i=1,k-1 + d(i)=wkm(i)-d(k)*wkm(k-i) +14 continue + if(k.eq.m)return + do 15 i=1,k + wkm(i)=d(i) +15 continue + do 16 j=1,n-k-1 + wk1(j)=wk1(j)-wkm(k)*wk2(j) + wk2(j)=wk2(j+1)-wkm(k)*wk1(j+1) +16 continue +17 continue + pause 'never get here in memcof' + END diff --git a/dataassim/math/numrec/f77_sources/metrop.for b/dataassim/math/numrec/f77_sources/metrop.for new file mode 100644 index 0000000..7148d8e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/metrop.for @@ -0,0 +1,11 @@ + SUBROUTINE metrop(de,t,ans) + REAL de,t + LOGICAL ans +CU USES ran3 + INTEGER jdum + REAL ran3 + SAVE jdum + DATA jdum /1/ + ans=(de.lt.0.0).or.(ran3(jdum).lt.exp(-de/t)) + return + END diff --git a/dataassim/math/numrec/f77_sources/mgfas.for b/dataassim/math/numrec/f77_sources/mgfas.for new file mode 100644 index 0000000..7223ccb --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mgfas.for @@ -0,0 +1,81 @@ + SUBROUTINE mgfas(u,n,maxcyc) + INTEGER maxcyc,n,NPRE,NPOST,NG,MEMLEN + DOUBLE PRECISION u(n,n),ALPHA + PARAMETER (NG=5,MEMLEN=17*2**(2*NG)/3+18*2**NG+10*NG-86/3) + PARAMETER (NPRE=1,NPOST=1,ALPHA=.33d0) +CU USES anorm2,copy,interp,lop,maloc,matadd,matsub,relax2,rstrct,slvsm2 + INTEGER j,jcycle,jj,jm1,jpost,jpre,mem,nf,ngrid,nn,irho(NG), + *irhs(NG),itau(NG),itemp(NG),iu(NG),maloc + DOUBLE PRECISION res,trerr,z,anorm2 + COMMON /memory/ z(MEMLEN),mem + mem=0 + nn=n/2+1 + ngrid=NG-1 + irho(ngrid)=maloc(nn**2) + call rstrct(z(irho(ngrid)),u,nn) +1 if (nn.gt.3) then + nn=nn/2+1 + ngrid=ngrid-1 + irho(ngrid)=maloc(nn**2) + call rstrct(z(irho(ngrid)),z(irho(ngrid+1)),nn) + goto 1 + endif + nn=3 + iu(1)=maloc(nn**2) + irhs(1)=maloc(nn**2) + itau(1)=maloc(nn**2) + itemp(1)=maloc(nn**2) + call slvsm2(z(iu(1)),z(irho(1))) + ngrid=NG + do 16 j=2,ngrid + nn=2*nn-1 + iu(j)=maloc(nn**2) + irhs(j)=maloc(nn**2) + itau(j)=maloc(nn**2) + itemp(j)=maloc(nn**2) + call interp(z(iu(j)),z(iu(j-1)),nn) + if (j.ne.ngrid) then + call copy(z(irhs(j)),z(irho(j)),nn) + else + call copy(z(irhs(j)),u,nn) + endif + do 15 jcycle=1,maxcyc + nf=nn + do 12 jj=j,2,-1 + do 11 jpre=1,NPRE + call relax2(z(iu(jj)),z(irhs(jj)),nf) +11 continue + call lop(z(itemp(jj)),z(iu(jj)),nf) + nf=nf/2+1 + jm1=jj-1 + call rstrct(z(itemp(jm1)),z(itemp(jj)),nf) + call rstrct(z(iu(jm1)),z(iu(jj)),nf) + call lop(z(itau(jm1)),z(iu(jm1)),nf) + call matsub(z(itau(jm1)),z(itemp(jm1)),z(itau(jm1)),nf) + if(jj.eq.j)trerr=ALPHA*anorm2(z(itau(jm1)),nf) + call rstrct(z(irhs(jm1)),z(irhs(jj)),nf) + call matadd(z(irhs(jm1)),z(itau(jm1)),z(irhs(jm1)),nf) +12 continue + call slvsm2(z(iu(1)),z(irhs(1))) + nf=3 + do 14 jj=2,j + jm1=jj-1 + call rstrct(z(itemp(jm1)),z(iu(jj)),nf) + call matsub(z(iu(jm1)),z(itemp(jm1)),z(itemp(jm1)),nf) + nf=2*nf-1 + call interp(z(itau(jj)),z(itemp(jm1)),nf) + call matadd(z(iu(jj)),z(itau(jj)),z(iu(jj)),nf) + do 13 jpost=1,NPOST + call relax2(z(iu(jj)),z(irhs(jj)),nf) +13 continue +14 continue + call lop(z(itemp(j)),z(iu(j)),nf) + call matsub(z(itemp(j)),z(irhs(j)),z(itemp(j)),nf) + res=anorm2(z(itemp(j)),nf) + if(res.lt.trerr)goto 2 +15 continue +2 continue +16 continue + call copy(u,z(iu(ngrid)),n) + return + END diff --git a/dataassim/math/numrec/f77_sources/mglin.for b/dataassim/math/numrec/f77_sources/mglin.for new file mode 100644 index 0000000..4283e84 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mglin.for @@ -0,0 +1,63 @@ + SUBROUTINE mglin(u,n,ncycle) + INTEGER n,ncycle,NPRE,NPOST,NG,MEMLEN + DOUBLE PRECISION u(n,n) + PARAMETER (NG=5,MEMLEN=13*2**(2*NG)/3+14*2**NG+8*NG-100/3) + PARAMETER (NPRE=1,NPOST=1) +CU USES addint,copy,fill0,interp,maloc,relax,resid,rstrct,slvsml + INTEGER j,jcycle,jj,jpost,jpre,mem,nf,ngrid,nn,ires(NG),irho(NG), + *irhs(NG),iu(NG),maloc + DOUBLE PRECISION z + COMMON /memory/ z(MEMLEN),mem + mem=0 + nn=n/2+1 + ngrid=NG-1 + irho(ngrid)=maloc(nn**2) + call rstrct(z(irho(ngrid)),u,nn) +1 if (nn.gt.3) then + nn=nn/2+1 + ngrid=ngrid-1 + irho(ngrid)=maloc(nn**2) + call rstrct(z(irho(ngrid)),z(irho(ngrid+1)),nn) + goto 1 + endif + nn=3 + iu(1)=maloc(nn**2) + irhs(1)=maloc(nn**2) + call slvsml(z(iu(1)),z(irho(1))) + ngrid=NG + do 16 j=2,ngrid + nn=2*nn-1 + iu(j)=maloc(nn**2) + irhs(j)=maloc(nn**2) + ires(j)=maloc(nn**2) + call interp(z(iu(j)),z(iu(j-1)),nn) + if (j.ne.ngrid) then + call copy(z(irhs(j)),z(irho(j)),nn) + else + call copy(z(irhs(j)),u,nn) + endif + do 15 jcycle=1,ncycle + nf=nn + do 12 jj=j,2,-1 + do 11 jpre=1,NPRE + call relax(z(iu(jj)),z(irhs(jj)),nf) +11 continue + call resid(z(ires(jj)),z(iu(jj)),z(irhs(jj)),nf) + nf=nf/2+1 + call rstrct(z(irhs(jj-1)),z(ires(jj)),nf) + call fill0(z(iu(jj-1)),nf) +12 continue + call slvsml(z(iu(1)),z(irhs(1))) + nf=3 + do 14 jj=2,j + nf=2*nf-1 + call addint(z(iu(jj)),z(iu(jj-1)),z(ires(jj)),nf) + do 13 jpost=1,NPOST + call relax(z(iu(jj)),z(irhs(jj)),nf) +13 continue +14 continue +15 continue +16 continue + call copy(u,z(iu(ngrid)),n) + return + END diff --git a/dataassim/math/numrec/f77_sources/midexp.for b/dataassim/math/numrec/f77_sources/midexp.for new file mode 100644 index 0000000..ed8e15e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/midexp.for @@ -0,0 +1,28 @@ + SUBROUTINE midexp(funk,aa,bb,s,n) + INTEGER n + REAL aa,bb,s,funk + EXTERNAL funk + INTEGER it,j + REAL ddel,del,sum,tnm,x,func,a,b + func(x)=funk(-log(x))/x + b=exp(-aa) + a=0. + if (n.eq.1) then + s=(b-a)*func(0.5*(a+b)) + else + it=3**(n-2) + tnm=it + del=(b-a)/(3.*tnm) + ddel=del+del + x=a+0.5*del + sum=0. + do 11 j=1,it + sum=sum+func(x) + x=x+ddel + sum=sum+func(x) + x=x+del +11 continue + s=(s+(b-a)*sum/tnm)/3. + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/midinf.for b/dataassim/math/numrec/f77_sources/midinf.for new file mode 100644 index 0000000..fc89d2e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/midinf.for @@ -0,0 +1,28 @@ + SUBROUTINE midinf(funk,aa,bb,s,n) + INTEGER n + REAL aa,bb,s,funk + EXTERNAL funk + INTEGER it,j + REAL a,b,ddel,del,sum,tnm,func,x + func(x)=funk(1./x)/x**2 + b=1./aa + a=1./bb + if (n.eq.1) then + s=(b-a)*func(0.5*(a+b)) + else + it=3**(n-2) + tnm=it + del=(b-a)/(3.*tnm) + ddel=del+del + x=a+0.5*del + sum=0. + do 11 j=1,it + sum=sum+func(x) + x=x+ddel + sum=sum+func(x) + x=x+del +11 continue + s=(s+(b-a)*sum/tnm)/3. + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/midpnt.for b/dataassim/math/numrec/f77_sources/midpnt.for new file mode 100644 index 0000000..b9dd62d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/midpnt.for @@ -0,0 +1,25 @@ + SUBROUTINE midpnt(func,a,b,s,n) + INTEGER n + REAL a,b,s,func + EXTERNAL func + INTEGER it,j + REAL ddel,del,sum,tnm,x + if (n.eq.1) then + s=(b-a)*func(0.5*(a+b)) + else + it=3**(n-2) + tnm=it + del=(b-a)/(3.*tnm) + ddel=del+del + x=a+0.5*del + sum=0. + do 11 j=1,it + sum=sum+func(x) + x=x+ddel + sum=sum+func(x) + x=x+del +11 continue + s=(s+(b-a)*sum/tnm)/3. + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/midsql.for b/dataassim/math/numrec/f77_sources/midsql.for new file mode 100644 index 0000000..9326dce --- /dev/null +++ b/dataassim/math/numrec/f77_sources/midsql.for @@ -0,0 +1,28 @@ + SUBROUTINE midsql(funk,aa,bb,s,n) + INTEGER n + REAL aa,bb,s,funk + EXTERNAL funk + INTEGER it,j + REAL ddel,del,sum,tnm,x,func,a,b + func(x)=2.*x*funk(aa+x**2) + b=sqrt(bb-aa) + a=0. + if (n.eq.1) then + s=(b-a)*func(0.5*(a+b)) + else + it=3**(n-2) + tnm=it + del=(b-a)/(3.*tnm) + ddel=del+del + x=a+0.5*del + sum=0. + do 11 j=1,it + sum=sum+func(x) + x=x+ddel + sum=sum+func(x) + x=x+del +11 continue + s=(s+(b-a)*sum/tnm)/3. + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/midsqu.for b/dataassim/math/numrec/f77_sources/midsqu.for new file mode 100644 index 0000000..93881aa --- /dev/null +++ b/dataassim/math/numrec/f77_sources/midsqu.for @@ -0,0 +1,28 @@ + SUBROUTINE midsqu(funk,aa,bb,s,n) + INTEGER n + REAL aa,bb,s,funk + EXTERNAL funk + INTEGER it,j + REAL ddel,del,sum,tnm,x,func,a,b + func(x)=2.*x*funk(bb-x**2) + b=sqrt(bb-aa) + a=0. + if (n.eq.1) then + s=(b-a)*func(0.5*(a+b)) + else + it=3**(n-2) + tnm=it + del=(b-a)/(3.*tnm) + ddel=del+del + x=a+0.5*del + sum=0. + do 11 j=1,it + sum=sum+func(x) + x=x+ddel + sum=sum+func(x) + x=x+del +11 continue + s=(s+(b-a)*sum/tnm)/3. + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/miser.for b/dataassim/math/numrec/f77_sources/miser.for new file mode 100644 index 0000000..feaf6ca --- /dev/null +++ b/dataassim/math/numrec/f77_sources/miser.for @@ -0,0 +1,115 @@ + SUBROUTINE miser(func,region,ndim,npts,dith,ave,var) + INTEGER ndim,npts,MNPT,MNBS,MAXD,NSTACK + REAL ave,dith,var,region(2*ndim),func,TINY,BIG,PFAC + PARAMETER (MNPT=15,MNBS=4*MNPT,MAXD=10,TINY=1.e-30,BIG=1.e30, + *NSTACK=1000,PFAC=0.1) + EXTERNAL func +CU USES func,ranpt + INTEGER iran,j,jb,jstack,n,naddr,np,npre,nptl,nptr,nptt + REAL avel,fracl,fval,rgl,rgm,rgr,s,sigl,siglb,sigr,sigrb,sum,sumb, + *summ,summ2,varl,fmaxl(10),fmaxr(10),fminl(10),fminr(10),pt(10), + *rmid(10),stack(NSTACK),stf(9) + EQUIVALENCE (stf(1),avel),(stf(2),varl),(stf(3),jb),(stf(4),nptr), + *(stf(5),naddr),(stf(6),rgl),(stf(7),rgm),(stf(8),rgr),(stf(9), + *fracl) + SAVE iran + DATA iran /0/ + jstack=0 + nptt=npts +1 continue + if (nptt.lt.MNBS) then + np=abs(nptt) + summ=0. + summ2=0. + do 11 n=1,np + call ranpt(pt,region,ndim) + fval=func(pt) + summ=summ+fval + summ2=summ2+fval**2 +11 continue + ave=summ/np + var=max(TINY,(summ2-summ**2/np)/np**2) + else + npre=max(int(nptt*PFAC),MNPT) + do 12 j=1,ndim + iran=mod(iran*2661+36979,175000) + s=sign(dith,float(iran-87500)) + rmid(j)=(0.5+s)*region(j)+(0.5-s)*region(j+ndim) + fminl(j)=BIG + fminr(j)=BIG + fmaxl(j)=-BIG + fmaxr(j)=-BIG +12 continue + do 14 n=1,npre + call ranpt(pt,region,ndim) + fval=func(pt) + do 13 j=1,ndim + if(pt(j).le.rmid(j))then + fminl(j)=min(fminl(j),fval) + fmaxl(j)=max(fmaxl(j),fval) + else + fminr(j)=min(fminr(j),fval) + fmaxr(j)=max(fmaxr(j),fval) + endif +13 continue +14 continue + sumb=BIG + jb=0 + siglb=1. + sigrb=1. + do 15 j=1,ndim + if(fmaxl(j).gt.fminl(j).and.fmaxr(j).gt.fminr(j))then + sigl=max(TINY,(fmaxl(j)-fminl(j))**(2./3.)) + sigr=max(TINY,(fmaxr(j)-fminr(j))**(2./3.)) + sum=sigl+sigr + if (sum.le.sumb) then + sumb=sum + jb=j + siglb=sigl + sigrb=sigr + endif + endif +15 continue + if (jb.eq.0) jb=1+(ndim*iran)/175000 + rgl=region(jb) + rgm=rmid(jb) + rgr=region(jb+ndim) + fracl=abs((rgm-rgl)/(rgr-rgl)) + nptl=MNPT+(nptt-npre-2*MNPT)*fracl*siglb/(fracl*siglb+ + *(1.-fracl)*sigrb) + nptr=nptt-npre-nptl + region(jb+ndim)=rgm + naddr=1 + do 16 j=1,9 + stack(jstack+j)=stf(j) +16 continue + jstack=jstack+9 + nptt=nptl + goto 1 +10 continue + avel=ave + varl=var + region(jb)=rgm + region(jb+ndim)=rgr + naddr=2 + do 17 j=1,9 + stack(jstack+j)=stf(j) +17 continue + jstack=jstack+9 + nptt=nptr + goto 1 +20 continue + region(jb)=rgl + ave=fracl*avel+(1.-fracl)*ave + var=fracl**2*varl+(1.-fracl)**2*var + endif + if (jstack.ne.0) then + jstack=jstack-9 + do 18 j=1,9 + stf(j)=stack(jstack+j) +18 continue + goto (10,20),naddr + pause 'miser: never get here' + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/mmid.for b/dataassim/math/numrec/f77_sources/mmid.for new file mode 100644 index 0000000..98db75a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mmid.for @@ -0,0 +1,29 @@ + SUBROUTINE mmid(y,dydx,nvar,xs,htot,nstep,yout,derivs) + INTEGER nstep,nvar,NMAX + REAL htot,xs,dydx(nvar),y(nvar),yout(nvar) + EXTERNAL derivs + PARAMETER (NMAX=50) + INTEGER i,n + REAL h,h2,swap,x,ym(NMAX),yn(NMAX) + h=htot/nstep + do 11 i=1,nvar + ym(i)=y(i) + yn(i)=y(i)+h*dydx(i) +11 continue + x=xs+h + call derivs(x,yn,yout) + h2=2.*h + do 13 n=2,nstep + do 12 i=1,nvar + swap=ym(i)+h2*yout(i) + ym(i)=yn(i) + yn(i)=swap +12 continue + x=x+h + call derivs(x,yn,yout) +13 continue + do 14 i=1,nvar + yout(i)=0.5*(ym(i)+yn(i)+h*yout(i)) +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/mnbrak.for b/dataassim/math/numrec/f77_sources/mnbrak.for new file mode 100644 index 0000000..42cf45f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mnbrak.for @@ -0,0 +1,64 @@ + SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func) + REAL ax,bx,cx,fa,fb,fc,func,GOLD,GLIMIT,TINY + EXTERNAL func + PARAMETER (GOLD=1.618034, GLIMIT=100., TINY=1.e-20) + REAL dum,fu,q,r,u,ulim + fa=func(ax) + fb=func(bx) + if(fb.gt.fa)then + dum=ax + ax=bx + bx=dum + dum=fb + fb=fa + fa=dum + endif + cx=bx+GOLD*(bx-ax) + fc=func(cx) +1 if(fb.ge.fc)then + r=(bx-ax)*(fb-fc) + q=(bx-cx)*(fb-fa) + u=bx-((bx-cx)*q-(bx-ax)*r)/(2.*sign(max(abs(q-r),TINY),q-r)) + ulim=bx+GLIMIT*(cx-bx) + if((bx-u)*(u-cx).gt.0.)then + fu=func(u) + if(fu.lt.fc)then + ax=bx + fa=fb + bx=u + fb=fu + return + else if(fu.gt.fb)then + cx=u + fc=fu + return + endif + u=cx+GOLD*(cx-bx) + fu=func(u) + else if((cx-u)*(u-ulim).gt.0.)then + fu=func(u) + if(fu.lt.fc)then + bx=cx + cx=u + u=cx+GOLD*(cx-bx) + fb=fc + fc=fu + fu=func(u) + endif + else if((u-ulim)*(ulim-cx).ge.0.)then + u=ulim + fu=func(u) + else + u=cx+GOLD*(cx-bx) + fu=func(u) + endif + ax=bx + bx=cx + cx=u + fa=fb + fb=fc + fc=fu + goto 1 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/mnewt.for b/dataassim/math/numrec/f77_sources/mnewt.for new file mode 100644 index 0000000..1eb2ce3 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mnewt.for @@ -0,0 +1,28 @@ + SUBROUTINE mnewt(ntrial,x,n,tolx,tolf) + INTEGER n,ntrial,NP + REAL tolf,tolx,x(n) + PARAMETER (NP=15) +CU USES lubksb,ludcmp,usrfun + INTEGER i,k,indx(NP) + REAL d,errf,errx,fjac(NP,NP),fvec(NP),p(NP) + do 14 k=1,ntrial + call usrfun(x,n,NP,fvec,fjac) + errf=0. + do 11 i=1,n + errf=errf+abs(fvec(i)) +11 continue + if(errf.le.tolf)return + do 12 i=1,n + p(i)=-fvec(i) +12 continue + call ludcmp(fjac,n,NP,indx,d) + call lubksb(fjac,n,NP,indx,p) + errx=0. + do 13 i=1,n + errx=errx+abs(p(i)) + x(i)=x(i)+p(i) +13 continue + if(errx.le.tolx)return +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/moment.for b/dataassim/math/numrec/f77_sources/moment.for new file mode 100644 index 0000000..eef2308 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/moment.for @@ -0,0 +1,38 @@ + SUBROUTINE moment(data,n,ave,adev,sdev,var,skew,curt) + INTEGER n + REAL adev,ave,curt,sdev,skew,var,data(n) + INTEGER j + REAL p,s,ep + if(n.le.1)pause 'n must be at least 2 in moment' + s=0. + do 11 j=1,n + s=s+data(j) +11 continue + ave=s/n + adev=0. + var=0. + skew=0. + curt=0. + ep=0. + do 12 j=1,n + s=data(j)-ave + ep=ep+s + adev=adev+abs(s) + p=s*s + var=var+p + p=p*s + skew=skew+p + p=p*s + curt=curt+p +12 continue + adev=adev/n + var=(var-ep**2/n)/(n-1) + sdev=sqrt(var) + if(var.ne.0.)then + skew=skew/(n*sdev**3) + curt=curt/(n*var**2)-3. + else + pause 'no skew or kurtosis when zero variance in moment' + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/mp2dfr.for b/dataassim/math/numrec/f77_sources/mp2dfr.for new file mode 100644 index 0000000..25a0465 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mp2dfr.for @@ -0,0 +1,14 @@ + SUBROUTINE mp2dfr(a,s,n,m) + INTEGER m,n,IAZ + CHARACTER*1 a(*),s(*) + PARAMETER (IAZ=48) +CU USES mplsh,mpsmu + INTEGER j + m=2.408*n + do 11 j=1,m + call mpsmu(a,a,n,10) + s(j)=char(ichar(a(1))+IAZ) + call mplsh(a,n) +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/mpdiv.for b/dataassim/math/numrec/f77_sources/mpdiv.for new file mode 100644 index 0000000..efa57cb --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mpdiv.for @@ -0,0 +1,17 @@ + SUBROUTINE mpdiv(q,r,u,v,n,m) + INTEGER m,n,NMAX,MACC + CHARACTER*1 q(n-m+1),r(m),u(n),v(m) + PARAMETER (NMAX=8192,MACC=3) +CU USES mpinv,mpmov,mpmul,mpsub + INTEGER is + CHARACTER*1 rr(2*NMAX),s(NMAX) + if(n+MACC.gt.NMAX)pause 'NMAX too small in mpdiv' + call mpinv(s,v,n-m+MACC,m) + call mpmul(rr,s,u,n-m+MACC,n) + call mpmov(q,rr(2),n-m+1) + call mpmul(rr,q,v,n-m+1,m) + call mpsub(is,rr(2),u,rr(2),n) + if (is.ne.0) pause 'MACC too small in mpdiv' + call mpmov(r,rr(n-m+2),m) + return + END diff --git a/dataassim/math/numrec/f77_sources/mpinv.for b/dataassim/math/numrec/f77_sources/mpinv.for new file mode 100644 index 0000000..5d322a7 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mpinv.for @@ -0,0 +1,34 @@ + SUBROUTINE mpinv(u,v,n,m) + INTEGER m,n,MF,NMAX + CHARACTER*1 u(n),v(m) + REAL BI + PARAMETER (MF=4,BI=1./256.,NMAX=8192) +CU USES mpmov,mpmul,mpneg + INTEGER i,j,mm + REAL fu,fv + CHARACTER*1 rr(2*NMAX+1),s(NMAX) + if(max(n,m).gt.NMAX)pause 'NMAX too small in mpinv' + mm=min(MF,m) + fv=ichar(v(mm)) + do 11 j=mm-1,1,-1 + fv=fv*BI+ichar(v(j)) +11 continue + fu=1./fv + do 12 j=1,n + i=int(fu) + u(j)=char(i) + fu=256.*(fu-i) +12 continue +1 continue + call mpmul(rr,u,v,n,m) + call mpmov(s,rr(2),n) + call mpneg(s,n) + s(1)=char(ichar(s(1))-254) + call mpmul(rr,s,u,n,n) + call mpmov(u,rr(2),n) + do 13 j=2,n-1 + if(ichar(s(j)).ne.0)goto 1 +13 continue + continue + return + END diff --git a/dataassim/math/numrec/f77_sources/mpmul.for b/dataassim/math/numrec/f77_sources/mpmul.for new file mode 100644 index 0000000..1010346 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mpmul.for @@ -0,0 +1,51 @@ + SUBROUTINE mpmul(w,u,v,n,m) + INTEGER m,n,NMAX + CHARACTER*1 w(n+m),u(n),v(m) + DOUBLE PRECISION RX + PARAMETER (NMAX=8192,RX=256.D0) +CU USES drealft + INTEGER j,mn,nn + DOUBLE PRECISION cy,t,a(NMAX),b(NMAX) + mn=max(m,n) + nn=1 +1 if(nn.lt.mn) then + nn=nn+nn + goto 1 + endif + nn=nn+nn + if(nn.gt.NMAX)pause 'NMAX too small in fftmul' + do 11 j=1,n + a(j)=ichar(u(j)) +11 continue + do 12 j=n+1,nn + a(j)=0.D0 +12 continue + do 13 j=1,m + b(j)=ichar(v(j)) +13 continue + do 14 j=m+1,nn + b(j)=0.D0 +14 continue + call drealft(a,nn,1) + call drealft(b,nn,1) + b(1)=b(1)*a(1) + b(2)=b(2)*a(2) + do 15 j=3,nn,2 + t=b(j) + b(j)=t*a(j)-b(j+1)*a(j+1) + b(j+1)=t*a(j+1)+b(j+1)*a(j) +15 continue + call drealft(b,nn,-1) + cy=0. + do 16 j=nn,1,-1 + t=b(j)/(nn/2)+cy+0.5D0 + b(j)=mod(t,RX) + cy=int(t/RX) +16 continue + if (cy.ge.RX) pause 'cannot happen in fftmul' + w(1)=char(int(cy)) + do 17 j=2,n+m + w(j)=char(int(b(j-1))) +17 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/mpops.for b/dataassim/math/numrec/f77_sources/mpops.for new file mode 100644 index 0000000..1de2703 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mpops.for @@ -0,0 +1,71 @@ + SUBROUTINE mpops(w,u,v) + CHARACTER*1 w(*),u(*),v(*) + INTEGER i,ireg,j,n,ir,is,iv,ii1,ii2 + CHARACTER*1 creg(4) + SAVE ii1,ii2 + EQUIVALENCE (ireg,creg) + ENTRY mpinit + ireg=256*ichar('2')+ichar('1') + do 11 j=1,4 + if (creg(j).eq.'1') ii1=j + if (creg(j).eq.'2') ii2=j +11 continue + return + ENTRY mpadd(w,u,v,n) + ireg=0 + do 12 j=n,1,-1 + ireg=ichar(u(j))+ichar(v(j))+ichar(creg(ii2)) + w(j+1)=creg(ii1) +12 continue + w(1)=creg(ii2) + return + ENTRY mpsub(is,w,u,v,n) + ireg=256 + do 13 j=n,1,-1 + ireg=255+ichar(u(j))-ichar(v(j))+ichar(creg(ii2)) + w(j)=creg(ii1) +13 continue + is=ichar(creg(ii2))-1 + return + ENTRY mpsad(w,u,n,iv) + ireg=256*iv + do 14 j=n,1,-1 + ireg=ichar(u(j))+ichar(creg(ii2)) + w(j+1)=creg(ii1) +14 continue + w(1)=creg(ii2) + return + ENTRY mpsmu(w,u,n,iv) + ireg=0 + do 15 j=n,1,-1 + ireg=ichar(u(j))*iv+ichar(creg(ii2)) + w(j+1)=creg(ii1) +15 continue + w(1)=creg(ii2) + return + ENTRY mpsdv(w,u,n,iv,ir) + ir=0 + do 16 j=1,n + i=256*ir+ichar(u(j)) + w(j)=char(i/iv) + ir=mod(i,iv) +16 continue + return + ENTRY mpneg(u,n) + ireg=256 + do 17 j=n,1,-1 + ireg=255-ichar(u(j))+ichar(creg(ii2)) + u(j)=creg(ii1) +17 continue + return + ENTRY mpmov(u,v,n) + do 18 j=1,n + u(j)=v(j) +18 continue + return + ENTRY mplsh(u,n) + do 19 j=1,n + u(j)=u(j+1) +19 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/mppi.for b/dataassim/math/numrec/f77_sources/mppi.for new file mode 100644 index 0000000..f368b1a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mppi.for @@ -0,0 +1,46 @@ + SUBROUTINE mppi(n) + INTEGER n,IAOFF,NMAX + PARAMETER (IAOFF=48,NMAX=8192) +CU USES mpinit,mp2dfr,mpadd,mpinv,mplsh,mpmov,mpmul,mpsdv,mpsqrt + INTEGER ir,j,m + CHARACTER*1 x(NMAX),y(NMAX),sx(NMAX),sxi(NMAX),t(NMAX),s(3*NMAX), + *pi(NMAX) + call mpinit + t(1)=char(2) + do 11 j=2,n + t(j)=char(0) +11 continue + call mpsqrt(x,x,t,n,n) + call mpadd(pi,t,x,n) + call mplsh(pi,n) + call mpsqrt(sx,sxi,x,n,n) + call mpmov(y,sx,n) +1 continue + call mpadd(x,sx,sxi,n) + call mpsdv(x,x(2),n,2,ir) + call mpsqrt(sx,sxi,x,n,n) + call mpmul(t,y,sx,n,n) + call mpadd(t(2),t(2),sxi,n) + x(1)=char(ichar(x(1))+1) + y(1)=char(ichar(y(1))+1) + call mpinv(s,y,n,n) + call mpmul(y,t(3),s,n,n) + call mplsh(y,n) + call mpmul(t,x,s,n,n) + continue + m=mod(255+ichar(t(2)),256) + do 12 j=3,n + if(ichar(t(j)).ne.m)goto 2 +12 continue + if (abs(ichar(t(n+1))-m).gt.1)goto 2 + write (*,*) 'pi=' + s(1)=char(ichar(pi(1))+IAOFF) + s(2)='.' + call mp2dfr(pi(2),s(3),n-1,m) + write (*,'(1x,64a1)') (s(j),j=1,m+1) + return +2 continue + call mpmul(s,pi,t(2),n,n) + call mpmov(pi,s(2),n) + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/mprove.for b/dataassim/math/numrec/f77_sources/mprove.for new file mode 100644 index 0000000..1d34993 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mprove.for @@ -0,0 +1,21 @@ + SUBROUTINE mprove(a,alud,n,np,indx,b,x) + INTEGER n,np,indx(n),NMAX + REAL a(np,np),alud(np,np),b(n),x(n) + PARAMETER (NMAX=500) +CU USES lubksb + INTEGER i,j + REAL r(NMAX) + DOUBLE PRECISION sdp + do 12 i=1,n + sdp=-b(i) + do 11 j=1,n + sdp=sdp+dble(a(i,j))*dble(x(j)) +11 continue + r(i)=sdp +12 continue + call lubksb(alud,n,np,indx,r) + do 13 i=1,n + x(i)=x(i)-r(i) +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/mpsqrt.for b/dataassim/math/numrec/f77_sources/mpsqrt.for new file mode 100644 index 0000000..59d65bc --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mpsqrt.for @@ -0,0 +1,40 @@ + SUBROUTINE mpsqrt(w,u,v,n,m) + INTEGER m,n,NMAX,MF + CHARACTER*1 w(*),u(*),v(*) + REAL BI + PARAMETER (NMAX=2048,MF=3,BI=1./256.) +CU USES mplsh,mpmov,mpmul,mpneg,mpsdv + INTEGER i,ir,j,mm + REAL fu,fv + CHARACTER*1 r(NMAX),s(NMAX) + if(2*n+1.gt.NMAX)pause 'NMAX too small in mpsqrt' + mm=min(m,MF) + fv=ichar(v(mm)) + do 11 j=mm-1,1,-1 + fv=BI*fv+ichar(v(j)) +11 continue + fu=1./sqrt(fv) + do 12 j=1,n + i=int(fu) + u(j)=char(i) + fu=256.*(fu-i) +12 continue +1 continue + call mpmul(r,u,u,n,n) + call mplsh(r,n) + call mpmul(s,r,v,n,m) + call mplsh(s,n) + call mpneg(s,n) + s(1)=char(ichar(s(1))-253) + call mpsdv(s,s,n,2,ir) + do 13 j=2,n-1 + if(ichar(s(j)).ne.0)goto 2 +13 continue + call mpmul(r,u,v,n,m) + call mpmov(w,r(2),n) + return +2 continue + call mpmul(r,s,u,n,n) + call mpmov(u,r(2),n) + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/mrqcof.for b/dataassim/math/numrec/f77_sources/mrqcof.for new file mode 100644 index 0000000..94c07a1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mrqcof.for @@ -0,0 +1,48 @@ + SUBROUTINE mrqcof(x,y,sig,ndata,a,ia,ma,alpha,beta,nalp,chisq, + *funcs) + INTEGER ma,nalp,ndata,ia(ma),MMAX + REAL chisq,a(ma),alpha(nalp,nalp),beta(ma),sig(ndata),x(ndata), + *y(ndata) + EXTERNAL funcs + PARAMETER (MMAX=20) + INTEGER mfit,i,j,k,l,m + REAL dy,sig2i,wt,ymod,dyda(MMAX) + mfit=0 + do 11 j=1,ma + if (ia(j).ne.0) mfit=mfit+1 +11 continue + do 13 j=1,mfit + do 12 k=1,j + alpha(j,k)=0. +12 continue + beta(j)=0. +13 continue + chisq=0. + do 16 i=1,ndata + call funcs(x(i),a,ymod,dyda,ma) + sig2i=1./(sig(i)*sig(i)) + dy=y(i)-ymod + j=0 + do 15 l=1,ma + if(ia(l).ne.0) then + j=j+1 + wt=dyda(l)*sig2i + k=0 + do 14 m=1,l + if(ia(m).ne.0) then + k=k+1 + alpha(j,k)=alpha(j,k)+wt*dyda(m) + endif +14 continue + beta(j)=beta(j)+dy*wt + endif +15 continue + chisq=chisq+dy*dy*sig2i +16 continue + do 18 j=2,mfit + do 17 k=1,j-1 + alpha(k,j)=alpha(j,k) +17 continue +18 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/mrqmin.for b/dataassim/math/numrec/f77_sources/mrqmin.for new file mode 100644 index 0000000..cafcf95 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/mrqmin.for @@ -0,0 +1,60 @@ + SUBROUTINE mrqmin(x,y,sig,ndata,a,ia,ma,covar,alpha,nca,chisq, + *funcs,alamda) + INTEGER ma,nca,ndata,ia(ma),MMAX + REAL alamda,chisq,funcs,a(ma),alpha(nca,nca),covar(nca,nca), + *sig(ndata),x(ndata),y(ndata) + PARAMETER (MMAX=20) +CU USES covsrt,gaussj,mrqcof + INTEGER j,k,l,mfit + REAL ochisq,atry(MMAX),beta(MMAX),da(MMAX) + SAVE ochisq,atry,beta,da,mfit + if(alamda.lt.0.)then + mfit=0 + do 11 j=1,ma + if (ia(j).ne.0) mfit=mfit+1 +11 continue + alamda=0.001 + call mrqcof(x,y,sig,ndata,a,ia,ma,alpha,beta,nca,chisq,funcs) + ochisq=chisq + do 12 j=1,ma + atry(j)=a(j) +12 continue + endif + do 14 j=1,mfit + do 13 k=1,mfit + covar(j,k)=alpha(j,k) +13 continue + covar(j,j)=alpha(j,j)*(1.+alamda) + da(j)=beta(j) +14 continue + call gaussj(covar,mfit,nca,da,1,1) + if(alamda.eq.0.)then + call covsrt(covar,nca,ma,ia,mfit) + return + endif + j=0 + do 15 l=1,ma + if(ia(l).ne.0) then + j=j+1 + atry(l)=a(l)+da(j) + endif +15 continue + call mrqcof(x,y,sig,ndata,atry,ia,ma,covar,da,nca,chisq,funcs) + if(chisq.lt.ochisq)then + alamda=0.1*alamda + ochisq=chisq + do 17 j=1,mfit + do 16 k=1,mfit + alpha(j,k)=covar(j,k) +16 continue + beta(j)=da(j) +17 continue + do 18 l=1,ma + a(l)=atry(l) +18 continue + else + alamda=10.*alamda + chisq=ochisq + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/newt.for b/dataassim/math/numrec/f77_sources/newt.for new file mode 100644 index 0000000..1f703da --- /dev/null +++ b/dataassim/math/numrec/f77_sources/newt.for @@ -0,0 +1,78 @@ + SUBROUTINE newt(x,n,check) + INTEGER n,nn,NP,MAXITS + LOGICAL check + REAL x(n),fvec,TOLF,TOLMIN,TOLX,STPMX + PARAMETER (NP=40,MAXITS=200,TOLF=1.e-4,TOLMIN=1.e-6,TOLX=1.e-7, + *STPMX=100.) + COMMON /newtv/ fvec(NP),nn + SAVE /newtv/ +CU USES fdjac,fmin,lnsrch,lubksb,ludcmp + INTEGER i,its,j,indx(NP) + REAL d,den,f,fold,stpmax,sum,temp,test,fjac(NP,NP),g(NP),p(NP), + *xold(NP),fmin + EXTERNAL fmin + nn=n + f=fmin(x) + test=0. + do 11 i=1,n + if(abs(fvec(i)).gt.test)test=abs(fvec(i)) +11 continue + if(test.lt..01*TOLF)then + check=.false. + return + endif + sum=0. + do 12 i=1,n + sum=sum+x(i)**2 +12 continue + stpmax=STPMX*max(sqrt(sum),float(n)) + do 21 its=1,MAXITS + call fdjac(n,x,fvec,NP,fjac) + do 14 i=1,n + sum=0. + do 13 j=1,n + sum=sum+fjac(j,i)*fvec(j) +13 continue + g(i)=sum +14 continue + do 15 i=1,n + xold(i)=x(i) +15 continue + fold=f + do 16 i=1,n + p(i)=-fvec(i) +16 continue + call ludcmp(fjac,n,NP,indx,d) + call lubksb(fjac,n,NP,indx,p) + call lnsrch(n,xold,fold,g,p,x,f,stpmax,check,fmin) + test=0. + do 17 i=1,n + if(abs(fvec(i)).gt.test)test=abs(fvec(i)) +17 continue + if(test.lt.TOLF)then + check=.false. + return + endif + if(check)then + test=0. + den=max(f,.5*n) + do 18 i=1,n + temp=abs(g(i))*max(abs(x(i)),1.)/den + if(temp.gt.test)test=temp +18 continue + if(test.lt.TOLMIN)then + check=.true. + else + check=.false. + endif + return + endif + test=0. + do 19 i=1,n + temp=(abs(x(i)-xold(i)))/max(abs(x(i)),1.) + if(temp.gt.test)test=temp +19 continue + if(test.lt.TOLX)return +21 continue + pause 'MAXITS exceeded in newt' + END diff --git a/dataassim/math/numrec/f77_sources/odeint.for b/dataassim/math/numrec/f77_sources/odeint.for new file mode 100644 index 0000000..76d9182 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/odeint.for @@ -0,0 +1,63 @@ + SUBROUTINE odeint(ystart,nvar,x1,x2,eps,h1,hmin,nok,nbad,derivs, + *rkqs) + INTEGER nbad,nok,nvar,KMAXX,MAXSTP,NMAX + REAL eps,h1,hmin,x1,x2,ystart(nvar),TINY + EXTERNAL derivs,rkqs + PARAMETER (MAXSTP=10000,NMAX=50,KMAXX=200,TINY=1.e-30) + INTEGER i,kmax,kount,nstp + REAL dxsav,h,hdid,hnext,x,xsav,dydx(NMAX),xp(KMAXX),y(NMAX), + *yp(NMAX,KMAXX),yscal(NMAX) + COMMON /path/ kmax,kount,dxsav,xp,yp + x=x1 + h=sign(h1,x2-x1) + nok=0 + nbad=0 + kount=0 + do 11 i=1,nvar + y(i)=ystart(i) +11 continue + if (kmax.gt.0) xsav=x-2.*dxsav + do 16 nstp=1,MAXSTP + call derivs(x,y,dydx) + do 12 i=1,nvar + yscal(i)=abs(y(i))+abs(h*dydx(i))+TINY +12 continue + if(kmax.gt.0)then + if(abs(x-xsav).gt.abs(dxsav)) then + if(kount.lt.kmax-1)then + kount=kount+1 + xp(kount)=x + do 13 i=1,nvar + yp(i,kount)=y(i) +13 continue + xsav=x + endif + endif + endif + if((x+h-x2)*(x+h-x1).gt.0.) h=x2-x + call rkqs(y,dydx,nvar,x,h,eps,yscal,hdid,hnext,derivs) + if(hdid.eq.h)then + nok=nok+1 + else + nbad=nbad+1 + endif + if((x-x2)*(x2-x1).ge.0.)then + do 14 i=1,nvar + ystart(i)=y(i) +14 continue + if(kmax.ne.0)then + kount=kount+1 + xp(kount)=x + do 15 i=1,nvar + yp(i,kount)=y(i) +15 continue + endif + return + endif + if(abs(hnext).lt.hmin) pause + *'stepsize smaller than minimum in odeint' + h=hnext +16 continue + pause 'too many steps in odeint' + return + END diff --git a/dataassim/math/numrec/f77_sources/orthog.for b/dataassim/math/numrec/f77_sources/orthog.for new file mode 100644 index 0000000..4c44ce8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/orthog.for @@ -0,0 +1,24 @@ + SUBROUTINE orthog(n,anu,alpha,beta,a,b) + INTEGER n,NMAX + REAL a(n),alpha(2*n-1),anu(2*n),b(n),beta(2*n-1) + PARAMETER (NMAX=64) + INTEGER k,l + REAL sig(2*NMAX+1,2*NMAX+1) + do 11 l=3,2*n + sig(1,l)=0. +11 continue + do 12 l=2,2*n+1 + sig(2,l)=anu(l-1) +12 continue + a(1)=alpha(1)+anu(2)/anu(1) + b(1)=0. + do 14 k=3,n+1 + do 13 l=k,2*n-k+3 + sig(k,l)=sig(k-1,l+1)+(alpha(l-1)-a(k-2))*sig(k-1,l)-b(k-2)* + *sig(k-2,l)+beta(l-1)*sig(k-1,l-1) +13 continue + a(k-1)=alpha(k-1)+sig(k,k+1)/sig(k,k)-sig(k-1,k)/sig(k-1,k-1) + b(k-1)=sig(k,k)/sig(k-1,k-1) +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/pade.for b/dataassim/math/numrec/f77_sources/pade.for new file mode 100644 index 0000000..4f8623d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/pade.for @@ -0,0 +1,45 @@ + SUBROUTINE pade(cof,n,resid) + INTEGER n,NMAX + REAL resid,BIG + DOUBLE PRECISION cof(2*n+1) + PARAMETER (NMAX=20,BIG=1.E30) +CU USES lubksb,ludcmp,mprove + INTEGER j,k,indx(NMAX) + REAL d,rr,rrold,sum,q(NMAX,NMAX),qlu(NMAX,NMAX),x(NMAX),y(NMAX), + *z(NMAX) + do 12 j=1,n + x(j)=cof(n+j+1) + y(j)=x(j) + do 11 k=1,n + q(j,k)=cof(j-k+n+1) + qlu(j,k)=q(j,k) +11 continue +12 continue + call ludcmp(qlu,n,NMAX,indx,d) + call lubksb(qlu,n,NMAX,indx,x) + rr=BIG +1 continue + rrold=rr + do 13 j=1,n + z(j)=x(j) +13 continue + call mprove(q,qlu,n,NMAX,indx,y,x) + rr=0. + do 14 j=1,n + rr=rr+(z(j)-x(j))**2 +14 continue + if(rr.lt.rrold)goto 1 + resid=sqrt(rr) + do 16 k=1,n + sum=cof(k+1) + do 15 j=1,k + sum=sum-x(j)*cof(k-j+1) +15 continue + y(k)=sum +16 continue + do 17 j=1,n + cof(j+1)=y(j) + cof(j+n+1)=-x(j) +17 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/pccheb.for b/dataassim/math/numrec/f77_sources/pccheb.for new file mode 100644 index 0000000..1acf807 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/pccheb.for @@ -0,0 +1,22 @@ + SUBROUTINE pccheb(d,c,n) + INTEGER n + REAL c(n),d(n) + INTEGER j,jm,jp,k + REAL fac,pow + pow=1. + c(1)=2.*d(1) + do 12 k=2,n + c(k)=0. + fac=d(k)/pow + jm=k-1 + jp=1 + do 11 j=k,1,-2 + c(j)=c(j)+fac + fac=fac*float(jm)/float(jp) + jm=jm-1 + jp=jp+1 +11 continue + pow=2.*pow +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/pcshft.for b/dataassim/math/numrec/f77_sources/pcshft.for new file mode 100644 index 0000000..bd7e3ea --- /dev/null +++ b/dataassim/math/numrec/f77_sources/pcshft.for @@ -0,0 +1,19 @@ + SUBROUTINE pcshft(a,b,d,n) + INTEGER n + REAL a,b,d(n) + INTEGER j,k + REAL const,fac + const=2./(b-a) + fac=const + do 11 j=2,n + d(j)=d(j)*fac + fac=fac*const +11 continue + const=0.5*(a+b) + do 13 j=1,n-1 + do 12 k=n-1,j,-1 + d(k)=d(k)-const*d(k+1) +12 continue +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/pearsn.for b/dataassim/math/numrec/f77_sources/pearsn.for new file mode 100644 index 0000000..007ac25 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/pearsn.for @@ -0,0 +1,33 @@ + SUBROUTINE pearsn(x,y,n,r,prob,z) + INTEGER n + REAL prob,r,z,x(n),y(n),TINY + PARAMETER (TINY=1.e-20) +CU USES betai + INTEGER j + REAL ax,ay,df,sxx,sxy,syy,t,xt,yt,betai + ax=0. + ay=0. + do 11 j=1,n + ax=ax+x(j) + ay=ay+y(j) +11 continue + ax=ax/n + ay=ay/n + sxx=0. + syy=0. + sxy=0. + do 12 j=1,n + xt=x(j)-ax + yt=y(j)-ay + sxx=sxx+xt**2 + syy=syy+yt**2 + sxy=sxy+xt*yt +12 continue + r=sxy/(sqrt(sxx*syy)+TINY) + z=0.5*log(((1.+r)+TINY)/((1.-r)+TINY)) + df=n-2 + t=r*sqrt(df/(((1.-r)+TINY)*((1.+r)+TINY))) + prob=betai(0.5*df,0.5,df/(df+t**2)) +C prob=erfcc(abs(z*sqrt(n-1.))/1.4142136) + return + END diff --git a/dataassim/math/numrec/f77_sources/period.for b/dataassim/math/numrec/f77_sources/period.for new file mode 100644 index 0000000..73b05aa --- /dev/null +++ b/dataassim/math/numrec/f77_sources/period.for @@ -0,0 +1,75 @@ + SUBROUTINE period(x,y,n,ofac,hifac,px,py,np,nout,jmax,prob) + INTEGER jmax,n,nout,np,NMAX + REAL hifac,ofac,prob,px(np),py(np),x(n),y(n) + PARAMETER (NMAX=2000) +CU USES avevar + INTEGER i,j + REAL ave,c,cc,cwtau,effm,expy,pnow,pymax,s,ss,sumc,sumcy,sums, + *sumsh,sumsy,swtau,var,wtau,xave,xdif,xmax,xmin,yy + DOUBLE PRECISION arg,wtemp,wi(NMAX),wpi(NMAX),wpr(NMAX),wr(NMAX), + *TWOPID + PARAMETER (TWOPID=6.2831853071795865D0) + nout=0.5*ofac*hifac*n + if(nout.gt.np) pause 'output arrays too short in period' + call avevar(y,n,ave,var) + xmax=x(1) + xmin=x(1) + do 11 j=1,n + if(x(j).gt.xmax)xmax=x(j) + if(x(j).lt.xmin)xmin=x(j) +11 continue + xdif=xmax-xmin + xave=0.5*(xmax+xmin) + pymax=0. + pnow=1./(xdif*ofac) + do 12 j=1,n + arg=TWOPID*((x(j)-xave)*pnow) + wpr(j)=-2.d0*sin(0.5d0*arg)**2 + wpi(j)=sin(arg) + wr(j)=cos(arg) + wi(j)=wpi(j) +12 continue + do 15 i=1,nout + px(i)=pnow + sumsh=0. + sumc=0. + do 13 j=1,n + c=wr(j) + s=wi(j) + sumsh=sumsh+s*c + sumc=sumc+(c-s)*(c+s) +13 continue + wtau=0.5*atan2(2.*sumsh,sumc) + swtau=sin(wtau) + cwtau=cos(wtau) + sums=0. + sumc=0. + sumsy=0. + sumcy=0. + do 14 j=1,n + s=wi(j) + c=wr(j) + ss=s*cwtau-c*swtau + cc=c*cwtau+s*swtau + sums=sums+ss**2 + sumc=sumc+cc**2 + yy=y(j)-ave + sumsy=sumsy+yy*ss + sumcy=sumcy+yy*cc + wtemp=wr(j) + wr(j)=(wr(j)*wpr(j)-wi(j)*wpi(j))+wr(j) + wi(j)=(wi(j)*wpr(j)+wtemp*wpi(j))+wi(j) +14 continue + py(i)=0.5*(sumcy**2/sumc+sumsy**2/sums)/var + if (py(i).ge.pymax) then + pymax=py(i) + jmax=i + endif + pnow=pnow+1./(ofac*xdif) +15 continue + expy=exp(-pymax) + effm=2.*nout/ofac + prob=effm*expy + if(prob.gt.0.01)prob=1.-(1.-expy)**effm + return + END diff --git a/dataassim/math/numrec/f77_sources/piksr2.for b/dataassim/math/numrec/f77_sources/piksr2.for new file mode 100644 index 0000000..1883de6 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/piksr2.for @@ -0,0 +1,19 @@ + SUBROUTINE piksr2(n,arr,brr) + INTEGER n + REAL arr(n),brr(n) + INTEGER i,j + REAL a,b + do 12 j=2,n + a=arr(j) + b=brr(j) + do 11 i=j-1,1,-1 + if(arr(i).le.a)goto 10 + arr(i+1)=arr(i) + brr(i+1)=brr(i) +11 continue + i=0 +10 arr(i+1)=a + brr(i+1)=b +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/piksrt.for b/dataassim/math/numrec/f77_sources/piksrt.for new file mode 100644 index 0000000..2193681 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/piksrt.for @@ -0,0 +1,16 @@ + SUBROUTINE piksrt(n,arr) + INTEGER n + REAL arr(n) + INTEGER i,j + REAL a + do 12 j=2,n + a=arr(j) + do 11 i=j-1,1,-1 + if(arr(i).le.a)goto 10 + arr(i+1)=arr(i) +11 continue + i=0 +10 arr(i+1)=a +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/pinvs.for b/dataassim/math/numrec/f77_sources/pinvs.for new file mode 100644 index 0000000..6289916 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/pinvs.for @@ -0,0 +1,64 @@ + SUBROUTINE pinvs(ie1,ie2,je1,jsf,jc1,k,c,nci,ncj,nck,s,nsi,nsj) + INTEGER ie1,ie2,jc1,je1,jsf,k,nci,ncj,nck,nsi,nsj,NMAX + REAL c(nci,ncj,nck),s(nsi,nsj) + PARAMETER (NMAX=10) + INTEGER i,icoff,id,ipiv,irow,j,jcoff,je2,jp,jpiv,js1,indxr(NMAX) + REAL big,dum,piv,pivinv,pscl(NMAX) + je2=je1+ie2-ie1 + js1=je2+1 + do 12 i=ie1,ie2 + big=0. + do 11 j=je1,je2 + if(abs(s(i,j)).gt.big) big=abs(s(i,j)) +11 continue + if(big.eq.0.) pause 'singular matrix, row all 0 in pinvs' + pscl(i)=1./big + indxr(i)=0 +12 continue + do 18 id=ie1,ie2 + piv=0. + do 14 i=ie1,ie2 + if(indxr(i).eq.0) then + big=0. + do 13 j=je1,je2 + if(abs(s(i,j)).gt.big) then + jp=j + big=abs(s(i,j)) + endif +13 continue + if(big*pscl(i).gt.piv) then + ipiv=i + jpiv=jp + piv=big*pscl(i) + endif + endif +14 continue + if(s(ipiv,jpiv).eq.0.) pause 'singular matrix in pinvs' + indxr(ipiv)=jpiv + pivinv=1./s(ipiv,jpiv) + do 15 j=je1,jsf + s(ipiv,j)=s(ipiv,j)*pivinv +15 continue + s(ipiv,jpiv)=1. + do 17 i=ie1,ie2 + if(indxr(i).ne.jpiv) then + if(s(i,jpiv).ne.0.) then + dum=s(i,jpiv) + do 16 j=je1,jsf + s(i,j)=s(i,j)-dum*s(ipiv,j) +16 continue + s(i,jpiv)=0. + endif + endif +17 continue +18 continue + jcoff=jc1-js1 + icoff=ie1-je1 + do 21 i=ie1,ie2 + irow=indxr(i)+icoff + do 19 j=js1,jsf + c(irow,j+jcoff,k)=s(i,j) +19 continue +21 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/plgndr.for b/dataassim/math/numrec/f77_sources/plgndr.for new file mode 100644 index 0000000..8a31313 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/plgndr.for @@ -0,0 +1,33 @@ + FUNCTION plgndr(l,m,x) + INTEGER l,m + REAL plgndr,x + INTEGER i,ll + REAL fact,pll,pmm,pmmp1,somx2 + if(m.lt.0.or.m.gt.l.or.abs(x).gt.1.)pause + *'bad arguments in plgndr' + pmm=1. + if(m.gt.0) then + somx2=sqrt((1.-x)*(1.+x)) + fact=1. + do 11 i=1,m + pmm=-pmm*fact*somx2 + fact=fact+2. +11 continue + endif + if(l.eq.m) then + plgndr=pmm + else + pmmp1=x*(2*m+1)*pmm + if(l.eq.m+1) then + plgndr=pmmp1 + else + do 12 ll=m+2,l + pll=(x*(2*ll-1)*pmmp1-(ll+m-1)*pmm)/(ll-m) + pmm=pmmp1 + pmmp1=pll +12 continue + plgndr=pll + endif + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/poidev.for b/dataassim/math/numrec/f77_sources/poidev.for new file mode 100644 index 0000000..bee31b2 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/poidev.for @@ -0,0 +1,35 @@ + FUNCTION poidev(xm,idum) + INTEGER idum + REAL poidev,xm,PI + PARAMETER (PI=3.141592654) +CU USES gammln,ran1 + REAL alxm,em,g,oldm,sq,t,y,gammln,ran1 + SAVE alxm,g,oldm,sq + DATA oldm /-1./ + if (xm.lt.12.)then + if (xm.ne.oldm) then + oldm=xm + g=exp(-xm) + endif + em=-1 + t=1. +2 em=em+1. + t=t*ran1(idum) + if (t.gt.g) goto 2 + else + if (xm.ne.oldm) then + oldm=xm + sq=sqrt(2.*xm) + alxm=log(xm) + g=xm*alxm-gammln(xm+1.) + endif +1 y=tan(PI*ran1(idum)) + em=sq*y+xm + if (em.lt.0.) goto 1 + em=int(em) + t=0.9*(1.+y**2)*exp(em*alxm-gammln(em+1.)-g) + if (ran1(idum).gt.t) goto 1 + endif + poidev=em + return + END diff --git a/dataassim/math/numrec/f77_sources/polcoe.for b/dataassim/math/numrec/f77_sources/polcoe.for new file mode 100644 index 0000000..c345d78 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/polcoe.for @@ -0,0 +1,31 @@ + SUBROUTINE polcoe(x,y,n,cof) + INTEGER n,NMAX + REAL cof(n),x(n),y(n) + PARAMETER (NMAX=15) + INTEGER i,j,k + REAL b,ff,phi,s(NMAX) + do 11 i=1,n + s(i)=0. + cof(i)=0. +11 continue + s(n)=-x(1) + do 13 i=2,n + do 12 j=n+1-i,n-1 + s(j)=s(j)-x(i)*s(j+1) +12 continue + s(n)=s(n)-x(i) +13 continue + do 16 j=1,n + phi=n + do 14 k=n-1,1,-1 + phi=k*s(k+1)+x(j)*phi +14 continue + ff=y(j)/phi + b=1. + do 15 k=n,1,-1 + cof(k)=cof(k)+b*ff + b=s(k)+x(j)*b +15 continue +16 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/polcof.for b/dataassim/math/numrec/f77_sources/polcof.for new file mode 100644 index 0000000..bffdd9d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/polcof.for @@ -0,0 +1,29 @@ + SUBROUTINE polcof(xa,ya,n,cof) + INTEGER n,NMAX + REAL cof(n),xa(n),ya(n) + PARAMETER (NMAX=15) +CU USES polint + INTEGER i,j,k + REAL dy,xmin,x(NMAX),y(NMAX) + do 11 j=1,n + x(j)=xa(j) + y(j)=ya(j) +11 continue + do 14 j=1,n + call polint(x,y,n+1-j,0.,cof(j),dy) + xmin=1.e38 + k=0 + do 12 i=1,n+1-j + if (abs(x(i)).lt.xmin)then + xmin=abs(x(i)) + k=i + endif + if(x(i).ne.0.)y(i)=(y(i)-cof(j))/x(i) +12 continue + do 13 i=k+1,n+1-j + y(i-1)=y(i) + x(i-1)=x(i) +13 continue +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/poldiv.for b/dataassim/math/numrec/f77_sources/poldiv.for new file mode 100644 index 0000000..e36109a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/poldiv.for @@ -0,0 +1,19 @@ + SUBROUTINE poldiv(u,n,v,nv,q,r) + INTEGER n,nv + REAL q(n),r(n),u(n),v(nv) + INTEGER j,k + do 11 j=1,n + r(j)=u(j) + q(j)=0. +11 continue + do 13 k=n-nv,0,-1 + q(k+1)=r(nv+k)/v(nv) + do 12 j=nv+k-1,k+1,-1 + r(j)=r(j)-q(k+1)*v(j-k) +12 continue +13 continue + do 14 j=nv,n + r(j)=0. +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/polin2.for b/dataassim/math/numrec/f77_sources/polin2.for new file mode 100644 index 0000000..bd2ac32 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/polin2.for @@ -0,0 +1,16 @@ + SUBROUTINE polin2(x1a,x2a,ya,m,n,x1,x2,y,dy) + INTEGER m,n,NMAX,MMAX + REAL dy,x1,x2,y,x1a(m),x2a(n),ya(m,n) + PARAMETER (NMAX=20,MMAX=20) +CU USES polint + INTEGER j,k + REAL ymtmp(MMAX),yntmp(NMAX) + do 12 j=1,m + do 11 k=1,n + yntmp(k)=ya(j,k) +11 continue + call polint(x2a,yntmp,n,x2,ymtmp(j),dy) +12 continue + call polint(x1a,ymtmp,m,x1,y,dy) + return + END diff --git a/dataassim/math/numrec/f77_sources/polint.for b/dataassim/math/numrec/f77_sources/polint.for new file mode 100644 index 0000000..42cfcdc --- /dev/null +++ b/dataassim/math/numrec/f77_sources/polint.for @@ -0,0 +1,40 @@ + SUBROUTINE polint(xa,ya,n,x,y,dy) + INTEGER n,NMAX + REAL dy,x,y,xa(n),ya(n) + PARAMETER (NMAX=10) + INTEGER i,m,ns + REAL den,dif,dift,ho,hp,w,c(NMAX),d(NMAX) + ns=1 + dif=abs(x-xa(1)) + do 11 i=1,n + dift=abs(x-xa(i)) + if (dift.lt.dif) then + ns=i + dif=dift + endif + c(i)=ya(i) + d(i)=ya(i) +11 continue + y=ya(ns) + ns=ns-1 + do 13 m=1,n-1 + do 12 i=1,n-m + ho=xa(i)-x + hp=xa(i+m)-x + w=c(i+1)-d(i) + den=ho-hp + if(den.eq.0.)pause 'failure in polint' + den=w/den + d(i)=hp*den + c(i)=ho*den +12 continue + if (2*ns.lt.n-m)then + dy=c(ns+1) + else + dy=d(ns) + ns=ns-1 + endif + y=y+dy +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/powell.for b/dataassim/math/numrec/f77_sources/powell.for new file mode 100644 index 0000000..b17d617 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/powell.for @@ -0,0 +1,46 @@ + SUBROUTINE powell(p,xi,n,np,ftol,iter,fret) + INTEGER iter,n,np,NMAX,ITMAX + REAL fret,ftol,p(np),xi(np,np),func + EXTERNAL func + PARAMETER (NMAX=20,ITMAX=200) +CU USES func,linmin + INTEGER i,ibig,j + REAL del,fp,fptt,t,pt(NMAX),ptt(NMAX),xit(NMAX) + fret=func(p) + do 11 j=1,n + pt(j)=p(j) +11 continue + iter=0 +1 iter=iter+1 + fp=fret + ibig=0 + del=0. + do 13 i=1,n + do 12 j=1,n + xit(j)=xi(j,i) +12 continue + fptt=fret + call linmin(p,xit,n,fret) + if(abs(fptt-fret).gt.del)then + del=abs(fptt-fret) + ibig=i + endif +13 continue + if(2.*abs(fp-fret).le.ftol*(abs(fp)+abs(fret)))return + if(iter.eq.ITMAX) pause 'powell exceeding maximum iterations' + do 14 j=1,n + ptt(j)=2.*p(j)-pt(j) + xit(j)=p(j)-pt(j) + pt(j)=p(j) +14 continue + fptt=func(ptt) + if(fptt.ge.fp)goto 1 + t=2.*(fp-2.*fret+fptt)*(fp-fret-del)**2-del*(fp-fptt)**2 + if(t.ge.0.)goto 1 + call linmin(p,xit,n,fret) + do 15 j=1,n + xi(j,ibig)=xi(j,n) + xi(j,n)=xit(j) +15 continue + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/predic.for b/dataassim/math/numrec/f77_sources/predic.for new file mode 100644 index 0000000..a5e91bf --- /dev/null +++ b/dataassim/math/numrec/f77_sources/predic.for @@ -0,0 +1,23 @@ + SUBROUTINE predic(data,ndata,d,m,future,nfut) + INTEGER ndata,nfut,m,MMAX + REAL d(m),data(ndata),future(nfut) + PARAMETER (MMAX=100) + INTEGER j,k + REAL discrp,sum,reg(MMAX) + do 11 j=1,m + reg(j)=data(ndata+1-j) +11 continue + do 14 j=1,nfut + discrp=0. + sum=discrp + do 12 k=1,m + sum=sum+d(k)*reg(k) +12 continue + do 13 k=m,2,-1 + reg(k)=reg(k-1) +13 continue + reg(1)=sum + future(j)=sum +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/probks.for b/dataassim/math/numrec/f77_sources/probks.for new file mode 100644 index 0000000..ff90e3e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/probks.for @@ -0,0 +1,19 @@ + FUNCTION probks(alam) + REAL probks,alam,EPS1,EPS2 + PARAMETER (EPS1=0.001, EPS2=1.e-8) + INTEGER j + REAL a2,fac,term,termbf + a2=-2.*alam**2 + fac=2. + probks=0. + termbf=0. + do 11 j=1,100 + term=fac*exp(a2*j**2) + probks=probks+term + if(abs(term).le.EPS1*termbf.or.abs(term).le.EPS2*probks)return + fac=-fac + termbf=abs(term) +11 continue + probks=1. + return + END diff --git a/dataassim/math/numrec/f77_sources/psdes.for b/dataassim/math/numrec/f77_sources/psdes.for new file mode 100644 index 0000000..537d3c2 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/psdes.for @@ -0,0 +1,19 @@ + SUBROUTINE psdes(lword,irword) + INTEGER irword,lword,NITER + PARAMETER (NITER=4) + INTEGER i,ia,ib,iswap,itmph,itmpl,c1(4),c2(4) + SAVE c1,c2 + DATA c1 /16#BAA96887,16#1E17D32C,16#03BCDC3C,16#0F33D1B2/, c2 + */16#4B0F3B58,16#E874F0C3,16#6955C5A6, 16#55A7CA46/ + do 11 i=1,NITER + iswap=irword + ia=ieor(irword,c1(i)) + itmpl=iand(ia,65535) + itmph=iand(ishft(ia,-16),65535) + ib=itmpl**2+not(itmph**2) + ia=ior(ishft(ib,16),iand(ishft(ib,-16),65535)) + irword=ieor(lword,ieor(c2(i),ia)+itmpl*itmph) + lword=iswap +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/pwt.for b/dataassim/math/numrec/f77_sources/pwt.for new file mode 100644 index 0000000..28c2f2b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/pwt.for @@ -0,0 +1,48 @@ + SUBROUTINE pwt(a,n,isign) + INTEGER isign,n,NMAX,NCMAX,ncof,ioff,joff + PARAMETER (NMAX=2048,NCMAX=50) + REAL a(n),wksp(NMAX),cc(NCMAX),cr(NCMAX) + COMMON /pwtcom/ cc,cr,ncof,ioff,joff + INTEGER i,ii,j,jf,jr,k,n1,ni,nj,nh,nmod + REAL ai,ai1 + if (n.lt.4) return + nmod=ncof*n + n1=n-1 + nh=n/2 + do 11 j=1,n + wksp(j)=0. +11 continue + if (isign.ge.0) then + ii=1 + do 13 i=1,n,2 + ni=i+nmod+ioff + nj=i+nmod+joff + do 12 k=1,ncof + jf=iand(n1,ni+k) + jr=iand(n1,nj+k) + wksp(ii)=wksp(ii)+cc(k)*a(jf+1) + wksp(ii+nh)=wksp(ii+nh)+cr(k)*a(jr+1) +12 continue + ii=ii+1 +13 continue + else + ii=1 + do 15 i=1,n,2 + ai=a(ii) + ai1=a(ii+nh) + ni=i+nmod+ioff + nj=i+nmod+joff + do 14 k=1,ncof + jf=iand(n1,ni+k)+1 + jr=iand(n1,nj+k)+1 + wksp(jf)=wksp(jf)+cc(k)*ai + wksp(jr)=wksp(jr)+cr(k)*ai1 +14 continue + ii=ii+1 +15 continue + endif + do 16 j=1,n + a(j)=wksp(j) +16 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/pwtset.for b/dataassim/math/numrec/f77_sources/pwtset.for new file mode 100644 index 0000000..e5408d4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/pwtset.for @@ -0,0 +1,39 @@ + SUBROUTINE pwtset(n) + INTEGER n,NCMAX,ncof,ioff,joff + PARAMETER (NCMAX=50) + REAL cc(NCMAX),cr(NCMAX) + COMMON /pwtcom/ cc,cr,ncof,ioff,joff + INTEGER k + REAL sig,c4(4),c12(12),c20(20) + SAVE c4,c12,c20,/pwtcom/ + DATA c4/0.4829629131445341, 0.8365163037378079,0.2241438680420134, + *-0.1294095225512604/ + DATA c12 /.111540743350, .494623890398, .751133908021, + *.315250351709,-.226264693965,-.129766867567,.097501605587, + *.027522865530,-.031582039318,.000553842201, .004777257511, + *-.001077301085/ + DATA c20 /.026670057901, .188176800078, .527201188932, + *.688459039454, .281172343661,-.249846424327,-.195946274377, + *.127369340336, .093057364604,-.071394147166,-.029457536822, + *.033212674059,.003606553567,-.010733175483, .001395351747, + *.001992405295,-.000685856695,-.000116466855,.000093588670, + *-.000013264203 / + ncof=n + sig=-1. + do 11 k=1,n + if(n.eq.4)then + cc(k)=c4(k) + else if(n.eq.12)then + cc(k)=c12(k) + else if(n.eq.20)then + cc(k)=c20(k) + else + pause 'unimplemented value n in pwtset' + endif + cr(ncof+1-k)=sig*cc(k) + sig=-sig +11 continue + ioff=-n/2 + joff=-n/2 + return + END diff --git a/dataassim/math/numrec/f77_sources/pythag.for b/dataassim/math/numrec/f77_sources/pythag.for new file mode 100644 index 0000000..93b144b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/pythag.for @@ -0,0 +1,16 @@ + FUNCTION pythag(a,b) + REAL a,b,pythag + REAL absa,absb + absa=abs(a) + absb=abs(b) + if(absa.gt.absb)then + pythag=absa*sqrt(1.+(absb/absa)**2) + else + if(absb.eq.0.)then + pythag=0. + else + pythag=absb*sqrt(1.+(absa/absb)**2) + endif + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/pzextr.for b/dataassim/math/numrec/f77_sources/pzextr.for new file mode 100644 index 0000000..11613ba --- /dev/null +++ b/dataassim/math/numrec/f77_sources/pzextr.for @@ -0,0 +1,39 @@ + SUBROUTINE pzextr(iest,xest,yest,yz,dy,nv) + INTEGER iest,nv,IMAX,NMAX + REAL xest,dy(nv),yest(nv),yz(nv) + PARAMETER (IMAX=13,NMAX=50) + INTEGER j,k1 + REAL delta,f1,f2,q,d(NMAX),qcol(NMAX,IMAX),x(IMAX) + SAVE qcol,x + x(iest)=xest + do 11 j=1,nv + dy(j)=yest(j) + yz(j)=yest(j) +11 continue + if(iest.eq.1) then + do 12 j=1,nv + qcol(j,1)=yest(j) +12 continue + else + do 13 j=1,nv + d(j)=yest(j) +13 continue + do 15 k1=1,iest-1 + delta=1./(x(iest-k1)-xest) + f1=xest*delta + f2=x(iest-k1)*delta + do 14 j=1,nv + q=qcol(j,k1) + qcol(j,k1)=dy(j) + delta=d(j)-q + dy(j)=f1*delta + d(j)=f2*delta + yz(j)=yz(j)+dy(j) +14 continue +15 continue + do 16 j=1,nv + qcol(j,iest)=dy(j) +16 continue + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/qgaus.for b/dataassim/math/numrec/f77_sources/qgaus.for new file mode 100644 index 0000000..07c2aa1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/qgaus.for @@ -0,0 +1,20 @@ + SUBROUTINE qgaus(func,a,b,ss) + REAL a,b,ss,func + EXTERNAL func + INTEGER j + REAL dx,xm,xr,w(5),x(5) + SAVE w,x + DATA w/.2955242247,.2692667193,.2190863625,.1494513491, + *.0666713443/ + DATA x/.1488743389,.4333953941,.6794095682,.8650633666, + *.9739065285/ + xm=0.5*(b+a) + xr=0.5*(b-a) + ss=0 + do 11 j=1,5 + dx=xr*x(j) + ss=ss+w(j)*(func(xm+dx)+func(xm-dx)) +11 continue + ss=xr*ss + return + END diff --git a/dataassim/math/numrec/f77_sources/qrdcmp.for b/dataassim/math/numrec/f77_sources/qrdcmp.for new file mode 100644 index 0000000..3bb616d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/qrdcmp.for @@ -0,0 +1,44 @@ + SUBROUTINE qrdcmp(a,n,np,c,d,sing) + INTEGER n,np + REAL a(np,np),c(n),d(n) + LOGICAL sing + INTEGER i,j,k + REAL scale,sigma,sum,tau + sing=.false. + do 17 k=1,n-1 + scale=0. + do 11 i=k,n + scale=max(scale,abs(a(i,k))) +11 continue + if(scale.eq.0.)then + sing=.true. + c(k)=0. + d(k)=0. + else + do 12 i=k,n + a(i,k)=a(i,k)/scale +12 continue + sum=0. + do 13 i=k,n + sum=sum+a(i,k)**2 +13 continue + sigma=sign(sqrt(sum),a(k,k)) + a(k,k)=a(k,k)+sigma + c(k)=sigma*a(k,k) + d(k)=-scale*sigma + do 16 j=k+1,n + sum=0. + do 14 i=k,n + sum=sum+a(i,k)*a(i,j) +14 continue + tau=sum/c(k) + do 15 i=k,n + a(i,j)=a(i,j)-tau*a(i,k) +15 continue +16 continue + endif +17 continue + d(n)=a(n,n) + if(d(n).eq.0.)sing=.true. + return + END diff --git a/dataassim/math/numrec/f77_sources/qromb.for b/dataassim/math/numrec/f77_sources/qromb.for new file mode 100644 index 0000000..0e5c4c9 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/qromb.for @@ -0,0 +1,20 @@ + SUBROUTINE qromb(func,a,b,ss) + INTEGER JMAX,JMAXP,K,KM + REAL a,b,func,ss,EPS + EXTERNAL func + PARAMETER (EPS=1.e-6, JMAX=20, JMAXP=JMAX+1, K=5, KM=K-1) +CU USES polint,trapzd + INTEGER j + REAL dss,h(JMAXP),s(JMAXP) + h(1)=1. + do 11 j=1,JMAX + call trapzd(func,a,b,s(j),j) + if (j.ge.K) then + call polint(h(j-KM),s(j-KM),K,0.,ss,dss) + if (abs(dss).le.EPS*abs(ss)) return + endif + s(j+1)=s(j) + h(j+1)=0.25*h(j) +11 continue + pause 'too many steps in qromb' + END diff --git a/dataassim/math/numrec/f77_sources/qromo.for b/dataassim/math/numrec/f77_sources/qromo.for new file mode 100644 index 0000000..ea0fafe --- /dev/null +++ b/dataassim/math/numrec/f77_sources/qromo.for @@ -0,0 +1,20 @@ + SUBROUTINE qromo(func,a,b,ss,choose) + INTEGER JMAX,JMAXP,K,KM + REAL a,b,func,ss,EPS + EXTERNAL func,choose + PARAMETER (EPS=1.e-6, JMAX=14, JMAXP=JMAX+1, K=5, KM=K-1) +CU USES polint + INTEGER j + REAL dss,h(JMAXP),s(JMAXP) + h(1)=1. + do 11 j=1,JMAX + call choose(func,a,b,s(j),j) + if (j.ge.K) then + call polint(h(j-KM),s(j-KM),K,0.,ss,dss) + if (abs(dss).le.EPS*abs(ss)) return + endif + s(j+1)=s(j) + h(j+1)=h(j)/9. +11 continue + pause 'too many steps in qromo' + END diff --git a/dataassim/math/numrec/f77_sources/qroot.for b/dataassim/math/numrec/f77_sources/qroot.for new file mode 100644 index 0000000..1742364 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/qroot.for @@ -0,0 +1,30 @@ + SUBROUTINE qroot(p,n,b,c,eps) + INTEGER n,NMAX,ITMAX + REAL b,c,eps,p(n),TINY + PARAMETER (NMAX=20,ITMAX=20,TINY=1.0e-6) +CU USES poldiv + INTEGER iter + REAL delb,delc,div,r,rb,rc,s,sb,sc,d(3),q(NMAX),qq(NMAX),rem(NMAX) + d(3)=1. + do 11 iter=1,ITMAX + d(2)=b + d(1)=c + call poldiv(p,n,d,3,q,rem) + s=rem(1) + r=rem(2) + call poldiv(q,n-1,d,3,qq,rem) + sc=-rem(1) + rc=-rem(2) + sb=-c*rc + rb=sc-b*rc + div=1./(sb*rc-sc*rb) + delb=(r*sc-s*rc)*div + delc=(-r*sb+s*rb)*div + b=b+delb + c=c+delc + if((abs(delb).le.eps* + *abs(b).or.abs(b).lt.TINY).and.(abs(delc).le.eps* + *abs(c).or.abs(c).lt.TINY)) return +11 continue + pause 'too many iterations in qroot' + END diff --git a/dataassim/math/numrec/f77_sources/qrsolv.for b/dataassim/math/numrec/f77_sources/qrsolv.for new file mode 100644 index 0000000..7f25d37 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/qrsolv.for @@ -0,0 +1,19 @@ + SUBROUTINE qrsolv(a,n,np,c,d,b) + INTEGER n,np + REAL a(np,np),b(n),c(n),d(n) +CU USES rsolv + INTEGER i,j + REAL sum,tau + do 13 j=1,n-1 + sum=0. + do 11 i=j,n + sum=sum+a(i,j)*b(i) +11 continue + tau=sum/c(j) + do 12 i=j,n + b(i)=b(i)-tau*a(i,j) +12 continue +13 continue + call rsolv(a,n,np,d,b) + return + END diff --git a/dataassim/math/numrec/f77_sources/qrupdt.for b/dataassim/math/numrec/f77_sources/qrupdt.for new file mode 100644 index 0000000..4d0e215 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/qrupdt.for @@ -0,0 +1,27 @@ + SUBROUTINE qrupdt(r,qt,n,np,u,v) + INTEGER n,np + REAL r(np,np),qt(np,np),u(np),v(np) +CU USES rotate + INTEGER i,j,k + do 11 k=n,1,-1 + if(u(k).ne.0.)goto 1 +11 continue + k=1 +1 do 12 i=k-1,1,-1 + call rotate(r,qt,n,np,i,u(i),-u(i+1)) + if(u(i).eq.0.)then + u(i)=abs(u(i+1)) + else if(abs(u(i)).gt.abs(u(i+1)))then + u(i)=abs(u(i))*sqrt(1.+(u(i+1)/u(i))**2) + else + u(i)=abs(u(i+1))*sqrt(1.+(u(i)/u(i+1))**2) + endif +12 continue + do 13 j=1,n + r(1,j)=r(1,j)+u(1)*v(j) +13 continue + do 14 i=1,k-1 + call rotate(r,qt,n,np,i,r(i,i),-r(i+1,i)) +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/qsimp.for b/dataassim/math/numrec/f77_sources/qsimp.for new file mode 100644 index 0000000..8ee4cca --- /dev/null +++ b/dataassim/math/numrec/f77_sources/qsimp.for @@ -0,0 +1,20 @@ + SUBROUTINE qsimp(func,a,b,s) + INTEGER JMAX + REAL a,b,func,s,EPS + EXTERNAL func + PARAMETER (EPS=1.e-6, JMAX=20) +CU USES trapzd + INTEGER j + REAL os,ost,st + ost=-1.e30 + os= -1.e30 + do 11 j=1,JMAX + call trapzd(func,a,b,st,j) + s=(4.*st-ost)/3. + if (abs(s-os).lt.EPS*abs(os)) return + if (s.eq.0..and.os.eq.0..and.j.gt.6) return + os=s + ost=st +11 continue + pause 'too many steps in qsimp' + END diff --git a/dataassim/math/numrec/f77_sources/qtrap.for b/dataassim/math/numrec/f77_sources/qtrap.for new file mode 100644 index 0000000..91d8fa4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/qtrap.for @@ -0,0 +1,17 @@ + SUBROUTINE qtrap(func,a,b,s) + INTEGER JMAX + REAL a,b,func,s,EPS + EXTERNAL func + PARAMETER (EPS=1.e-6, JMAX=20) +CU USES trapzd + INTEGER j + REAL olds + olds=-1.e30 + do 11 j=1,JMAX + call trapzd(func,a,b,s,j) + if (abs(s-olds).lt.EPS*abs(olds)) return + if (s.eq.0..and.olds.eq.0..and.j.gt.6) return + olds=s +11 continue + pause 'too many steps in qtrap' + END diff --git a/dataassim/math/numrec/f77_sources/quad3d.for b/dataassim/math/numrec/f77_sources/quad3d.for new file mode 100644 index 0000000..b7312e9 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/quad3d.for @@ -0,0 +1,37 @@ + SUBROUTINE quad3d(x1,x2,ss) + REAL ss,x1,x2,h + EXTERNAL h +CU USES h,qgausx + call qgausx(h,x1,x2,ss) + return + END + FUNCTION f(zz) + REAL f,zz,func,x,y,z + COMMON /xyz/ x,y,z +CU USES func + z=zz + f=func(x,y,z) + return + END + FUNCTION g(yy) + REAL g,yy,f,z1,z2,x,y,z + EXTERNAL f + COMMON /xyz/ x,y,z +CU USES f,qgausz,z1,z2 + REAL ss + y=yy + call qgausz(f,z1(x,y),z2(x,y),ss) + g=ss + return + END + FUNCTION h(xx) + REAL h,xx,g,y1,y2,x,y,z + EXTERNAL g + COMMON /xyz/ x,y,z +CU USES g,qgausy,y1,y2 + REAL ss + x=xx + call qgausy(g,y1(x),y2(x),ss) + h=ss + return + END diff --git a/dataassim/math/numrec/f77_sources/quadct.for b/dataassim/math/numrec/f77_sources/quadct.for new file mode 100644 index 0000000..7a5df33 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/quadct.for @@ -0,0 +1,31 @@ + SUBROUTINE quadct(x,y,xx,yy,nn,fa,fb,fc,fd) + INTEGER nn + REAL fa,fb,fc,fd,x,y,xx(nn),yy(nn) + INTEGER k,na,nb,nc,nd + REAL ff + na=0 + nb=0 + nc=0 + nd=0 + do 11 k=1,nn + if(yy(k).gt.y)then + if(xx(k).gt.x)then + na=na+1 + else + nb=nb+1 + endif + else + if(xx(k).gt.x)then + nd=nd+1 + else + nc=nc+1 + endif + endif +11 continue + ff=1.0/nn + fa=ff*na + fb=ff*nb + fc=ff*nc + fd=ff*nd + return + END diff --git a/dataassim/math/numrec/f77_sources/quadmx.for b/dataassim/math/numrec/f77_sources/quadmx.for new file mode 100644 index 0000000..4fd121f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/quadmx.for @@ -0,0 +1,24 @@ + SUBROUTINE quadmx(a,n,np) + INTEGER n,np,NMAX + REAL a(np,np),PI + DOUBLE PRECISION xx + PARAMETER (PI=3.14159265,NMAX=257) + COMMON /momcom/ xx + EXTERNAL kermom +CU USES wwghts,kermom + INTEGER j,k + REAL h,wt(NMAX),x,cx,y + h=PI/(n-1) + do 12 j=1,n + x=(j-1)*h + xx=x + call wwghts(wt,n,h,kermom) + cx=cos(x) + do 11 k=1,n + y=(k-1)*h + a(j,k)=wt(k)*cx*cos(y) +11 continue + a(j,j)=a(j,j)+1. +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/quadvl.for b/dataassim/math/numrec/f77_sources/quadvl.for new file mode 100644 index 0000000..5c0cb43 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/quadvl.for @@ -0,0 +1,13 @@ + SUBROUTINE quadvl(x,y,fa,fb,fc,fd) + REAL fa,fb,fc,fd,x,y + REAL qa,qb,qc,qd + qa=min(2.,max(0.,1.-x)) + qb=min(2.,max(0.,1.-y)) + qc=min(2.,max(0.,x+1.)) + qd=min(2.,max(0.,y+1.)) + fa=0.25*qa*qb + fb=0.25*qb*qc + fc=0.25*qc*qd + fd=0.25*qd*qa + return + END diff --git a/dataassim/math/numrec/f77_sources/ran0.for b/dataassim/math/numrec/f77_sources/ran0.for new file mode 100644 index 0000000..5aae679 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ran0.for @@ -0,0 +1,14 @@ + FUNCTION ran0(idum) + INTEGER idum,IA,IM,IQ,IR,MASK + REAL ran0,AM + PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, + *MASK=123459876) + INTEGER k + idum=ieor(idum,MASK) + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + ran0=AM*idum + idum=ieor(idum,MASK) + return + END diff --git a/dataassim/math/numrec/f77_sources/ran1.for b/dataassim/math/numrec/f77_sources/ran1.for new file mode 100644 index 0000000..7d9fca5 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ran1.for @@ -0,0 +1,27 @@ + FUNCTION ran1(idum) + INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV + REAL ran1,AM,EPS,RNMX + PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836, + *NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS) + INTEGER j,k,iv(NTAB),iy + SAVE iv,iy + DATA iv /NTAB*0/, iy /0/ + if (idum.le.0.or.iy.eq.0) then + idum=max(-idum,1) + do 11 j=NTAB+8,1,-1 + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + if (j.le.NTAB) iv(j)=idum +11 continue + iy=iv(1) + endif + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + j=1+iy/NDIV + iy=iv(j) + iv(j)=idum + ran1=min(AM*iy,RNMX) + return + END diff --git a/dataassim/math/numrec/f77_sources/ran2.for b/dataassim/math/numrec/f77_sources/ran2.for new file mode 100644 index 0000000..1b500af --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ran2.for @@ -0,0 +1,33 @@ + FUNCTION ran2(idum) + INTEGER idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV + REAL ran2,AM,EPS,RNMX + PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1, + *IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791, + *NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS) + INTEGER idum2,j,k,iv(NTAB),iy + SAVE iv,iy,idum2 + DATA idum2/123456789/, iv/NTAB*0/, iy/0/ + if (idum.le.0) then + idum=max(-idum,1) + idum2=idum + do 11 j=NTAB+8,1,-1 + k=idum/IQ1 + idum=IA1*(idum-k*IQ1)-k*IR1 + if (idum.lt.0) idum=idum+IM1 + if (j.le.NTAB) iv(j)=idum +11 continue + iy=iv(1) + endif + k=idum/IQ1 + idum=IA1*(idum-k*IQ1)-k*IR1 + if (idum.lt.0) idum=idum+IM1 + k=idum2/IQ2 + idum2=IA2*(idum2-k*IQ2)-k*IR2 + if (idum2.lt.0) idum2=idum2+IM2 + j=1+iy/NDIV + iy=iv(j)-idum2 + iv(j)=idum + if(iy.lt.1)iy=iy+IMM1 + ran2=min(AM*iy,RNMX) + return + END diff --git a/dataassim/math/numrec/f77_sources/ran3.for b/dataassim/math/numrec/f77_sources/ran3.for new file mode 100644 index 0000000..63e5453 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ran3.for @@ -0,0 +1,45 @@ + FUNCTION ran3(idum) + INTEGER idum + INTEGER MBIG,MSEED,MZ +C REAL MBIG,MSEED,MZ + REAL ran3,FAC + PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1./MBIG) +C PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=1./MBIG) + INTEGER i,iff,ii,inext,inextp,k + INTEGER mj,mk,ma(55) +C REAL mj,mk,ma(55) + SAVE iff,inext,inextp,ma + DATA iff /0/ + if(idum.lt.0.or.iff.eq.0)then + iff=1 + mj=MSEED-iabs(idum) + mj=mod(mj,MBIG) + ma(55)=mj + mk=1 + do 11 i=1,54 + ii=mod(21*i,55) + ma(ii)=mk + mk=mj-mk + if(mk.lt.MZ)mk=mk+MBIG + mj=ma(ii) +11 continue + do 13 k=1,4 + do 12 i=1,55 + ma(i)=ma(i)-ma(1+mod(i+30,55)) + if(ma(i).lt.MZ)ma(i)=ma(i)+MBIG +12 continue +13 continue + inext=0 + inextp=31 + idum=1 + endif + inext=inext+1 + if(inext.eq.56)inext=1 + inextp=inextp+1 + if(inextp.eq.56)inextp=1 + mj=ma(inext)-ma(inextp) + if(mj.lt.MZ)mj=mj+MBIG + ma(inext)=mj + ran3=mj*FAC + return + END diff --git a/dataassim/math/numrec/f77_sources/ran4.for b/dataassim/math/numrec/f77_sources/ran4.for new file mode 100644 index 0000000..5ca218c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ran4.for @@ -0,0 +1,21 @@ + FUNCTION ran4(idum) + INTEGER idum + REAL ran4 +CU USES psdes + INTEGER idums,irword,itemp,jflmsk,jflone,lword + REAL ftemp + EQUIVALENCE (itemp,ftemp) + SAVE idums,jflone,jflmsk + DATA idums /0/, jflone /16#3F800000/, jflmsk /16#007FFFFF/ + if(idum.lt.0)then + idums=-idum + idum=1 + endif + irword=idum + lword=idums + call psdes(lword,irword) + itemp=ior(jflone,iand(jflmsk,irword)) + ran4=ftemp-1.0 + idum=idum+1 + return + END diff --git a/dataassim/math/numrec/f77_sources/rank.for b/dataassim/math/numrec/f77_sources/rank.for new file mode 100644 index 0000000..38dbe84 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rank.for @@ -0,0 +1,8 @@ + SUBROUTINE rank(n,indx,irank) + INTEGER n,indx(n),irank(n) + INTEGER j + do 11 j=1,n + irank(indx(j))=j +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/ranpt.for b/dataassim/math/numrec/f77_sources/ranpt.for new file mode 100644 index 0000000..c7257d5 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ranpt.for @@ -0,0 +1,13 @@ + SUBROUTINE ranpt(pt,region,n) + INTEGER n,idum + REAL pt(n),region(2*n) + COMMON /ranno/ idum + SAVE /ranno/ +CU USES ran1 + INTEGER j + REAL ran1 + do 11 j=1,n + pt(j)=region(j)+(region(j+n)-region(j))*ran1(idum) +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/ratint.for b/dataassim/math/numrec/f77_sources/ratint.for new file mode 100644 index 0000000..647b1d6 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ratint.for @@ -0,0 +1,44 @@ + SUBROUTINE ratint(xa,ya,n,x,y,dy) + INTEGER n,NMAX + REAL dy,x,y,xa(n),ya(n),TINY + PARAMETER (NMAX=10,TINY=1.e-25) + INTEGER i,m,ns + REAL dd,h,hh,t,w,c(NMAX),d(NMAX) + ns=1 + hh=abs(x-xa(1)) + do 11 i=1,n + h=abs(x-xa(i)) + if (h.eq.0.)then + y=ya(i) + dy=0.0 + return + else if (h.lt.hh) then + ns=i + hh=h + endif + c(i)=ya(i) + d(i)=ya(i)+TINY +11 continue + y=ya(ns) + ns=ns-1 + do 13 m=1,n-1 + do 12 i=1,n-m + w=c(i+1)-d(i) + h=xa(i+m)-x + t=(xa(i)-x)*d(i)/h + dd=t-c(i+1) + if(dd.eq.0.)pause 'failure in ratint' + dd=w/dd + d(i)=c(i+1)*dd + c(i)=t*dd +12 continue + if (2*ns.lt.n-m)then + dy=c(ns+1) + else + dy=d(ns) + ns=ns-1 + endif + y=y+dy +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/ratlsq.for b/dataassim/math/numrec/f77_sources/ratlsq.for new file mode 100644 index 0000000..e8c48d6 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ratlsq.for @@ -0,0 +1,63 @@ + SUBROUTINE ratlsq(fn,a,b,mm,kk,cof,dev) + INTEGER kk,mm,NPFAC,MAXC,MAXP,MAXIT + DOUBLE PRECISION a,b,dev,cof(mm+kk+1),fn,PIO2,BIG + PARAMETER (NPFAC=8,MAXC=20,MAXP=NPFAC*MAXC+1,MAXIT=5, + *PIO2=3.141592653589793D0/2.D0,BIG=1.D30) + EXTERNAL fn +CU USES fn,ratval,dsvbksb,dsvdcmp + INTEGER i,it,j,ncof,npt + DOUBLE PRECISION devmax,e,hth,pow,sum,bb(MAXP),coff(MAXC), + *ee(MAXP),fs(MAXP),u(MAXP,MAXC),v(MAXC,MAXC),w(MAXC),wt(MAXP), + *xs(MAXP),ratval + ncof=mm+kk+1 + npt=NPFAC*ncof + dev=BIG + do 11 i=1,npt + if (i.lt.npt/2) then + hth=PIO2*(i-1)/(npt-1.d0) + xs(i)=a+(b-a)*sin(hth)**2 + else + hth=PIO2*(npt-i)/(npt-1.d0) + xs(i)=b-(b-a)*sin(hth)**2 + endif + fs(i)=fn(xs(i)) + wt(i)=1.d0 + ee(i)=1.d0 +11 continue + e=0.d0 + do 17 it=1,MAXIT + do 14 i=1,npt + pow=wt(i) + bb(i)=pow*(fs(i)+sign(e,ee(i))) + do 12 j=1,mm+1 + u(i,j)=pow + pow=pow*xs(i) +12 continue + pow=-bb(i) + do 13 j=mm+2,ncof + pow=pow*xs(i) + u(i,j)=pow +13 continue +14 continue + call dsvdcmp(u,npt,ncof,MAXP,MAXC,w,v) + call dsvbksb(u,w,v,npt,ncof,MAXP,MAXC,bb,coff) + devmax=0.d0 + sum=0.d0 + do 15 j=1,npt + ee(j)=ratval(xs(j),coff,mm,kk)-fs(j) + wt(j)=abs(ee(j)) + sum=sum+wt(j) + if(wt(j).gt.devmax)devmax=wt(j) +15 continue + e=sum/npt + if (devmax.le.dev) then + do 16 j=1,ncof + cof(j)=coff(j) +16 continue + dev=devmax + endif + write (*,10) it,devmax +17 continue + return +10 FORMAT (1x,'ratlsq iteration=',i2,' max error=',1pe10.3) + END diff --git a/dataassim/math/numrec/f77_sources/ratval.for b/dataassim/math/numrec/f77_sources/ratval.for new file mode 100644 index 0000000..5e9c1b3 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ratval.for @@ -0,0 +1,16 @@ + FUNCTION ratval(x,cof,mm,kk) + INTEGER kk,mm + DOUBLE PRECISION ratval,x,cof(mm+kk+1) + INTEGER j + DOUBLE PRECISION sumd,sumn + sumn=cof(mm+1) + do 11 j=mm,1,-1 + sumn=sumn*x+cof(j) +11 continue + sumd=0.d0 + do 12 j=mm+kk+1,mm+2,-1 + sumd=(sumd+cof(j))*x +12 continue + ratval=sumn/(1.d0+sumd) + return + END diff --git a/dataassim/math/numrec/f77_sources/rc.for b/dataassim/math/numrec/f77_sources/rc.for new file mode 100644 index 0000000..a334045 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rc.for @@ -0,0 +1,29 @@ + FUNCTION rc(x,y) + REAL rc,x,y,ERRTOL,TINY,SQRTNY,BIG,TNBG,COMP1,COMP2,THIRD,C1,C2, + *C3,C4 + PARAMETER (ERRTOL=.04,TINY=1.69e-38,SQRTNY=1.3e-19,BIG=3.E37, + *TNBG=TINY*BIG,COMP1=2.236/SQRTNY,COMP2=TNBG*TNBG/25.,THIRD=1./3., + *C1=.3,C2=1./7.,C3=.375,C4=9./22.) + REAL alamb,ave,s,w,xt,yt + if(x.lt.0..or.y.eq.0..or.(x+abs(y)).lt.TINY.or.(x+ + *abs(y)).gt.BIG.or.(y.lt.-COMP1.and.x.gt.0..and.x.lt.COMP2))pause + *'invalid arguments in rc' + if(y.gt.0.)then + xt=x + yt=y + w=1. + else + xt=x-y + yt=-y + w=sqrt(x)/sqrt(xt) + endif +1 continue + alamb=2.*sqrt(xt)*sqrt(yt)+yt + xt=.25*(xt+alamb) + yt=.25*(yt+alamb) + ave=THIRD*(xt+yt+yt) + s=(yt-ave)/ave + if(abs(s).gt.ERRTOL)goto 1 + rc=w*(1.+s*s*(C1+s*(C2+s*(C3+s*C4))))/sqrt(ave) + return + END diff --git a/dataassim/math/numrec/f77_sources/rd.for b/dataassim/math/numrec/f77_sources/rd.for new file mode 100644 index 0000000..80f7038 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rd.for @@ -0,0 +1,37 @@ + FUNCTION rd(x,y,z) + REAL rd,x,y,z,ERRTOL,TINY,BIG,C1,C2,C3,C4,C5,C6 + PARAMETER (ERRTOL=.05,TINY=1.e-25,BIG=4.5E21,C1=3./14.,C2=1./6., + *C3=9./22.,C4=3./26.,C5=.25*C3,C6=1.5*C4) + REAL alamb,ave,delx,dely,delz,ea,eb,ec,ed,ee,fac,sqrtx,sqrty, + *sqrtz,sum,xt,yt,zt + if(min(x,y).lt.0..or.min(x+y,z).lt.TINY.or.max(x,y, + *z).gt.BIG)pause 'invalid arguments in rd' + xt=x + yt=y + zt=z + sum=0. + fac=1. +1 continue + sqrtx=sqrt(xt) + sqrty=sqrt(yt) + sqrtz=sqrt(zt) + alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz + sum=sum+fac/(sqrtz*(zt+alamb)) + fac=.25*fac + xt=.25*(xt+alamb) + yt=.25*(yt+alamb) + zt=.25*(zt+alamb) + ave=.2*(xt+yt+3.*zt) + delx=(ave-xt)/ave + dely=(ave-yt)/ave + delz=(ave-zt)/ave + if(max(abs(delx),abs(dely),abs(delz)).gt.ERRTOL)goto 1 + ea=delx*dely + eb=delz*delz + ec=ea-eb + ed=ea-6.*eb + ee=ed+ec+ec + rd=3.*sum+fac*(1.+ed*(-C1+C5*ed-C6*delz*ee)+delz*(C2*ee+delz*(-C3* + *ec+delz*C4*ea)))/(ave*sqrt(ave)) + return + END diff --git a/dataassim/math/numrec/f77_sources/realft.for b/dataassim/math/numrec/f77_sources/realft.for new file mode 100644 index 0000000..f13e7dc --- /dev/null +++ b/dataassim/math/numrec/f77_sources/realft.for @@ -0,0 +1,52 @@ + SUBROUTINE realft(data,n,isign) + INTEGER isign,n + REAL data(n) +CU USES four1 + INTEGER i,i1,i2,i3,i4,n2p3 + REAL c1,c2,h1i,h1r,h2i,h2r,wis,wrs + DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp + theta=3.141592653589793d0/dble(n/2) + c1=0.5 + if (isign.eq.1) then + c2=-0.5 + call four1(data,n/2,+1) + else + c2=0.5 + theta=-theta + endif + wpr=-2.0d0*sin(0.5d0*theta)**2 + wpi=sin(theta) + wr=1.0d0+wpr + wi=wpi + n2p3=n+3 + do 11 i=2,n/4 + i1=2*i-1 + i2=i1+1 + i3=n2p3-i2 + i4=i3+1 + wrs=sngl(wr) + wis=sngl(wi) + h1r=c1*(data(i1)+data(i3)) + h1i=c1*(data(i2)-data(i4)) + h2r=-c2*(data(i2)+data(i4)) + h2i=c2*(data(i1)-data(i3)) + data(i1)=h1r+wrs*h2r-wis*h2i + data(i2)=h1i+wrs*h2i+wis*h2r + data(i3)=h1r-wrs*h2r+wis*h2i + data(i4)=-h1i+wrs*h2i+wis*h2r + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi +11 continue + if (isign.eq.1) then + h1r=data(1) + data(1)=h1r+data(2) + data(2)=h1r-data(2) + else + h1r=data(1) + data(1)=c1*(h1r+data(2)) + data(2)=c1*(h1r-data(2)) + call four1(data,n/2,-1) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/rebin.for b/dataassim/math/numrec/f77_sources/rebin.for new file mode 100644 index 0000000..611b5fc --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rebin.for @@ -0,0 +1,25 @@ + SUBROUTINE rebin(rc,nd,r,xin,xi) + INTEGER nd + REAL rc,r(*),xi(*),xin(*) + INTEGER i,k + REAL dr,xn,xo + k=0 + xo=0. + dr=0. + do 11 i=1,nd-1 +1 if(rc.gt.dr)then + k=k+1 + dr=dr+r(k) + goto 1 + endif + if(k.gt.1) xo=xi(k-1) + xn=xi(k) + dr=dr-rc + xin(i)=xn-(xn-xo)*dr/r(k) +11 continue + do 12 i=1,nd-1 + xi(i)=xin(i) +12 continue + xi(nd)=1. + return + END diff --git a/dataassim/math/numrec/f77_sources/red.for b/dataassim/math/numrec/f77_sources/red.for new file mode 100644 index 0000000..0d5ce22 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/red.for @@ -0,0 +1,24 @@ + SUBROUTINE red(iz1,iz2,jz1,jz2,jm1,jm2,jmf,ic1,jc1,jcf,kc,c,nci, + *ncj,nck,s,nsi,nsj) + INTEGER ic1,iz1,iz2,jc1,jcf,jm1,jm2,jmf,jz1,jz2,kc,nci,ncj,nck, + *nsi,nsj + REAL c(nci,ncj,nck),s(nsi,nsj) + INTEGER i,ic,j,l,loff + REAL vx + loff=jc1-jm1 + ic=ic1 + do 14 j=jz1,jz2 + do 12 l=jm1,jm2 + vx=c(ic,l+loff,kc) + do 11 i=iz1,iz2 + s(i,l)=s(i,l)-s(i,j)*vx +11 continue +12 continue + vx=c(ic,jcf,kc) + do 13 i=iz1,iz2 + s(i,jmf)=s(i,jmf)-s(i,j)*vx +13 continue + ic=ic+1 +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/relax.for b/dataassim/math/numrec/f77_sources/relax.for new file mode 100644 index 0000000..daba375 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/relax.for @@ -0,0 +1,21 @@ + SUBROUTINE relax(u,rhs,n) + INTEGER n + DOUBLE PRECISION rhs(n,n),u(n,n) + INTEGER i,ipass,isw,j,jsw + DOUBLE PRECISION h,h2 + h=1.d0/(n-1) + h2=h*h + jsw=1 + do 13 ipass=1,2 + isw=jsw + do 12 j=2,n-1 + do 11 i=isw+1,n-1,2 + u(i,j)=0.25d0*(u(i+1,j)+u(i-1,j)+u(i,j+1)+u(i,j-1)-h2*rhs(i, + *j)) +11 continue + isw=3-isw +12 continue + jsw=3-jsw +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/relax2.for b/dataassim/math/numrec/f77_sources/relax2.for new file mode 100644 index 0000000..af68c01 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/relax2.for @@ -0,0 +1,23 @@ + SUBROUTINE relax2(u,rhs,n) + INTEGER n + DOUBLE PRECISION rhs(n,n),u(n,n) + INTEGER i,ipass,isw,j,jsw + DOUBLE PRECISION foh2,h,h2i,res + h=1.d0/(n-1) + h2i=1.d0/(h*h) + foh2=-4.d0*h2i + jsw=1 + do 13 ipass=1,2 + isw=jsw + do 12 j=2,n-1 + do 11 i=isw+1,n-1,2 + res=h2i*(u(i+1,j)+u(i-1,j)+u(i,j+1)+u(i,j-1)-4.d0*u(i,j))+ + *u(i,j)**2-rhs(i,j) + u(i,j)=u(i,j)-res/(foh2+2.d0*u(i,j)) +11 continue + isw=3-isw +12 continue + jsw=3-jsw +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/resid.for b/dataassim/math/numrec/f77_sources/resid.for new file mode 100644 index 0000000..cc5ae3f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/resid.for @@ -0,0 +1,21 @@ + SUBROUTINE resid(res,u,rhs,n) + INTEGER n + DOUBLE PRECISION res(n,n),rhs(n,n),u(n,n) + INTEGER i,j + DOUBLE PRECISION h,h2i + h=1.d0/(n-1) + h2i=1.d0/(h*h) + do 12 j=2,n-1 + do 11 i=2,n-1 + res(i,j)=-h2i*(u(i+1,j)+u(i-1,j)+u(i,j+1)+u(i,j-1)-4.d0*u(i, + *j))+rhs(i,j) +11 continue +12 continue + do 13 i=1,n + res(i,1)=0.d0 + res(i,n)=0.d0 + res(1,i)=0.d0 + res(n,i)=0.d0 +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/revcst.for b/dataassim/math/numrec/f77_sources/revcst.for new file mode 100644 index 0000000..86ad742 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/revcst.for @@ -0,0 +1,17 @@ + SUBROUTINE revcst(x,y,iorder,ncity,n,de) + INTEGER ncity,iorder(ncity),n(6) + REAL de,x(ncity),y(ncity) + INTEGER ii,j + REAL alen,xx(4),yy(4),x1,x2,y1,y2 + alen(x1,x2,y1,y2)=sqrt((x2-x1)**2+(y2-y1)**2) + n(3)=1+mod((n(1)+ncity-2),ncity) + n(4)=1+mod(n(2),ncity) + do 11 j=1,4 + ii=iorder(n(j)) + xx(j)=x(ii) + yy(j)=y(ii) +11 continue + de=-alen(xx(1),xx(3),yy(1),yy(3))-alen(xx(2),xx(4),yy(2),yy(4))+ + *alen(xx(1),xx(4),yy(1),yy(4))+alen(xx(2),xx(3),yy(2),yy(3)) + return + END diff --git a/dataassim/math/numrec/f77_sources/revers.for b/dataassim/math/numrec/f77_sources/revers.for new file mode 100644 index 0000000..ad704c1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/revers.for @@ -0,0 +1,13 @@ + SUBROUTINE revers(iorder,ncity,n) + INTEGER ncity,iorder(ncity),n(6) + INTEGER itmp,j,k,l,nn + nn=(1+mod(n(2)-n(1)+ncity,ncity))/2 + do 11 j=1,nn + k=1+mod((n(1)+j-2),ncity) + l=1+mod((n(2)-j+ncity),ncity) + itmp=iorder(k) + iorder(k)=iorder(l) + iorder(l)=itmp +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/rf.for b/dataassim/math/numrec/f77_sources/rf.for new file mode 100644 index 0000000..df58d8b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rf.for @@ -0,0 +1,28 @@ + FUNCTION rf(x,y,z) + REAL rf,x,y,z,ERRTOL,TINY,BIG,THIRD,C1,C2,C3,C4 + PARAMETER (ERRTOL=.08,TINY=1.5e-38,BIG=3.E37,THIRD=1./3., + *C1=1./24.,C2=.1,C3=3./44.,C4=1./14.) + REAL alamb,ave,delx,dely,delz,e2,e3,sqrtx,sqrty,sqrtz,xt,yt,zt + if(min(x,y,z).lt.0..or.min(x+y,x+z,y+z).lt.TINY.or.max(x,y, + *z).gt.BIG)pause 'invalid arguments in rf' + xt=x + yt=y + zt=z +1 continue + sqrtx=sqrt(xt) + sqrty=sqrt(yt) + sqrtz=sqrt(zt) + alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz + xt=.25*(xt+alamb) + yt=.25*(yt+alamb) + zt=.25*(zt+alamb) + ave=THIRD*(xt+yt+zt) + delx=(ave-xt)/ave + dely=(ave-yt)/ave + delz=(ave-zt)/ave + if(max(abs(delx),abs(dely),abs(delz)).gt.ERRTOL)goto 1 + e2=delx*dely-delz**2 + e3=delx*dely*delz + rf=(1.+(C1*e2-C2-C3*e3)*e2+C4*e3)/sqrt(ave) + return + END diff --git a/dataassim/math/numrec/f77_sources/rj.for b/dataassim/math/numrec/f77_sources/rj.for new file mode 100644 index 0000000..2482cad --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rj.for @@ -0,0 +1,56 @@ + FUNCTION rj(x,y,z,p) + REAL rj,p,x,y,z,ERRTOL,TINY,BIG,C1,C2,C3,C4,C5,C6,C7,C8 + PARAMETER (ERRTOL=.05,TINY=2.5e-13,BIG=9.E11,C1=3./14.,C2=1./3., + *C3=3./22.,C4=3./26.,C5=.75*C3,C6=1.5*C4,C7=.5*C2,C8=C3+C3) +CU USES rc,rf + REAL a,alamb,alpha,ave,b,beta,delp,delx,dely,delz,ea,eb,ec,ed,ee, + *fac,pt,rcx,rho,sqrtx,sqrty,sqrtz,sum,tau,xt,yt,zt,rc,rf + if(min(x,y,z).lt.0..or.min(x+y,x+z,y+z,abs(p)).lt.TINY.or.max(x,y, + *z,abs(p)).gt.BIG)pause 'invalid arguments in rj' + sum=0. + fac=1. + if(p.gt.0.)then + xt=x + yt=y + zt=z + pt=p + else + xt=min(x,y,z) + zt=max(x,y,z) + yt=x+y+z-xt-zt + a=1./(yt-p) + b=a*(zt-yt)*(yt-xt) + pt=yt+b + rho=xt*zt/yt + tau=p*pt/yt + rcx=rc(rho,tau) + endif +1 continue + sqrtx=sqrt(xt) + sqrty=sqrt(yt) + sqrtz=sqrt(zt) + alamb=sqrtx*(sqrty+sqrtz)+sqrty*sqrtz + alpha=(pt*(sqrtx+sqrty+sqrtz)+sqrtx*sqrty*sqrtz)**2 + beta=pt*(pt+alamb)**2 + sum=sum+fac*rc(alpha,beta) + fac=.25*fac + xt=.25*(xt+alamb) + yt=.25*(yt+alamb) + zt=.25*(zt+alamb) + pt=.25*(pt+alamb) + ave=.2*(xt+yt+zt+pt+pt) + delx=(ave-xt)/ave + dely=(ave-yt)/ave + delz=(ave-zt)/ave + delp=(ave-pt)/ave + if(max(abs(delx),abs(dely),abs(delz),abs(delp)).gt.ERRTOL)goto 1 + ea=delx*(dely+delz)+dely*delz + eb=delx*dely*delz + ec=delp**2 + ed=ea-3.*ec + ee=eb+2.*delp*(ea-ec) + rj=3.*sum+fac*(1.+ed*(-C1+C5*ed-C6*ee)+eb*(C7+delp*(-C8+delp*C4))+ + *delp*ea*(C2-delp*C3)-C2*delp*ec)/(ave*sqrt(ave)) + if (p.le.0.) rj=a*(b*rj+3.*(rcx-rf(xt,yt,zt))) + return + END diff --git a/dataassim/math/numrec/f77_sources/rk4.for b/dataassim/math/numrec/f77_sources/rk4.for new file mode 100644 index 0000000..a343fe3 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rk4.for @@ -0,0 +1,28 @@ + SUBROUTINE rk4(y,dydx,n,x,h,yout,derivs) + INTEGER n,NMAX + REAL h,x,dydx(n),y(n),yout(n) + EXTERNAL derivs + PARAMETER (NMAX=50) + INTEGER i + REAL h6,hh,xh,dym(NMAX),dyt(NMAX),yt(NMAX) + hh=h*0.5 + h6=h/6. + xh=x+hh + do 11 i=1,n + yt(i)=y(i)+hh*dydx(i) +11 continue + call derivs(xh,yt,dyt) + do 12 i=1,n + yt(i)=y(i)+hh*dyt(i) +12 continue + call derivs(xh,yt,dym) + do 13 i=1,n + yt(i)=y(i)+h*dym(i) + dym(i)=dyt(i)+dym(i) +13 continue + call derivs(x+h,yt,dyt) + do 14 i=1,n + yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i)) +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/rkck.for b/dataassim/math/numrec/f77_sources/rkck.for new file mode 100644 index 0000000..8faeeba --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rkck.for @@ -0,0 +1,47 @@ + SUBROUTINE rkck(y,dydx,n,x,h,yout,yerr,derivs) + INTEGER n,NMAX + REAL h,x,dydx(n),y(n),yerr(n),yout(n) + EXTERNAL derivs + PARAMETER (NMAX=50) +CU USES derivs + INTEGER i + REAL ak2(NMAX),ak3(NMAX),ak4(NMAX),ak5(NMAX),ak6(NMAX), + *ytemp(NMAX),A2,A3,A4,A5,A6,B21,B31,B32,B41,B42,B43,B51,B52,B53, + *B54,B61,B62,B63,B64,B65,C1,C3,C4,C6,DC1,DC3,DC4,DC5,DC6 + PARAMETER (A2=.2,A3=.3,A4=.6,A5=1.,A6=.875,B21=.2,B31=3./40., + *B32=9./40.,B41=.3,B42=-.9,B43=1.2,B51=-11./54.,B52=2.5, + *B53=-70./27.,B54=35./27.,B61=1631./55296.,B62=175./512., + *B63=575./13824.,B64=44275./110592.,B65=253./4096.,C1=37./378., + *C3=250./621.,C4=125./594.,C6=512./1771.,DC1=C1-2825./27648., + *DC3=C3-18575./48384.,DC4=C4-13525./55296.,DC5=-277./14336., + *DC6=C6-.25) + do 11 i=1,n + ytemp(i)=y(i)+B21*h*dydx(i) +11 continue + call derivs(x+A2*h,ytemp,ak2) + do 12 i=1,n + ytemp(i)=y(i)+h*(B31*dydx(i)+B32*ak2(i)) +12 continue + call derivs(x+A3*h,ytemp,ak3) + do 13 i=1,n + ytemp(i)=y(i)+h*(B41*dydx(i)+B42*ak2(i)+B43*ak3(i)) +13 continue + call derivs(x+A4*h,ytemp,ak4) + do 14 i=1,n + ytemp(i)=y(i)+h*(B51*dydx(i)+B52*ak2(i)+B53*ak3(i)+B54*ak4(i)) +14 continue + call derivs(x+A5*h,ytemp,ak5) + do 15 i=1,n + ytemp(i)=y(i)+h*(B61*dydx(i)+B62*ak2(i)+B63*ak3(i)+B64*ak4(i)+ + *B65*ak5(i)) +15 continue + call derivs(x+A6*h,ytemp,ak6) + do 16 i=1,n + yout(i)=y(i)+h*(C1*dydx(i)+C3*ak3(i)+C4*ak4(i)+C6*ak6(i)) +16 continue + do 17 i=1,n + yerr(i)=h*(DC1*dydx(i)+DC3*ak3(i)+DC4*ak4(i)+DC5*ak5(i)+DC6* + *ak6(i)) +17 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/rkdumb.for b/dataassim/math/numrec/f77_sources/rkdumb.for new file mode 100644 index 0000000..8c384fd --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rkdumb.for @@ -0,0 +1,28 @@ + SUBROUTINE rkdumb(vstart,nvar,x1,x2,nstep,derivs) + INTEGER nstep,nvar,NMAX,NSTPMX + PARAMETER (NMAX=50,NSTPMX=200) + REAL x1,x2,vstart(nvar),xx(NSTPMX),y(NMAX,NSTPMX) + EXTERNAL derivs + COMMON /path/ xx,y +CU USES rk4 + INTEGER i,k + REAL h,x,dv(NMAX),v(NMAX) + do 11 i=1,nvar + v(i)=vstart(i) + y(i,1)=v(i) +11 continue + xx(1)=x1 + x=x1 + h=(x2-x1)/nstep + do 13 k=1,nstep + call derivs(x,v,dv) + call rk4(v,dv,nvar,x,h,v,derivs) + if(x+h.eq.x)pause 'stepsize not significant in rkdumb' + x=x+h + xx(k+1)=x + do 12 i=1,nvar + y(i,k+1)=v(i) +12 continue +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/rkqs.for b/dataassim/math/numrec/f77_sources/rkqs.for new file mode 100644 index 0000000..3716104 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rkqs.for @@ -0,0 +1,37 @@ + SUBROUTINE rkqs(y,dydx,n,x,htry,eps,yscal,hdid,hnext,derivs) + INTEGER n,NMAX + REAL eps,hdid,hnext,htry,x,dydx(n),y(n),yscal(n) + EXTERNAL derivs + PARAMETER (NMAX=50) +CU USES derivs,rkck + INTEGER i + REAL errmax,h,htemp,xnew,yerr(NMAX),ytemp(NMAX),SAFETY,PGROW, + *PSHRNK,ERRCON + PARAMETER (SAFETY=0.9,PGROW=-.2,PSHRNK=-.25,ERRCON=1.89e-4) + h=htry +1 call rkck(y,dydx,n,x,h,ytemp,yerr,derivs) + errmax=0. + do 11 i=1,n + errmax=max(errmax,abs(yerr(i)/yscal(i))) +11 continue + errmax=errmax/eps + if(errmax.gt.1.)then + htemp=SAFETY*h*(errmax**PSHRNK) + h=sign(max(abs(htemp),0.1*abs(h)),h) + xnew=x+h + if(xnew.eq.x)pause 'stepsize underflow in rkqs' + goto 1 + else + if(errmax.gt.ERRCON)then + hnext=SAFETY*h*(errmax**PGROW) + else + hnext=5.*h + endif + hdid=h + x=x+h + do 12 i=1,n + y(i)=ytemp(i) +12 continue + return + endif + END diff --git a/dataassim/math/numrec/f77_sources/rlft3.for b/dataassim/math/numrec/f77_sources/rlft3.for new file mode 100644 index 0000000..5710cd2 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rlft3.for @@ -0,0 +1,56 @@ + SUBROUTINE rlft3(data,speq,nn1,nn2,nn3,isign) + INTEGER isign,nn1,nn2,nn3 + COMPLEX data(nn1/2,nn2,nn3),speq(nn2,nn3) +CU USES fourn + INTEGER i1,i2,i3,j1,j2,j3,nn(3) + DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp + COMPLEX c1,c2,h1,h2,w + c1=cmplx(0.5,0.0) + c2=cmplx(0.0,-0.5*isign) + theta=6.28318530717959d0/dble(isign*nn1) + wpr=-2.0d0*sin(0.5d0*theta)**2 + wpi=sin(theta) + nn(1)=nn1/2 + nn(2)=nn2 + nn(3)=nn3 + if(isign.eq.1)then + call fourn(data,nn,3,isign) + do 12 i3=1,nn3 + do 11 i2=1,nn2 + speq(i2,i3)=data(1,i2,i3) +11 continue +12 continue + endif + do 15 i3=1,nn3 + j3=1 + if (i3.ne.1) j3=nn3-i3+2 + wr=1.0d0 + wi=0.0d0 + do 14 i1=1,nn1/4+1 + j1=nn1/2-i1+2 + do 13 i2=1,nn2 + j2=1 + if (i2.ne.1) j2=nn2-i2+2 + if(i1.eq.1)then + h1=c1*(data(1,i2,i3)+conjg(speq(j2,j3))) + h2=c2*(data(1,i2,i3)-conjg(speq(j2,j3))) + data(1,i2,i3)=h1+h2 + speq(j2,j3)=conjg(h1-h2) + else + h1=c1*(data(i1,i2,i3)+conjg(data(j1,j2,j3))) + h2=c2*(data(i1,i2,i3)-conjg(data(j1,j2,j3))) + data(i1,i2,i3)=h1+w*h2 + data(j1,j2,j3)=conjg(h1-w*h2) + endif +13 continue + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi + w=cmplx(sngl(wr),sngl(wi)) +14 continue +15 continue + if(isign.eq.-1)then + call fourn(data,nn,3,isign) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/rlftfrag.for b/dataassim/math/numrec/f77_sources/rlftfrag.for new file mode 100644 index 0000000..4cf6ec7 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rlftfrag.for @@ -0,0 +1,47 @@ + PROGRAM exmpl1 + INTEGER N1,N2,N3 + PARAMETER (N1=256,N2=256,N3=1) +CU USES rlft3 + REAL data(N1,N2) + COMPLEX spec(N1/2,N2),speq(N2) + EQUIVALENCE (data,spec) +C ... + call rlft3(data,speq,N1,N2,N3,1) +C ... + call rlft3(data,speq,N1,N2,N3,-1) +C ... + END + PROGRAM exmpl2 + INTEGER N1,N2,N3 + PARAMETER (N1=32,N2=64,N3=16) +CU USES rlft3 + REAL data(N1,N2,N3) + COMPLEX spec(N1/2,N2,N3),speq(N2,N3) + EQUIVALENCE (data,spec) +C ... + call rlft3(data,speq,N1,N2,N3,1) +C ... + END + PROGRAM exmpl3 + INTEGER N + PARAMETER (N=32) +CU USES rlft3 + INTEGER j + REAL fac,data1(N,N,N),data2(N,N,N) + COMPLEX spec1(N/2,N,N),speq1(N,N),spec2(N/2,N,N),speq2(N,N), + *zpec1(N*N*N/2),zpeq1(N*N),zpec2(N*N*N/2),zpeq2(N*N) + EQUIVALENCE (data1,spec1,zpec1), (data2,spec2,zpec2),(speq1, + *zpeq1), (speq2,zpeq2) +C ... + call rlft3(data1,speq1,N,N,N,1) + call rlft3(data2,speq2,N,N,N,1) + fac=2./(N*N*N) + do 11 j=1,N*N*N/2 + zpec1(j)=fac*zpec1(j)*zpec2(j) +11 continue + do 12 j=1,N*N + zpeq1(j)=fac*zpeq1(j)*zpeq2(j) +12 continue + call rlft3(data1,speq1,N,N,N,-1) +C ... + END diff --git a/dataassim/math/numrec/f77_sources/rofunc.for b/dataassim/math/numrec/f77_sources/rofunc.for new file mode 100644 index 0000000..d0793b1 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rofunc.for @@ -0,0 +1,28 @@ + FUNCTION rofunc(b) + INTEGER NMAX + REAL rofunc,b,EPS + PARAMETER (NMAX=1000,EPS=1.e-7) +CU USES select + INTEGER j,ndata + REAL aa,abdev,d,sum,arr(NMAX),x(NMAX),y(NMAX),select + COMMON /arrays/ x,y,arr,aa,abdev,ndata + do 11 j=1,ndata + arr(j)=y(j)-b*x(j) +11 continue + if (mod(ndata,2).eq.0) then + j=ndata/2 + aa=0.5*(select(j,ndata,arr)+select(j+1,ndata,arr)) + else + aa=select((ndata+1)/2,ndata,arr) + endif + sum=0. + abdev=0. + do 12 j=1,ndata + d=y(j)-(b*x(j)+aa) + abdev=abdev+abs(d) + if (y(j).ne.0.) d=d/abs(y(j)) + if (abs(d).gt.EPS) sum=sum+x(j)*sign(1.0,d) +12 continue + rofunc=sum + return + END diff --git a/dataassim/math/numrec/f77_sources/rotate.for b/dataassim/math/numrec/f77_sources/rotate.for new file mode 100644 index 0000000..face441 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rotate.for @@ -0,0 +1,31 @@ + SUBROUTINE rotate(r,qt,n,np,i,a,b) + INTEGER n,np,i + REAL a,b,r(np,np),qt(np,np) + INTEGER j + REAL c,fact,s,w,y + if(a.eq.0.)then + c=0. + s=sign(1.,b) + else if(abs(a).gt.abs(b))then + fact=b/a + c=sign(1./sqrt(1.+fact**2),a) + s=fact*c + else + fact=a/b + s=sign(1./sqrt(1.+fact**2),b) + c=fact*s + endif + do 11 j=i,n + y=r(i,j) + w=r(i+1,j) + r(i,j)=c*y-s*w + r(i+1,j)=s*y+c*w +11 continue + do 12 j=1,n + y=qt(i,j) + w=qt(i+1,j) + qt(i,j)=c*y-s*w + qt(i+1,j)=s*y+c*w +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/rsolv.for b/dataassim/math/numrec/f77_sources/rsolv.for new file mode 100644 index 0000000..a8f2183 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rsolv.for @@ -0,0 +1,15 @@ + SUBROUTINE rsolv(a,n,np,d,b) + INTEGER n,np + REAL a(np,np),b(n),d(n) + INTEGER i,j + REAL sum + b(n)=b(n)/d(n) + do 12 i=n-1,1,-1 + sum=0. + do 11 j=i+1,n + sum=sum+a(i,j)*b(j) +11 continue + b(i)=(b(i)-sum)/d(i) +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/rstrct.for b/dataassim/math/numrec/f77_sources/rstrct.for new file mode 100644 index 0000000..8f8928a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rstrct.for @@ -0,0 +1,22 @@ + SUBROUTINE rstrct(uc,uf,nc) + INTEGER nc + DOUBLE PRECISION uc(nc,nc),uf(2*nc-1,2*nc-1) + INTEGER ic,if,jc,jf + do 12 jc=2,nc-1 + jf=2*jc-1 + do 11 ic=2,nc-1 + if=2*ic-1 + uc(ic,jc)=.5d0*uf(if,jf)+.125d0*(uf(if+1,jf)+uf(if-1,jf)+ + *uf(if,jf+1)+uf(if,jf-1)) +11 continue +12 continue + do 13 ic=1,nc + uc(ic,1)=uf(2*ic-1,1) + uc(ic,nc)=uf(2*ic-1,2*nc-1) +13 continue + do 14 jc=1,nc + uc(1,jc)=uf(1,2*jc-1) + uc(nc,jc)=uf(2*nc-1,2*jc-1) +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/rtbis.for b/dataassim/math/numrec/f77_sources/rtbis.for new file mode 100644 index 0000000..4393f60 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rtbis.for @@ -0,0 +1,26 @@ + FUNCTION rtbis(func,x1,x2,xacc) + INTEGER JMAX + REAL rtbis,x1,x2,xacc,func + EXTERNAL func + PARAMETER (JMAX=40) + INTEGER j + REAL dx,f,fmid,xmid + fmid=func(x2) + f=func(x1) + if(f*fmid.ge.0.) pause 'root must be bracketed in rtbis' + if(f.lt.0.)then + rtbis=x1 + dx=x2-x1 + else + rtbis=x2 + dx=x1-x2 + endif + do 11 j=1,JMAX + dx=dx*.5 + xmid=rtbis+dx + fmid=func(xmid) + if(fmid.le.0.)rtbis=xmid + if(abs(dx).lt.xacc .or. fmid.eq.0.) return +11 continue + pause 'too many bisections in rtbis' + END diff --git a/dataassim/math/numrec/f77_sources/rtflsp.for b/dataassim/math/numrec/f77_sources/rtflsp.for new file mode 100644 index 0000000..d332e1d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rtflsp.for @@ -0,0 +1,38 @@ + FUNCTION rtflsp(func,x1,x2,xacc) + INTEGER MAXIT + REAL rtflsp,x1,x2,xacc,func + EXTERNAL func + PARAMETER (MAXIT=30) + INTEGER j + REAL del,dx,f,fh,fl,swap,xh,xl + fl=func(x1) + fh=func(x2) + if(fl*fh.gt.0.) pause 'root must be bracketed in rtflsp' + if(fl.lt.0.)then + xl=x1 + xh=x2 + else + xl=x2 + xh=x1 + swap=fl + fl=fh + fh=swap + endif + dx=xh-xl + do 11 j=1,MAXIT + rtflsp=xl+dx*fl/(fl-fh) + f=func(rtflsp) + if(f.lt.0.) then + del=xl-rtflsp + xl=rtflsp + fl=f + else + del=xh-rtflsp + xh=rtflsp + fh=f + endif + dx=xh-xl + if(abs(del).lt.xacc.or.f.eq.0.)return +11 continue + pause 'rtflsp exceed maximum iterations' + END diff --git a/dataassim/math/numrec/f77_sources/rtnewt.for b/dataassim/math/numrec/f77_sources/rtnewt.for new file mode 100644 index 0000000..144506e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rtnewt.for @@ -0,0 +1,18 @@ + FUNCTION rtnewt(funcd,x1,x2,xacc) + INTEGER JMAX + REAL rtnewt,x1,x2,xacc + EXTERNAL funcd + PARAMETER (JMAX=20) + INTEGER j + REAL df,dx,f + rtnewt=.5*(x1+x2) + do 11 j=1,JMAX + call funcd(rtnewt,f,df) + dx=f/df + rtnewt=rtnewt-dx + if((x1-rtnewt)*(rtnewt-x2).lt.0.)pause + *'rtnewt jumped out of brackets' + if(abs(dx).lt.xacc) return +11 continue + pause 'rtnewt exceeded maximum iterations' + END diff --git a/dataassim/math/numrec/f77_sources/rtsafe.for b/dataassim/math/numrec/f77_sources/rtsafe.for new file mode 100644 index 0000000..4d55270 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rtsafe.for @@ -0,0 +1,53 @@ + FUNCTION rtsafe(funcd,x1,x2,xacc) + INTEGER MAXIT + REAL rtsafe,x1,x2,xacc + EXTERNAL funcd + PARAMETER (MAXIT=100) + INTEGER j + REAL df,dx,dxold,f,fh,fl,temp,xh,xl + call funcd(x1,fl,df) + call funcd(x2,fh,df) + if((fl.gt.0..and.fh.gt.0.).or.(fl.lt.0..and.fh.lt.0.))pause + *'root must be bracketed in rtsafe' + if(fl.eq.0.)then + rtsafe=x1 + return + else if(fh.eq.0.)then + rtsafe=x2 + return + else if(fl.lt.0.)then + xl=x1 + xh=x2 + else + xh=x1 + xl=x2 + endif + rtsafe=.5*(x1+x2) + dxold=abs(x2-x1) + dx=dxold + call funcd(rtsafe,f,df) + do 11 j=1,MAXIT + if(((rtsafe-xh)*df-f)*((rtsafe-xl)*df-f).ge.0..or. abs(2.* + *f).gt.abs(dxold*df) ) then + dxold=dx + dx=0.5*(xh-xl) + rtsafe=xl+dx + if(xl.eq.rtsafe)return + else + dxold=dx + dx=f/df + temp=rtsafe + rtsafe=rtsafe-dx + if(temp.eq.rtsafe)return + endif + if(abs(dx).lt.xacc) return + call funcd(rtsafe,f,df) + if(f.lt.0.) then + xl=rtsafe + else + xh=rtsafe + endif +11 continue + pause 'rtsafe exceeding maximum iterations' + return + END diff --git a/dataassim/math/numrec/f77_sources/rtsec.for b/dataassim/math/numrec/f77_sources/rtsec.for new file mode 100644 index 0000000..12da32c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rtsec.for @@ -0,0 +1,29 @@ + FUNCTION rtsec(func,x1,x2,xacc) + INTEGER MAXIT + REAL rtsec,x1,x2,xacc,func + EXTERNAL func + PARAMETER (MAXIT=30) + INTEGER j + REAL dx,f,fl,swap,xl + fl=func(x1) + f=func(x2) + if(abs(fl).lt.abs(f))then + rtsec=x1 + xl=x2 + swap=fl + fl=f + f=swap + else + xl=x1 + rtsec=x2 + endif + do 11 j=1,MAXIT + dx=(xl-rtsec)*f/(f-fl) + xl=rtsec + fl=f + rtsec=rtsec+dx + f=func(rtsec) + if(abs(dx).lt.xacc.or.f.eq.0.)return +11 continue + pause 'rtsec exceed maximum iterations' + END diff --git a/dataassim/math/numrec/f77_sources/rzextr.for b/dataassim/math/numrec/f77_sources/rzextr.for new file mode 100644 index 0000000..452744a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/rzextr.for @@ -0,0 +1,43 @@ + SUBROUTINE rzextr(iest,xest,yest,yz,dy,nv) + INTEGER iest,nv,IMAX,NMAX + REAL xest,dy(nv),yest(nv),yz(nv) + PARAMETER (IMAX=13,NMAX=50) + INTEGER j,k + REAL b,b1,c,ddy,v,yy,d(NMAX,IMAX),fx(IMAX),x(IMAX) + SAVE d,x + x(iest)=xest + if(iest.eq.1) then + do 11 j=1,nv + yz(j)=yest(j) + d(j,1)=yest(j) + dy(j)=yest(j) +11 continue + else + do 12 k=1,iest-1 + fx(k+1)=x(iest-k)/xest +12 continue + do 14 j=1,nv + yy=yest(j) + v=d(j,1) + c=yy + d(j,1)=yy + do 13 k=2,iest + b1=fx(k)*v + b=b1-c + if(b.ne.0.) then + b=(c-v)/b + ddy=c*b + c=b1*b + else + ddy=v + endif + if (k.ne.iest) v=d(j,k) + d(j,k)=ddy + yy=yy+ddy +13 continue + dy(j)=ddy + yz(j)=yy +14 continue + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/savgol.for b/dataassim/math/numrec/f77_sources/savgol.for new file mode 100644 index 0000000..7b945be --- /dev/null +++ b/dataassim/math/numrec/f77_sources/savgol.for @@ -0,0 +1,45 @@ + SUBROUTINE savgol(c,np,nl,nr,ld,m) + INTEGER ld,m,nl,np,nr,MMAX + REAL c(np) + PARAMETER (MMAX=6) +CU USES lubksb,ludcmp + INTEGER imj,ipj,j,k,kk,mm,indx(MMAX+1) + REAL d,fac,sum,a(MMAX+1,MMAX+1),b(MMAX+1) + if(np.lt.nl+nr+ + *1.or.nl.lt.0.or.nr.lt.0.or.ld.gt.m.or.m.gt.MMAX.or.nl+nr.lt.m) + *pause 'bad args in savgol' + do 14 ipj=0,2*m + sum=0. + if(ipj.eq.0)sum=1. + do 11 k=1,nr + sum=sum+float(k)**ipj +11 continue + do 12 k=1,nl + sum=sum+float(-k)**ipj +12 continue + mm=min(ipj,2*m-ipj) + do 13 imj=-mm,mm,2 + a(1+(ipj+imj)/2,1+(ipj-imj)/2)=sum +13 continue +14 continue + call ludcmp(a,m+1,MMAX+1,indx,d) + do 15 j=1,m+1 + b(j)=0. +15 continue + b(ld+1)=1. + call lubksb(a,m+1,MMAX+1,indx,b) + do 16 kk=1,np + c(kk)=0. +16 continue + do 18 k=-nl,nr + sum=b(1) + fac=1. + do 17 mm=1,m + fac=fac*k + sum=sum+b(mm+1)*fac +17 continue + kk=mod(np-k,np)+1 + c(kk)=sum +18 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/scrsho.for b/dataassim/math/numrec/f77_sources/scrsho.for new file mode 100644 index 0000000..27942bc --- /dev/null +++ b/dataassim/math/numrec/f77_sources/scrsho.for @@ -0,0 +1,51 @@ + SUBROUTINE scrsho(fx) + INTEGER ISCR,JSCR + REAL fx + EXTERNAL fx + PARAMETER (ISCR=60,JSCR=21) + INTEGER i,j,jz + REAL dx,dyj,x,x1,x2,ybig,ysml,y(ISCR) + CHARACTER*1 scr(ISCR,JSCR),blank,zero,yy,xx,ff + SAVE blank,zero,yy,xx,ff + DATA blank,zero,yy,xx,ff/' ','-','l','-','x'/ +1 continue + write (*,*) ' Enter x1,x2 (= to stop)' + read (*,*) x1,x2 + if(x1.eq.x2) return + do 11 j=1,JSCR + scr(1,j)=yy + scr(ISCR,j)=yy +11 continue + do 13 i=2,ISCR-1 + scr(i,1)=xx + scr(i,JSCR)=xx + do 12 j=2,JSCR-1 + scr(i,j)=blank +12 continue +13 continue + dx=(x2-x1)/(ISCR-1) + x=x1 + ybig=0. + ysml=ybig + do 14 i=1,ISCR + y(i)=fx(x) + if(y(i).lt.ysml) ysml=y(i) + if(y(i).gt.ybig) ybig=y(i) + x=x+dx +14 continue + if(ybig.eq.ysml) ybig=ysml+1. + dyj=(JSCR-1)/(ybig-ysml) + jz=1-ysml*dyj + do 15 i=1,ISCR + scr(i,jz)=zero + j=1+(y(i)-ysml)*dyj + scr(i,j)=ff +15 continue + write (*,'(1x,1pe10.3,1x,80a1)') ybig,(scr(i,JSCR),i=1,ISCR) + do 16 j=JSCR-1,2,-1 + write (*,'(12x,80a1)') (scr(i,j),i=1,ISCR) +16 continue + write (*,'(1x,1pe10.3,1x,80a1)') ysml,(scr(i,1),i=1,ISCR) + write (*,'(12x,1pe10.3,40x,e10.3)') x1,x2 + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/select.for b/dataassim/math/numrec/f77_sources/select.for new file mode 100644 index 0000000..71e4ec4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/select.for @@ -0,0 +1,58 @@ + FUNCTION select(k,n,arr) + INTEGER k,n + REAL select,arr(n) + INTEGER i,ir,j,l,mid + REAL a,temp + l=1 + ir=n +1 if(ir-l.le.1)then + if(ir-l.eq.1)then + if(arr(ir).lt.arr(l))then + temp=arr(l) + arr(l)=arr(ir) + arr(ir)=temp + endif + endif + select=arr(k) + return + else + mid=(l+ir)/2 + temp=arr(mid) + arr(mid)=arr(l+1) + arr(l+1)=temp + if(arr(l).gt.arr(ir))then + temp=arr(l) + arr(l)=arr(ir) + arr(ir)=temp + endif + if(arr(l+1).gt.arr(ir))then + temp=arr(l+1) + arr(l+1)=arr(ir) + arr(ir)=temp + endif + if(arr(l).gt.arr(l+1))then + temp=arr(l) + arr(l)=arr(l+1) + arr(l+1)=temp + endif + i=l+1 + j=ir + a=arr(l+1) +3 continue + i=i+1 + if(arr(i).lt.a)goto 3 +4 continue + j=j-1 + if(arr(j).gt.a)goto 4 + if(j.lt.i)goto 5 + temp=arr(i) + arr(i)=arr(j) + arr(j)=temp + goto 3 +5 arr(l+1)=arr(j) + arr(j)=a + if(j.ge.k)ir=j-1 + if(j.le.k)l=i + endif + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/selip.for b/dataassim/math/numrec/f77_sources/selip.for new file mode 100644 index 0000000..8cd4fb9 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/selip.for @@ -0,0 +1,69 @@ + FUNCTION selip(k,n,arr) + INTEGER k,n,M + REAL selip,arr(n),BIG + PARAMETER (M=64,BIG=1.E30) +CU USES shell + INTEGER i,j,jl,jm,ju,kk,mm,nlo,nxtmm,isel(M+2) + REAL ahi,alo,sum,sel(M+2) + if(k.lt.1.or.k.gt.n.or.n.le.0) pause 'bad input to selip' + kk=k + ahi=BIG + alo=-BIG +1 continue + mm=0 + nlo=0 + sum=0. + nxtmm=M+1 + do 11 i=1,n + if(arr(i).ge.alo.and.arr(i).le.ahi)then + mm=mm+1 + if(arr(i).eq.alo) nlo=nlo+1 + if(mm.le.M)then + sel(mm)=arr(i) + else if(mm.eq.nxtmm)then + nxtmm=mm+mm/M + sel(1+mod(i+mm+kk,M))=arr(i) + endif + sum=sum+arr(i) + endif +11 continue + if(kk.le.nlo)then + selip=alo + return + else if(mm.le.M)then + call shell(mm,sel) + selip=sel(kk) + return + endif + sel(M+1)=sum/mm + call shell(M+1,sel) + sel(M+2)=ahi + do 12 j=1,M+2 + isel(j)=0 +12 continue + do 13 i=1,n + if(arr(i).ge.alo.and.arr(i).le.ahi)then + jl=0 + ju=M+2 +2 if(ju-jl.gt.1)then + jm=(ju+jl)/2 + if(arr(i).ge.sel(jm))then + jl=jm + else + ju=jm + endif + goto 2 + endif + isel(ju)=isel(ju)+1 + endif +13 continue + j=1 +3 if(kk.gt.isel(j))then + alo=sel(j) + kk=kk-isel(j) + j=j+1 + goto 3 + endif + ahi=sel(j) + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/sfroid.for b/dataassim/math/numrec/f77_sources/sfroid.for new file mode 100644 index 0000000..819699b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sfroid.for @@ -0,0 +1,60 @@ + PROGRAM sfroid + INTEGER NE,M,NB,NCI,NCJ,NCK,NSI,NSJ,NYJ,NYK + COMMON /sfrcom/ x,h,mm,n,c2,anorm + PARAMETER (NE=3,M=41,NB=1,NCI=NE,NCJ=NE-NB+1,NCK=M+1,NSI=NE,NSJ=2* + *NE+1,NYJ=NE,NYK=M) +CU USES plgndr,solvde + INTEGER i,itmax,k,mm,n,indexv(NE) + REAL anorm,c2,conv,deriv,fac1,fac2,h,q1,slowc,c(NCI,NCJ,NCK), + *s(NSI,NSJ),scalv(NE),x(M),y(NE,M),plgndr + itmax=100 + conv=5.e-6 + slowc=1. + h=1./(M-1) + c2=0. + write(*,*)'ENTER M,N' + read(*,*)mm,n + if(mod(n+mm,2).eq.1)then + indexv(1)=1 + indexv(2)=2 + indexv(3)=3 + else + indexv(1)=2 + indexv(2)=1 + indexv(3)=3 + endif + anorm=1. + if(mm.NE.0)then + q1=n + do 11 i=1,mm + anorm=-.5*anorm*(n+i)*(q1/i) + q1=q1-1. +11 continue + endif + do 12 k=1,M-1 + x(k)=(k-1)*h + fac1=1.-x(k)**2 + fac2=fac1**(-mm/2.) + y(1,k)=plgndr(n,mm,x(k))*fac2 + deriv=-((n-mm+1)*plgndr(n+1,mm,x(k))-(n+1)*x(k)*plgndr(n,mm, + *x(k)))/fac1 + y(2,k)=mm*x(k)*y(1,k)/fac1+deriv*fac2 + y(3,k)=n*(n+1)-mm*(mm+1) +12 continue + x(M)=1. + y(1,M)=anorm + y(3,M)=n*(n+1)-mm*(mm+1) + y(2,M)=(y(3,M)-c2)*y(1,M)/(2.*(mm+1.)) + scalv(1)=abs(anorm) + scalv(2)=max(abs(anorm),y(2,M)) + scalv(3)=max(1.,y(3,M)) +1 continue + write (*,*) 'ENTER C**2 OR 999 TO END' + read (*,*) c2 + if (c2.eq.999.) stop + call solvde(itmax,conv,slowc,scalv,indexv,NE,NB,M,y,NYJ,NYK,c,NCI, + *NCJ,NCK,s,NSI,NSJ) + write (*,*) ' M = ',mm,' N = ',n,' C**2 = ',c2,' LAMBDA = ', + *y(3,1)+mm*(mm+1) + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/shell.for b/dataassim/math/numrec/f77_sources/shell.for new file mode 100644 index 0000000..7d9cda4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/shell.for @@ -0,0 +1,24 @@ + SUBROUTINE shell(n,a) + INTEGER n + REAL a(n) + INTEGER i,j,inc + REAL v + inc=1 +1 inc=3*inc+1 + if(inc.le.n)goto 1 +2 continue + inc=inc/3 + do 11 i=inc+1,n + v=a(i) + j=i +3 if(a(j-inc).gt.v)then + a(j)=a(j-inc) + j=j-inc + if(j.le.inc)goto 4 + goto 3 + endif +4 a(j)=v +11 continue + if(inc.gt.1)goto 2 + return + END diff --git a/dataassim/math/numrec/f77_sources/shoot.for b/dataassim/math/numrec/f77_sources/shoot.for new file mode 100644 index 0000000..ab9ac40 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/shoot.for @@ -0,0 +1,19 @@ +CU SUBROUTINE shoot(n2,v,f) is named "funcv" for use with "newt" + SUBROUTINE funcv(n2,v,f) + INTEGER n2,nvar,kmax,kount,KMAXX,NMAX + REAL f(n2),v(n2),x1,x2,dxsav,xp,yp,EPS + PARAMETER (NMAX=50,KMAXX=200,EPS=1.e-6) + COMMON /caller/ x1,x2,nvar + COMMON /path/ kmax,kount,dxsav,xp(KMAXX),yp(NMAX,KMAXX) +CU USES derivs,load,odeint,rkqs,score + INTEGER nbad,nok + REAL h1,hmin,y(NMAX) + EXTERNAL derivs,rkqs + kmax=0 + h1=(x2-x1)/100. + hmin=0. + call load(x1,v,y) + call odeint(y,nvar,x1,x2,EPS,h1,hmin,nok,nbad,derivs,rkqs) + call score(x2,y,f) + return + END diff --git a/dataassim/math/numrec/f77_sources/shootf.for b/dataassim/math/numrec/f77_sources/shootf.for new file mode 100644 index 0000000..96c4d1f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/shootf.for @@ -0,0 +1,25 @@ +CU SUBROUTINE shootf(n,v,f) is named "funcv" for use with "newt" + SUBROUTINE funcv(n,v,f) + INTEGER n,nvar,nn2,kmax,kount,KMAXX,NMAX + REAL f(n),v(n),x1,x2,xf,dxsav,xp,yp,EPS + PARAMETER (NMAX=50,KMAXX=200,EPS=1.e-6) + COMMON /caller/ x1,x2,xf,nvar,nn2 + COMMON /path/ kmax,kount,dxsav,xp(KMAXX),yp(NMAX,KMAXX) +CU USES derivs,load1,load2,odeint,rkqs,score + INTEGER i,nbad,nok + REAL h1,hmin,f1(NMAX),f2(NMAX),y(NMAX) + EXTERNAL derivs,rkqs + kmax=0 + h1=(x2-x1)/100. + hmin=0. + call load1(x1,v,y) + call odeint(y,nvar,x1,xf,EPS,h1,hmin,nok,nbad,derivs,rkqs) + call score(xf,y,f1) + call load2(x2,v(nn2+1),y) + call odeint(y,nvar,x2,xf,EPS,h1,hmin,nok,nbad,derivs,rkqs) + call score(xf,y,f2) + do 11 i=1,n + f(i)=f1(i)-f2(i) +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/simp1.for b/dataassim/math/numrec/f77_sources/simp1.for new file mode 100644 index 0000000..1bffabb --- /dev/null +++ b/dataassim/math/numrec/f77_sources/simp1.for @@ -0,0 +1,20 @@ + SUBROUTINE simp1(a,mp,np,mm,ll,nll,iabf,kp,bmax) + INTEGER iabf,kp,mm,mp,nll,np,ll(np) + REAL bmax,a(mp,np) + INTEGER k + REAL test + kp=ll(1) + bmax=a(mm+1,kp+1) + do 11 k=2,nll + if(iabf.eq.0)then + test=a(mm+1,ll(k)+1)-bmax + else + test=abs(a(mm+1,ll(k)+1))-abs(bmax) + endif + if(test.gt.0.)then + bmax=a(mm+1,ll(k)+1) + kp=ll(k) + endif +11 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/simp2.for b/dataassim/math/numrec/f77_sources/simp2.for new file mode 100644 index 0000000..707f05d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/simp2.for @@ -0,0 +1,32 @@ + SUBROUTINE simp2(a,m,n,mp,np,l2,nl2,ip,kp,q1) + INTEGER ip,kp,m,mp,n,nl2,np,l2(mp) + REAL q1,a(mp,np),EPS + PARAMETER (EPS=1.e-6) + INTEGER i,ii,k + REAL q,q0,qp + ip=0 + do 11 i=1,nl2 + if(a(l2(i)+1,kp+1).lt.-EPS)goto 1 +11 continue + return +1 q1=-a(l2(i)+1,1)/a(l2(i)+1,kp+1) + ip=l2(i) + do 13 i=i+1,nl2 + ii=l2(i) + if(a(ii+1,kp+1).lt.-EPS)then + q=-a(ii+1,1)/a(ii+1,kp+1) + if(q.lt.q1)then + ip=ii + q1=q + else if (q.eq.q1) then + do 12 k=1,n + qp=-a(ip+1,k+1)/a(ip+1,kp+1) + q0=-a(ii+1,k+1)/a(ii+1,kp+1) + if(q0.ne.qp)goto 2 +12 continue +2 if(q0.lt.qp)ip=ii + endif + endif +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/simp3.for b/dataassim/math/numrec/f77_sources/simp3.for new file mode 100644 index 0000000..b9b34a4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/simp3.for @@ -0,0 +1,22 @@ + SUBROUTINE simp3(a,mp,np,i1,k1,ip,kp) + INTEGER i1,ip,k1,kp,mp,np + REAL a(mp,np) + INTEGER ii,kk + REAL piv + piv=1./a(ip+1,kp+1) + do 12 ii=1,i1+1 + if(ii-1.ne.ip)then + a(ii,kp+1)=a(ii,kp+1)*piv + do 11 kk=1,k1+1 + if(kk-1.ne.kp)then + a(ii,kk)=a(ii,kk)-a(ip+1,kk)*a(ii,kp+1) + endif +11 continue + endif +12 continue + do 13 kk=1,k1+1 + if(kk-1.ne.kp)a(ip+1,kk)=-a(ip+1,kk)*piv +13 continue + a(ip+1,kp+1)=piv + return + END diff --git a/dataassim/math/numrec/f77_sources/simplx.for b/dataassim/math/numrec/f77_sources/simplx.for new file mode 100644 index 0000000..c089a2f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/simplx.for @@ -0,0 +1,96 @@ + SUBROUTINE simplx(a,m,n,mp,np,m1,m2,m3,icase,izrov,iposv) + INTEGER icase,m,m1,m2,m3,mp,n,np,iposv(m),izrov(n),MMAX,NMAX + REAL a(mp,np),EPS + PARAMETER (MMAX=100,NMAX=100,EPS=1.e-6) +CU USES simp1,simp2,simp3 + INTEGER i,ip,ir,is,k,kh,kp,m12,nl1,nl2,l1(NMAX),l2(MMAX),l3(MMAX) + REAL bmax,q1 + if(m.ne.m1+m2+m3)pause 'bad input constraint counts in simplx' + nl1=n + do 11 k=1,n + l1(k)=k + izrov(k)=k +11 continue + nl2=m + do 12 i=1,m + if(a(i+1,1).lt.0.)pause 'bad input tableau in simplx' + l2(i)=i + iposv(i)=n+i +12 continue + do 13 i=1,m2 + l3(i)=1 +13 continue + ir=0 + if(m2+m3.eq.0)goto 30 + ir=1 + do 15 k=1,n+1 + q1=0. + do 14 i=m1+1,m + q1=q1+a(i+1,k) +14 continue + a(m+2,k)=-q1 +15 continue +10 call simp1(a,mp,np,m+1,l1,nl1,0,kp,bmax) + if(bmax.le.EPS.and.a(m+2,1).lt.-EPS)then + icase=-1 + return + else if(bmax.le.EPS.and.a(m+2,1).le.EPS)then + m12=m1+m2+1 + do 16 ip=m12,m + if(iposv(ip).eq.ip+n)then + call simp1(a,mp,np,ip,l1,nl1,1,kp,bmax) + if(bmax.gt.0.)goto 1 + endif +16 continue + ir=0 + m12=m12-1 + do 18 i=m1+1,m12 + if(l3(i-m1).eq.1)then + do 17 k=1,n+1 + a(i+1,k)=-a(i+1,k) +17 continue + endif +18 continue + goto 30 + endif + call simp2(a,m,n,mp,np,l2,nl2,ip,kp,q1) + if(ip.eq.0)then + icase=-1 + return + endif +1 call simp3(a,mp,np,m+1,n,ip,kp) + if(iposv(ip).ge.n+m1+m2+1)then + do 19 k=1,nl1 + if(l1(k).eq.kp)goto 2 +19 continue +2 nl1=nl1-1 + do 21 is=k,nl1 + l1(is)=l1(is+1) +21 continue + else + if(iposv(ip).lt.n+m1+1)goto 20 + kh=iposv(ip)-m1-n + if(l3(kh).eq.0)goto 20 + l3(kh)=0 + endif + a(m+2,kp+1)=a(m+2,kp+1)+1. + do 22 i=1,m+2 + a(i,kp+1)=-a(i,kp+1) +22 continue +20 is=izrov(kp) + izrov(kp)=iposv(ip) + iposv(ip)=is + if(ir.ne.0)goto 10 +30 call simp1(a,mp,np,0,l1,nl1,0,kp,bmax) + if(bmax.le.0.)then + icase=0 + return + endif + call simp2(a,m,n,mp,np,l2,nl2,ip,kp,q1) + if(ip.eq.0)then + icase=1 + return + endif + call simp3(a,mp,np,m,n,ip,kp) + goto 20 + END diff --git a/dataassim/math/numrec/f77_sources/simpr.for b/dataassim/math/numrec/f77_sources/simpr.for new file mode 100644 index 0000000..27fe288 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/simpr.for @@ -0,0 +1,48 @@ + SUBROUTINE simpr(y,dydx,dfdx,dfdy,nmax,n,xs,htot,nstep,yout, + *derivs) + INTEGER n,nmax,nstep,NMAXX + REAL htot,xs,dfdx(n),dfdy(nmax,nmax),dydx(n),y(n),yout(n) + EXTERNAL derivs + PARAMETER (NMAXX=50) +CU USES derivs,lubksb,ludcmp + INTEGER i,j,nn,indx(NMAXX) + REAL d,h,x,a(NMAXX,NMAXX),del(NMAXX),ytemp(NMAXX) + h=htot/nstep + do 12 i=1,n + do 11 j=1,n + a(i,j)=-h*dfdy(i,j) +11 continue + a(i,i)=a(i,i)+1. +12 continue + call ludcmp(a,n,NMAXX,indx,d) + do 13 i=1,n + yout(i)=h*(dydx(i)+h*dfdx(i)) +13 continue + call lubksb(a,n,NMAXX,indx,yout) + do 14 i=1,n + del(i)=yout(i) + ytemp(i)=y(i)+del(i) +14 continue + x=xs+h + call derivs(x,ytemp,yout) + do 17 nn=2,nstep + do 15 i=1,n + yout(i)=h*yout(i)-del(i) +15 continue + call lubksb(a,n,NMAXX,indx,yout) + do 16 i=1,n + del(i)=del(i)+2.*yout(i) + ytemp(i)=ytemp(i)+del(i) +16 continue + x=x+h + call derivs(x,ytemp,yout) +17 continue + do 18 i=1,n + yout(i)=h*yout(i)-del(i) +18 continue + call lubksb(a,n,NMAXX,indx,yout) + do 19 i=1,n + yout(i)=ytemp(i)+yout(i) +19 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/sinft.for b/dataassim/math/numrec/f77_sources/sinft.for new file mode 100644 index 0000000..1125c6a --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sinft.for @@ -0,0 +1,33 @@ + SUBROUTINE sinft(y,n) + INTEGER n + REAL y(n) +CU USES realft + INTEGER j + REAL sum,y1,y2 + DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp + theta=3.141592653589793d0/dble(n) + wr=1.0d0 + wi=0.0d0 + wpr=-2.0d0*sin(0.5d0*theta)**2 + wpi=sin(theta) + y(1)=0.0 + do 11 j=1,n/2 + wtemp=wr + wr=wr*wpr-wi*wpi+wr + wi=wi*wpr+wtemp*wpi+wi + y1=wi*(y(j+1)+y(n-j+1)) + y2=0.5*(y(j+1)-y(n-j+1)) + y(j+1)=y1+y2 + y(n-j+1)=y1-y2 +11 continue + call realft(y,n,+1) + sum=0.0 + y(1)=0.5*y(1) + y(2)=0.0 + do 12 j=1,n-1,2 + sum=sum+y(j) + y(j)=y(j+1) + y(j+1)=sum +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/slvsm2.for b/dataassim/math/numrec/f77_sources/slvsm2.for new file mode 100644 index 0000000..4348497 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/slvsm2.for @@ -0,0 +1,11 @@ + SUBROUTINE slvsm2(u,rhs) + DOUBLE PRECISION rhs(3,3),u(3,3) +CU USES fill0 + DOUBLE PRECISION disc,fact,h + call fill0(u,3) + h=.5d0 + fact=2./h**2 + disc=sqrt(fact**2+rhs(2,2)) + u(2,2)=-rhs(2,2)/(fact+disc) + return + END diff --git a/dataassim/math/numrec/f77_sources/slvsml.for b/dataassim/math/numrec/f77_sources/slvsml.for new file mode 100644 index 0000000..4e80d20 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/slvsml.for @@ -0,0 +1,9 @@ + SUBROUTINE slvsml(u,rhs) + DOUBLE PRECISION rhs(3,3),u(3,3) +CU USES fill0 + DOUBLE PRECISION h + call fill0(u,3) + h=.5d0 + u(2,2)=-h*h*rhs(2,2)/4.d0 + return + END diff --git a/dataassim/math/numrec/f77_sources/sncndn.for b/dataassim/math/numrec/f77_sources/sncndn.for new file mode 100644 index 0000000..9917703 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sncndn.for @@ -0,0 +1,61 @@ + SUBROUTINE sncndn(uu,emmc,sn,cn,dn) + REAL cn,dn,emmc,sn,uu,CA + PARAMETER (CA=.0003) + INTEGER i,ii,l + REAL a,b,c,d,emc,u,em(13),en(13) + LOGICAL bo + emc=emmc + u=uu + if(emc.ne.0.)then + bo=(emc.lt.0.) + if(bo)then + d=1.-emc + emc=-emc/d + d=sqrt(d) + u=d*u + endif + a=1. + dn=1. + do 11 i=1,13 + l=i + em(i)=a + emc=sqrt(emc) + en(i)=emc + c=0.5*(a+emc) + if(abs(a-emc).le.CA*a)goto 1 + emc=a*emc + a=c +11 continue +1 u=c*u + sn=sin(u) + cn=cos(u) + if(sn.eq.0.)goto 2 + a=cn/sn + c=a*c + do 12 ii=l,1,-1 + b=em(ii) + a=c*a + c=dn*c + dn=(en(ii)+a)/(b+a) + a=c/b +12 continue + a=1./sqrt(c**2+1.) + if(sn.lt.0.)then + sn=-a + else + sn=a + endif + cn=c*sn +2 if(bo)then + a=dn + dn=cn + cn=a + sn=sn/d + endif + else + cn=1./cosh(u) + dn=cn + sn=tanh(u) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/snrm.for b/dataassim/math/numrec/f77_sources/snrm.for new file mode 100644 index 0000000..c515c9b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/snrm.for @@ -0,0 +1,18 @@ + FUNCTION snrm(n,sx,itol) + INTEGER n,itol,i,isamax + DOUBLE PRECISION sx(n),snrm + if (itol.le.3)then + snrm=0. + do 11 i=1,n + snrm=snrm+sx(i)**2 +11 continue + snrm=sqrt(snrm) + else + isamax=1 + do 12 i=1,n + if(abs(sx(i)).gt.abs(sx(isamax))) isamax=i +12 continue + snrm=abs(sx(isamax)) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/sobseq.for b/dataassim/math/numrec/f77_sources/sobseq.for new file mode 100644 index 0000000..c6baab8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sobseq.for @@ -0,0 +1,49 @@ + SUBROUTINE sobseq(n,x) + INTEGER n,MAXBIT,MAXDIM + REAL x(*) + PARAMETER (MAXBIT=30,MAXDIM=6) + INTEGER i,im,in,ipp,j,k,l,ip(MAXDIM),iu(MAXDIM,MAXBIT),iv(MAXBIT* + *MAXDIM),ix(MAXDIM),mdeg(MAXDIM) + REAL fac + SAVE ip,mdeg,ix,iv,in,fac + EQUIVALENCE (iv,iu) + DATA ip /0,1,1,2,1,4/, mdeg /1,2,3,3,4,4/, ix /6*0/ + DATA iv /6*1,3,1,3,3,1,1,5,7,7,3,3,5,15,11,5,15,13,9,156*0/ + if (n.lt.0) then + do 11 k=1,MAXDIM + ix(k)=0 +11 continue + in=0 + if(iv(1).ne.1)return + fac=1./2.**MAXBIT + do 15 k=1,MAXDIM + do 12 j=1,mdeg(k) + iu(k,j)=iu(k,j)*2**(MAXBIT-j) +12 continue + do 14 j=mdeg(k)+1,MAXBIT + ipp=ip(k) + i=iu(k,j-mdeg(k)) + i=ieor(i,i/2**mdeg(k)) + do 13 l=mdeg(k)-1,1,-1 + if(iand(ipp,1).ne.0)i=ieor(i,iu(k,j-l)) + ipp=ipp/2 +13 continue + iu(k,j)=i +14 continue +15 continue + else + im=in + do 16 j=1,MAXBIT + if(iand(im,1).eq.0)goto 1 + im=im/2 +16 continue + pause 'MAXBIT too small in sobseq' +1 im=(j-1)*MAXDIM + do 17 k=1,min(n,MAXDIM) + ix(k)=ieor(ix(k),iv(im+k)) + x(k)=ix(k)*fac +17 continue + in=in+1 + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/solvde.for b/dataassim/math/numrec/f77_sources/solvde.for new file mode 100644 index 0000000..c090fab --- /dev/null +++ b/dataassim/math/numrec/f77_sources/solvde.for @@ -0,0 +1,77 @@ + SUBROUTINE solvde(itmax,conv,slowc,scalv,indexv,ne,nb,m,y,nyj,nyk, + *c,nci,ncj,nck,s,nsi,nsj) + INTEGER itmax,m,nb,nci,ncj,nck,ne,nsi,nsj,nyj,nyk,indexv(nyj),NMAX + REAL conv,slowc,c(nci,ncj,nck),s(nsi,nsj),scalv(nyj),y(nyj,nyk) + PARAMETER (NMAX=10) +CU USES bksub,difeq,pinvs,red + INTEGER ic1,ic2,ic3,ic4,it,j,j1,j2,j3,j4,j5,j6,j7,j8,j9,jc1,jcf, + *jv,k,k1,k2,km,kp,nvars,kmax(NMAX) + REAL err,errj,fac,vmax,vz,ermax(NMAX) + k1=1 + k2=m + nvars=ne*m + j1=1 + j2=nb + j3=nb+1 + j4=ne + j5=j4+j1 + j6=j4+j2 + j7=j4+j3 + j8=j4+j4 + j9=j8+j1 + ic1=1 + ic2=ne-nb + ic3=ic2+1 + ic4=ne + jc1=1 + jcf=ic3 + do 16 it=1,itmax + k=k1 + call difeq(k,k1,k2,j9,ic3,ic4,indexv,ne,s,nsi,nsj,y,nyj,nyk) + call pinvs(ic3,ic4,j5,j9,jc1,k1,c,nci,ncj,nck,s,nsi,nsj) + do 11 k=k1+1,k2 + kp=k-1 + call difeq(k,k1,k2,j9,ic1,ic4,indexv,ne,s,nsi,nsj,y,nyj,nyk) + call red(ic1,ic4,j1,j2,j3,j4,j9,ic3,jc1,jcf,kp,c,nci,ncj,nck, + *s,nsi,nsj) + call pinvs(ic1,ic4,j3,j9,jc1,k,c,nci,ncj,nck,s,nsi,nsj) +11 continue + k=k2+1 + call difeq(k,k1,k2,j9,ic1,ic2,indexv,ne,s,nsi,nsj,y,nyj,nyk) + call red(ic1,ic2,j5,j6,j7,j8,j9,ic3,jc1,jcf,k2,c,nci,ncj,nck,s, + *nsi,nsj) + call pinvs(ic1,ic2,j7,j9,jcf,k2+1,c,nci,ncj,nck,s,nsi,nsj) + call bksub(ne,nb,jcf,k1,k2,c,nci,ncj,nck) + err=0. + do 13 j=1,ne + jv=indexv(j) + errj=0. + km=0 + vmax=0. + do 12 k=k1,k2 + vz=abs(c(jv,1,k)) + if(vz.gt.vmax) then + vmax=vz + km=k + endif + errj=errj+vz +12 continue + err=err+errj/scalv(j) + ermax(j)=c(jv,1,km)/scalv(j) + kmax(j)=km +13 continue + err=err/nvars + fac=slowc/max(slowc,err) + do 15 j=1,ne + jv=indexv(j) + do 14 k=k1,k2 + y(j,k)=y(j,k)-fac*c(jv,1,k) +14 continue +15 continue + write(*,100) it,err,fac + if(err.lt.conv) return +16 continue + pause 'itmax exceeded in solvde' +100 format(1x,i4,2f12.6) + return + END diff --git a/dataassim/math/numrec/f77_sources/sor.for b/dataassim/math/numrec/f77_sources/sor.for new file mode 100644 index 0000000..3e49fa3 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sor.for @@ -0,0 +1,39 @@ + SUBROUTINE sor(a,b,c,d,e,f,u,jmax,rjac) + INTEGER jmax,MAXITS + DOUBLE PRECISION rjac,a(jmax,jmax),b(jmax,jmax),c(jmax,jmax), + *d(jmax,jmax),e(jmax,jmax),f(jmax,jmax),u(jmax,jmax),EPS + PARAMETER (MAXITS=1000,EPS=1.d-5) + INTEGER ipass,j,jsw,l,lsw,n + DOUBLE PRECISION anorm,anormf,omega,resid + anormf=0.d0 + do 12 j=2,jmax-1 + do 11 l=2,jmax-1 + anormf=anormf+abs(f(j,l)) +11 continue +12 continue + omega=1.d0 + do 16 n=1,MAXITS + anorm=0.d0 + jsw=1 + do 15 ipass=1,2 + lsw=jsw + do 14 j=2,jmax-1 + do 13 l=lsw+1,jmax-1,2 + resid=a(j,l)*u(j+1,l)+b(j,l)*u(j-1,l)+c(j,l)*u(j,l+1)+d(j, + *l)*u(j,l-1)+e(j,l)*u(j,l)-f(j,l) + anorm=anorm+abs(resid) + u(j,l)=u(j,l)-omega*resid/e(j,l) +13 continue + lsw=3-lsw +14 continue + jsw=3-jsw + if(n.eq.1.and.ipass.eq.1) then + omega=1.d0/(1.d0-.5d0*rjac**2) + else + omega=1.d0/(1.d0-.25d0*rjac**2*omega) + endif +15 continue + if(anorm.lt.EPS*anormf)return +16 continue + pause 'MAXITS exceeded in sor' + END diff --git a/dataassim/math/numrec/f77_sources/sort.for b/dataassim/math/numrec/f77_sources/sort.for new file mode 100644 index 0000000..0f31bc8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sort.for @@ -0,0 +1,73 @@ + SUBROUTINE sort(n,arr) + INTEGER n,M,NSTACK + REAL arr(n) + PARAMETER (M=7,NSTACK=50) + INTEGER i,ir,j,jstack,k,l,istack(NSTACK) + REAL a,temp + jstack=0 + l=1 + ir=n +1 if(ir-l.lt.M)then + do 12 j=l+1,ir + a=arr(j) + do 11 i=j-1,l,-1 + if(arr(i).le.a)goto 2 + arr(i+1)=arr(i) +11 continue + i=l-1 +2 arr(i+1)=a +12 continue + if(jstack.eq.0)return + ir=istack(jstack) + l=istack(jstack-1) + jstack=jstack-2 + else + k=(l+ir)/2 + temp=arr(k) + arr(k)=arr(l+1) + arr(l+1)=temp + if(arr(l).gt.arr(ir))then + temp=arr(l) + arr(l)=arr(ir) + arr(ir)=temp + endif + if(arr(l+1).gt.arr(ir))then + temp=arr(l+1) + arr(l+1)=arr(ir) + arr(ir)=temp + endif + if(arr(l).gt.arr(l+1))then + temp=arr(l) + arr(l)=arr(l+1) + arr(l+1)=temp + endif + i=l+1 + j=ir + a=arr(l+1) +3 continue + i=i+1 + if(arr(i).lt.a)goto 3 +4 continue + j=j-1 + if(arr(j).gt.a)goto 4 + if(j.lt.i)goto 5 + temp=arr(i) + arr(i)=arr(j) + arr(j)=temp + goto 3 +5 arr(l+1)=arr(j) + arr(j)=a + jstack=jstack+2 + if(jstack.gt.NSTACK)pause 'NSTACK too small in sort' + if(ir-i+1.ge.j-l)then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif + endif + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/sort2.for b/dataassim/math/numrec/f77_sources/sort2.for new file mode 100644 index 0000000..26b4512 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sort2.for @@ -0,0 +1,94 @@ + SUBROUTINE sort2(n,arr,brr) + INTEGER n,M,NSTACK + REAL arr(n),brr(n) + PARAMETER (M=7,NSTACK=50) + INTEGER i,ir,j,jstack,k,l,istack(NSTACK) + REAL a,b,temp + jstack=0 + l=1 + ir=n +1 if(ir-l.lt.M)then + do 12 j=l+1,ir + a=arr(j) + b=brr(j) + do 11 i=j-1,l,-1 + if(arr(i).le.a)goto 2 + arr(i+1)=arr(i) + brr(i+1)=brr(i) +11 continue + i=l-1 +2 arr(i+1)=a + brr(i+1)=b +12 continue + if(jstack.eq.0)return + ir=istack(jstack) + l=istack(jstack-1) + jstack=jstack-2 + else + k=(l+ir)/2 + temp=arr(k) + arr(k)=arr(l+1) + arr(l+1)=temp + temp=brr(k) + brr(k)=brr(l+1) + brr(l+1)=temp + if(arr(l).gt.arr(ir))then + temp=arr(l) + arr(l)=arr(ir) + arr(ir)=temp + temp=brr(l) + brr(l)=brr(ir) + brr(ir)=temp + endif + if(arr(l+1).gt.arr(ir))then + temp=arr(l+1) + arr(l+1)=arr(ir) + arr(ir)=temp + temp=brr(l+1) + brr(l+1)=brr(ir) + brr(ir)=temp + endif + if(arr(l).gt.arr(l+1))then + temp=arr(l) + arr(l)=arr(l+1) + arr(l+1)=temp + temp=brr(l) + brr(l)=brr(l+1) + brr(l+1)=temp + endif + i=l+1 + j=ir + a=arr(l+1) + b=brr(l+1) +3 continue + i=i+1 + if(arr(i).lt.a)goto 3 +4 continue + j=j-1 + if(arr(j).gt.a)goto 4 + if(j.lt.i)goto 5 + temp=arr(i) + arr(i)=arr(j) + arr(j)=temp + temp=brr(i) + brr(i)=brr(j) + brr(j)=temp + goto 3 +5 arr(l+1)=arr(j) + arr(j)=a + brr(l+1)=brr(j) + brr(j)=b + jstack=jstack+2 + if(jstack.gt.NSTACK)pause 'NSTACK too small in sort2' + if(ir-i+1.ge.j-l)then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif + endif + goto 1 + END diff --git a/dataassim/math/numrec/f77_sources/sort3.for b/dataassim/math/numrec/f77_sources/sort3.for new file mode 100644 index 0000000..fb7f2d3 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sort3.for @@ -0,0 +1,26 @@ + SUBROUTINE sort3(n,ra,rb,rc,wksp,iwksp) + INTEGER n,iwksp(n) + REAL ra(n),rb(n),rc(n),wksp(n) +CU USES indexx + INTEGER j + call indexx(n,ra,iwksp) + do 11 j=1,n + wksp(j)=ra(j) +11 continue + do 12 j=1,n + ra(j)=wksp(iwksp(j)) +12 continue + do 13 j=1,n + wksp(j)=rb(j) +13 continue + do 14 j=1,n + rb(j)=wksp(iwksp(j)) +14 continue + do 15 j=1,n + wksp(j)=rc(j) +15 continue + do 16 j=1,n + rc(j)=wksp(iwksp(j)) +16 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/spctrm.for b/dataassim/math/numrec/f77_sources/spctrm.for new file mode 100644 index 0000000..58cc74e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/spctrm.for @@ -0,0 +1,62 @@ + SUBROUTINE spctrm(p,m,k,ovrlap,w1,w2) + INTEGER k,m + REAL p(m),w1(4*m),w2(m) + LOGICAL ovrlap +CU USES four1 + INTEGER j,j2,joff,joffn,kk,m4,m43,m44,mm + REAL den,facm,facp,sumw,w,window + window(j)=(1.-abs(((j-1)-facm)*facp)) +C window(j)=1. +C window(j)=(1.-(((j-1)-facm)*facp)**2) + mm=m+m + m4=mm+mm + m44=m4+4 + m43=m4+3 + den=0. + facm=m + facp=1./m + sumw=0. + do 11 j=1,mm + sumw=sumw+window(j)**2 +11 continue + do 12 j=1,m + p(j)=0. +12 continue + if(ovrlap)then + read (9,*) (w2(j),j=1,m) + endif + do 18 kk=1,k + do 15 joff=-1,0,1 + if (ovrlap) then + do 13 j=1,m + w1(joff+j+j)=w2(j) +13 continue + read (9,*) (w2(j),j=1,m) + joffn=joff+mm + do 14 j=1,m + w1(joffn+j+j)=w2(j) +14 continue + else + read (9,*) (w1(j),j=joff+2,m4,2) + endif +15 continue + do 16 j=1,mm + j2=j+j + w=window(j) + w1(j2)=w1(j2)*w + w1(j2-1)=w1(j2-1)*w +16 continue + call four1(w1,mm,1) + p(1)=p(1)+w1(1)**2+w1(2)**2 + do 17 j=2,m + j2=j+j + p(j)=p(j)+w1(j2)**2+w1(j2-1)**2+w1(m44-j2)**2+w1(m43-j2)**2 +17 continue + den=den+sumw +18 continue + den=m4*den + do 19 j=1,m + p(j)=p(j)/den +19 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/spear.for b/dataassim/math/numrec/f77_sources/spear.for new file mode 100644 index 0000000..257ca75 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/spear.for @@ -0,0 +1,36 @@ + SUBROUTINE spear(data1,data2,n,wksp1,wksp2,d,zd,probd,rs,probrs) + INTEGER n + REAL d,probd,probrs,rs,zd,data1(n),data2(n),wksp1(n),wksp2(n) +CU USES betai,crank,erfcc,sort2 + INTEGER j + REAL aved,df,en,en3n,fac,sf,sg,t,vard,betai,erfcc + do 11 j=1,n + wksp1(j)=data1(j) + wksp2(j)=data2(j) +11 continue + call sort2(n,wksp1,wksp2) + call crank(n,wksp1,sf) + call sort2(n,wksp2,wksp1) + call crank(n,wksp2,sg) + d=0. + do 12 j=1,n + d=d+(wksp1(j)-wksp2(j))**2 +12 continue + en=n + en3n=en**3-en + aved=en3n/6.-(sf+sg)/12. + fac=(1.-sf/en3n)*(1.-sg/en3n) + vard=((en-1.)*en**2*(en+1.)**2/36.)*fac + zd=(d-aved)/sqrt(vard) + probd=erfcc(abs(zd)/1.4142136) + rs=(1.-(6./en3n)*(d+(sf+sg)/12.))/sqrt(fac) + fac=(1.+rs)*(1.-rs) + if(fac.gt.0.)then + t=rs*sqrt((en-2.)/fac) + df=en-2. + probrs=betai(0.5*df,0.5,df/(df+t**2)) + else + probrs=0. + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/sphbes.for b/dataassim/math/numrec/f77_sources/sphbes.for new file mode 100644 index 0000000..1140e3c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sphbes.for @@ -0,0 +1,16 @@ + SUBROUTINE sphbes(n,x,sj,sy,sjp,syp) + INTEGER n + REAL sj,sjp,sy,syp,x +CU USES bessjy + REAL factor,order,rj,rjp,ry,ryp,RTPIO2 + PARAMETER (RTPIO2=1.2533141) + if(n.lt.0.or.x.le.0.)pause 'bad arguments in sphbes' + order=n+0.5 + call bessjy(x,order,rj,ry,rjp,ryp) + factor=RTPIO2/sqrt(x) + sj=factor*rj + sy=factor*ry + sjp=factor*rjp-sj/(2.*x) + syp=factor*ryp-sy/(2.*x) + return + END diff --git a/dataassim/math/numrec/f77_sources/sphfpt.for b/dataassim/math/numrec/f77_sources/sphfpt.for new file mode 100644 index 0000000..4bcea1b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sphfpt.for @@ -0,0 +1,70 @@ + PROGRAM sphfpt + INTEGER i,m,n,nvar,nn2,N1,N2,NTOT + REAL DXX + PARAMETER (N1=2,N2=1,NTOT=N1+N2,DXX=1.e-4) + REAL c2,dx,gamma,q1,x1,x2,xf,v1(N2),v2(N1),v(NTOT) + LOGICAL check + COMMON /sphcom/ c2,gamma,dx,m,n + COMMON /caller/ x1,x2,xf,nvar,nn2 + EQUIVALENCE (v1(1),v(1)),(v2(1),v(N2+1)) +CU USES newt + nvar=NTOT + nn2=N2 + dx=DXX +1 write(*,*) 'input m,n,c-squared (999 to end)' + read(*,*) m,n,c2 + if (c2.eq.999.) stop + if ((n.lt.m).or.(m.lt.0)) goto 1 + gamma=1.0 + q1=n + do 11 i=1,m + gamma=-0.5*gamma*(n+i)*(q1/i) + q1=q1-1.0 +11 continue + v1(1)=n*(n+1)-m*(m+1)+c2/2.0 + v2(2)=v1(1) + v2(1)=gamma*(1.-(v2(2)-c2)*dx/(2*(m+1))) + x1=-1.0+dx + x2=1.0-dx + xf=0. + call newt(v,NTOT,check) + if(check)then + write(*,*)'shootf failed; bad initial guess' + else + write(*,'(1x,t6,a)') 'mu(m,n)' + write(*,'(1x,f12.6)') v1(1) + goto 1 + endif + END + SUBROUTINE load1(x1,v1,y) + INTEGER m,n + REAL c2,dx,gamma,x1,y1,v1(1),y(3) + COMMON /sphcom/ c2,gamma,dx,m,n + y(3)=v1(1) + if(mod(n-m,2).eq.0)then + y1=gamma + else + y1=-gamma + endif + y(2)=-(y(3)-c2)*y1/(2*(m+1)) + y(1)=y1+y(2)*dx + return + END + SUBROUTINE load2(x2,v2,y) + INTEGER m,n + REAL c2,dx,gamma,x2,v2(2),y(3) + COMMON /sphcom/ c2,gamma,dx,m,n + y(3)=v2(2) + y(1)=v2(1) + y(2)=(y(3)-c2)*y(1)/(2*(m+1)) + return + END + SUBROUTINE score(xf,y,f) + INTEGER i,m,n + REAL c2,gamma,dx,xf,f(3),y(3) + COMMON /sphcom/ c2,gamma,dx,m,n + do 12 i=1,3 + f(i)=y(i) +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/sphoot.for b/dataassim/math/numrec/f77_sources/sphoot.for new file mode 100644 index 0000000..edb10e8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sphoot.for @@ -0,0 +1,66 @@ + PROGRAM sphoot + INTEGER i,m,n,nvar,N2 + PARAMETER (N2=1) + REAL c2,dx,gamma,q1,x1,x2,v(N2) + LOGICAL check + COMMON /sphcom/ c2,gamma,dx,m,n + COMMON /caller/ x1,x2,nvar +CU USES newt + dx=1.e-4 + nvar=3 +1 write(*,*) 'input m,n,c-squared (999 to end)' + read(*,*) m,n,c2 + if (c2.eq.999.) stop + if ((n.lt.m).or.(m.lt.0)) goto 1 + gamma=1.0 + q1=n + do 11 i=1,m + gamma=-0.5*gamma*(n+i)*(q1/i) + q1=q1-1.0 +11 continue + v(1)=n*(n+1)-m*(m+1)+c2/2.0 + x1=-1.0+dx + x2=0.0 + call newt(v,N2,check) + if(check)then + write(*,*)'shoot failed; bad initial guess' + else + write(*,'(1x,t6,a)') 'mu(m,n)' + write(*,'(1x,f12.6)') v(1) + goto 1 + endif + END + SUBROUTINE load(x1,v,y) + INTEGER m,n + REAL c2,dx,gamma,x1,y1,v(1),y(3) + COMMON /sphcom/ c2,gamma,dx,m,n + y(3)=v(1) + if(mod(n-m,2).eq.0)then + y1=gamma + else + y1=-gamma + endif + y(2)=-(y(3)-c2)*y1/(2*(m+1)) + y(1)=y1+y(2)*dx + return + END + SUBROUTINE score(x2,y,f) + INTEGER m,n + REAL c2,dx,gamma,x2,f(1),y(3) + COMMON /sphcom/ c2,gamma,dx,m,n + if (mod(n-m,2).eq.0) then + f(1)=y(2) + else + f(1)=y(1) + endif + return + END + SUBROUTINE derivs(x,y,dydx) + INTEGER m,n + REAL c2,dx,gamma,x,dydx(3),y(3) + COMMON /sphcom/ c2,gamma,dx,m,n + dydx(1)=y(2) + dydx(2)=(2.0*x*(m+1.0)*y(2)-(y(3)-c2*x*x)*y(1))/(1.0-x*x) + dydx(3)=0.0 + return + END diff --git a/dataassim/math/numrec/f77_sources/splie2.for b/dataassim/math/numrec/f77_sources/splie2.for new file mode 100644 index 0000000..b66629d --- /dev/null +++ b/dataassim/math/numrec/f77_sources/splie2.for @@ -0,0 +1,18 @@ + SUBROUTINE splie2(x1a,x2a,ya,m,n,y2a) + INTEGER m,n,NN + REAL x1a(m),x2a(n),y2a(m,n),ya(m,n) + PARAMETER (NN=100) +CU USES spline + INTEGER j,k + REAL y2tmp(NN),ytmp(NN) + do 13 j=1,m + do 11 k=1,n + ytmp(k)=ya(j,k) +11 continue + call spline(x2a,ytmp,n,1.e30,1.e30,y2tmp) + do 12 k=1,n + y2a(j,k)=y2tmp(k) +12 continue +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/splin2.for b/dataassim/math/numrec/f77_sources/splin2.for new file mode 100644 index 0000000..b8008bc --- /dev/null +++ b/dataassim/math/numrec/f77_sources/splin2.for @@ -0,0 +1,18 @@ + SUBROUTINE splin2(x1a,x2a,ya,y2a,m,n,x1,x2,y) + INTEGER m,n,NN + REAL x1,x2,y,x1a(m),x2a(n),y2a(m,n),ya(m,n) + PARAMETER (NN=100) +CU USES spline,splint + INTEGER j,k + REAL y2tmp(NN),ytmp(NN),yytmp(NN) + do 12 j=1,m + do 11 k=1,n + ytmp(k)=ya(j,k) + y2tmp(k)=y2a(j,k) +11 continue + call splint(x2a,ytmp,y2tmp,n,x2,yytmp(j)) +12 continue + call spline(x1a,yytmp,m,1.e30,1.e30,y2tmp) + call splint(x1a,yytmp,y2tmp,m,x1,y) + return + END diff --git a/dataassim/math/numrec/f77_sources/spline.for b/dataassim/math/numrec/f77_sources/spline.for new file mode 100644 index 0000000..46e0f41 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/spline.for @@ -0,0 +1,34 @@ + SUBROUTINE spline(x,y,n,yp1,ypn,y2) + INTEGER n,NMAX + REAL yp1,ypn,x(n),y(n),y2(n) + PARAMETER (NMAX=500) + INTEGER i,k + REAL p,qn,sig,un,u(NMAX) + if (yp1.gt..99e30) then + y2(1)=0. + u(1)=0. + else + y2(1)=-0.5 + u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1) + endif + do 11 i=2,n-1 + sig=(x(i)-x(i-1))/(x(i+1)-x(i-1)) + p=sig*y2(i-1)+2. + y2(i)=(sig-1.)/p + u(i)=(6.*((y(i+1)-y(i))/(x(i+ + *1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig* + *u(i-1))/p +11 continue + if (ypn.gt..99e30) then + qn=0. + un=0. + else + qn=0.5 + un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1))) + endif + y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.) + do 12 k=n-1,1,-1 + y2(k)=y2(k)*y2(k+1)+u(k) +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/splint.for b/dataassim/math/numrec/f77_sources/splint.for new file mode 100644 index 0000000..b1f422f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/splint.for @@ -0,0 +1,24 @@ + SUBROUTINE splint(xa,ya,y2a,n,x,y) + INTEGER n + REAL x,y,xa(n),y2a(n),ya(n) + INTEGER k,khi,klo + REAL a,b,h + klo=1 + khi=n +1 if (khi-klo.gt.1) then + k=(khi+klo)/2 + if(xa(k).gt.x)then + khi=k + else + klo=k + endif + goto 1 + endif + h=xa(khi)-xa(klo) + if (h.eq.0.) pause 'bad xa input in splint' + a=(xa(khi)-x)/h + b=(x-xa(klo))/h + y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h** + *2)/6. + return + END diff --git a/dataassim/math/numrec/f77_sources/spread.for b/dataassim/math/numrec/f77_sources/spread.for new file mode 100644 index 0000000..f68b0a7 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/spread.for @@ -0,0 +1,27 @@ + SUBROUTINE spread(y,yy,n,x,m) + INTEGER m,n + REAL x,y,yy(n) + INTEGER ihi,ilo,ix,j,nden,nfac(10) + REAL fac + SAVE nfac + DATA nfac /1,1,2,6,24,120,720,5040,40320,362880/ + if(m.gt.10) pause 'factorial table too small in spread' + ix=x + if(x.eq.float(ix))then + yy(ix)=yy(ix)+y + else + ilo=min(max(int(x-0.5*m+1.0),1),n-m+1) + ihi=ilo+m-1 + nden=nfac(m) + fac=x-ilo + do 11 j=ilo+1,ihi + fac=fac*(x-j) +11 continue + yy(ihi)=yy(ihi)+y*fac/(nden*(x-ihi)) + do 12 j=ihi-1,ilo,-1 + nden=(nden/(j+1-ilo))*(j-ihi) + yy(j)=yy(j)+y*fac/(nden*(x-j)) +12 continue + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/sprsax.for b/dataassim/math/numrec/f77_sources/sprsax.for new file mode 100644 index 0000000..0284949 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sprsax.for @@ -0,0 +1,13 @@ + SUBROUTINE sprsax(sa,ija,x,b,n) + INTEGER n,ija(*) + REAL b(n),sa(*),x(n) + INTEGER i,k + if (ija(1).ne.n+2) pause 'mismatched vector and matrix in sprsax' + do 12 i=1,n + b(i)=sa(i)*x(i) + do 11 k=ija(i),ija(i+1)-1 + b(i)=b(i)+sa(k)*x(ija(k)) +11 continue +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/sprsin.for b/dataassim/math/numrec/f77_sources/sprsin.for new file mode 100644 index 0000000..c0ad164 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sprsin.for @@ -0,0 +1,24 @@ + SUBROUTINE sprsin(a,n,np,thresh,nmax,sa,ija) + INTEGER n,nmax,np,ija(nmax) + REAL thresh,a(np,np),sa(nmax) + INTEGER i,j,k + do 11 j=1,n + sa(j)=a(j,j) +11 continue + ija(1)=n+2 + k=n+1 + do 13 i=1,n + do 12 j=1,n + if(abs(a(i,j)).ge.thresh)then + if(i.ne.j)then + k=k+1 + if(k.gt.nmax)pause 'nmax too small in sprsin' + sa(k)=a(i,j) + ija(k)=j + endif + endif +12 continue + ija(i+1)=k+1 +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/sprspm.for b/dataassim/math/numrec/f77_sources/sprspm.for new file mode 100644 index 0000000..032fc83 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sprspm.for @@ -0,0 +1,52 @@ + SUBROUTINE sprspm(sa,ija,sb,ijb,sc,ijc) + INTEGER ija(*),ijb(*),ijc(*) + REAL sa(*),sb(*),sc(*) + INTEGER i,ijma,ijmb,j,m,ma,mb,mbb,mn + REAL sum + if (ija(1).ne.ijb(1).or.ija(1).ne.ijc(1))pause + *'sprspm sizes do not match' + do 13 i=1,ijc(1)-2 + j=i + m=i + mn=ijc(i) + sum=sa(i)*sb(i) +1 continue + mb=ijb(j) + do 11 ma=ija(i),ija(i+1)-1 + ijma=ija(ma) + if(ijma.eq.j)then + sum=sum+sa(ma)*sb(j) + else +2 if(mb.lt.ijb(j+1))then + ijmb=ijb(mb) + if(ijmb.eq.i)then + sum=sum+sa(i)*sb(mb) + mb=mb+1 + goto 2 + else if(ijmb.lt.ijma)then + mb=mb+1 + goto 2 + else if(ijmb.eq.ijma)then + sum=sum+sa(ma)*sb(mb) + mb=mb+1 + goto 2 + endif + endif + endif +11 continue + do 12 mbb=mb,ijb(j+1)-1 + if(ijb(mbb).eq.i)then + sum=sum+sa(i)*sb(mbb) + endif +12 continue + sc(m)=sum + sum=0.e0 + if(mn.ge.ijc(i+1))goto 3 + m=mn + mn=mn+1 + j=ijc(m) + goto 1 +3 continue +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/sprstm.for b/dataassim/math/numrec/f77_sources/sprstm.for new file mode 100644 index 0000000..930c391 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sprstm.for @@ -0,0 +1,56 @@ + SUBROUTINE sprstm(sa,ija,sb,ijb,thresh,nmax,sc,ijc) + INTEGER nmax,ija(*),ijb(*),ijc(nmax) + REAL thresh,sa(*),sb(*),sc(nmax) + INTEGER i,ijma,ijmb,j,k,ma,mb,mbb + REAL sum + if (ija(1).ne.ijb(1)) pause 'sprstm sizes do not match' + k=ija(1) + ijc(1)=k + do 14 i=1,ija(1)-2 + do 13 j=1,ijb(1)-2 + if(i.eq.j)then + sum=sa(i)*sb(j) + else + sum=0.d0 + endif + mb=ijb(j) + do 11 ma=ija(i),ija(i+1)-1 + ijma=ija(ma) + if(ijma.eq.j)then + sum=sum+sa(ma)*sb(j) + else +2 if(mb.lt.ijb(j+1))then + ijmb=ijb(mb) + if(ijmb.eq.i)then + sum=sum+sa(i)*sb(mb) + mb=mb+1 + goto 2 + else if(ijmb.lt.ijma)then + mb=mb+1 + goto 2 + else if(ijmb.eq.ijma)then + sum=sum+sa(ma)*sb(mb) + mb=mb+1 + goto 2 + endif + endif + endif +11 continue + do 12 mbb=mb,ijb(j+1)-1 + if(ijb(mbb).eq.i)then + sum=sum+sa(i)*sb(mbb) + endif +12 continue + if(i.eq.j)then + sc(i)=sum + else if(abs(sum).gt.thresh)then + if(k.gt.nmax)pause 'sprstm: nmax to small' + sc(k)=sum + ijc(k)=j + k=k+1 + endif +13 continue + ijc(i+1)=k +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/sprstp.for b/dataassim/math/numrec/f77_sources/sprstp.for new file mode 100644 index 0000000..148c901 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sprstp.for @@ -0,0 +1,61 @@ + SUBROUTINE sprstp(sa,ija,sb,ijb) + INTEGER ija(*),ijb(*) + REAL sa(*),sb(*) +CU USES iindexx + INTEGER j,jl,jm,jp,ju,k,m,n2,noff,inc,iv + REAL v + n2=ija(1) + do 11 j=1,n2-2 + sb(j)=sa(j) +11 continue + call iindexx(ija(n2-1)-ija(1),ija(n2),ijb(n2)) + jp=0 + do 13 k=ija(1),ija(n2-1)-1 + m=ijb(k)+n2-1 + sb(k)=sa(m) + do 12 j=jp+1,ija(m) + ijb(j)=k +12 continue + jp=ija(m) + jl=1 + ju=n2-1 +5 if (ju-jl.gt.1) then + jm=(ju+jl)/2 + if(ija(jm).gt.m)then + ju=jm + else + jl=jm + endif + goto 5 + endif + ijb(k)=jl +13 continue + do 14 j=jp+1,n2-1 + ijb(j)=ija(n2-1) +14 continue + do 16 j=1,n2-2 + jl=ijb(j+1)-ijb(j) + noff=ijb(j)-1 + inc=1 +1 inc=3*inc+1 + if(inc.le.jl)goto 1 +2 continue + inc=inc/3 + do 15 k=noff+inc+1,noff+jl + iv=ijb(k) + v=sb(k) + m=k +3 if(ijb(m-inc).gt.iv)then + ijb(m)=ijb(m-inc) + sb(m)=sb(m-inc) + m=m-inc + if(m-noff.le.inc)goto 4 + goto 3 + endif +4 ijb(m)=iv + sb(m)=v +15 continue + if(inc.gt.1)goto 2 +16 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/sprstx.for b/dataassim/math/numrec/f77_sources/sprstx.for new file mode 100644 index 0000000..bd8b875 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/sprstx.for @@ -0,0 +1,16 @@ + SUBROUTINE sprstx(sa,ija,x,b,n) + INTEGER n,ija(*) + REAL b(n),sa(*),x(n) + INTEGER i,j,k + if (ija(1).ne.n+2) pause 'mismatched vector and matrix in sprstx' + do 11 i=1,n + b(i)=sa(i)*x(i) +11 continue + do 13 i=1,n + do 12 k=ija(i),ija(i+1)-1 + j=ija(k) + b(j)=b(j)+sa(k)*x(i) +12 continue +13 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/stifbs.for b/dataassim/math/numrec/f77_sources/stifbs.for new file mode 100644 index 0000000..a167fb0 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/stifbs.for @@ -0,0 +1,115 @@ + SUBROUTINE stifbs(y,dydx,nv,x,htry,eps,yscal,hdid,hnext,derivs) + INTEGER nv,NMAX,KMAXX,IMAX + REAL eps,hdid,hnext,htry,x,dydx(nv),y(nv),yscal(nv),SAFE1,SAFE2, + *REDMAX,REDMIN,TINY,SCALMX + EXTERNAL derivs + PARAMETER (NMAX=50,KMAXX=7,IMAX=KMAXX+1,SAFE1=.25,SAFE2=.7, + *REDMAX=1.e-5,REDMIN=.7,TINY=1.e-30,SCALMX=.1) +CU USES derivs,jacobn,simpr,pzextr + INTEGER i,iq,k,kk,km,kmax,kopt,nvold,nseq(IMAX) + REAL eps1,epsold,errmax,fact,h,red,scale,work,wrkmin,xest,xnew, + *a(IMAX),alf(KMAXX,KMAXX),dfdx(NMAX),dfdy(NMAX,NMAX),err(KMAXX), + *yerr(NMAX),ysav(NMAX),yseq(NMAX) + LOGICAL first,reduct + SAVE a,alf,epsold,first,kmax,kopt,nseq,nvold,xnew + DATA first/.true./,epsold/-1./,nvold/-1/ + DATA nseq /2,6,10,14,22,34,50,70/ + if(eps.ne.epsold.or.nv.ne.nvold)then + hnext=-1.e29 + xnew=-1.e29 + eps1=SAFE1*eps + a(1)=nseq(1)+1 + do 11 k=1,KMAXX + a(k+1)=a(k)+nseq(k+1) +11 continue + do 13 iq=2,KMAXX + do 12 k=1,iq-1 + alf(k,iq)=eps1**((a(k+1)-a(iq+1))/((a(iq+1)-a(1)+1.)*(2*k+ + *1))) +12 continue +13 continue + epsold=eps + nvold=nv + a(1)=nv+a(1) + do 14 k=1,KMAXX + a(k+1)=a(k)+nseq(k+1) +14 continue + do 15 kopt=2,KMAXX-1 + if(a(kopt+1).gt.a(kopt)*alf(kopt-1,kopt))goto 1 +15 continue +1 kmax=kopt + endif + h=htry + do 16 i=1,nv + ysav(i)=y(i) +16 continue + call jacobn(x,y,dfdx,dfdy,nv,nmax) + if(h.ne.hnext.or.x.ne.xnew)then + first=.true. + kopt=kmax + endif + reduct=.false. +2 do 18 k=1,kmax + xnew=x+h + if(xnew.eq.x)pause 'stepsize underflow in stifbs' + call simpr(ysav,dydx,dfdx,dfdy,nmax,nv,x,h,nseq(k),yseq,derivs) + xest=(h/nseq(k))**2 + call pzextr(k,xest,yseq,y,yerr,nv) + if(k.ne.1)then + errmax=TINY + do 17 i=1,nv + errmax=max(errmax,abs(yerr(i)/yscal(i))) +17 continue + errmax=errmax/eps + km=k-1 + err(km)=(errmax/SAFE1)**(1./(2*km+1)) + endif + if(k.ne.1.and.(k.ge.kopt-1.or.first))then + if(errmax.lt.1.)goto 4 + if(k.eq.kmax.or.k.eq.kopt+1)then + red=SAFE2/err(km) + goto 3 + else if(k.eq.kopt)then + if(alf(kopt-1,kopt).lt.err(km))then + red=1./err(km) + goto 3 + endif + else if(kopt.eq.kmax)then + if(alf(km,kmax-1).lt.err(km))then + red=alf(km,kmax-1)*SAFE2/err(km) + goto 3 + endif + else if(alf(km,kopt).lt.err(km))then + red=alf(km,kopt-1)/err(km) + goto 3 + endif + endif +18 continue +3 red=min(red,REDMIN) + red=max(red,REDMAX) + h=h*red + reduct=.true. + goto 2 +4 x=xnew + hdid=h + first=.false. + wrkmin=1.e35 + do 19 kk=1,km + fact=max(err(kk),SCALMX) + work=fact*a(kk+1) + if(work.lt.wrkmin)then + scale=fact + wrkmin=work + kopt=kk+1 + endif +19 continue + hnext=h/scale + if(kopt.ge.k.and.kopt.ne.kmax.and..not.reduct)then + fact=max(scale/alf(kopt-1,kopt),SCALMX) + if(a(kopt+1)*fact.le.wrkmin)then + hnext=h/fact + kopt=kopt+1 + endif + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/stiff.for b/dataassim/math/numrec/f77_sources/stiff.for new file mode 100644 index 0000000..1296f1b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/stiff.for @@ -0,0 +1,85 @@ + SUBROUTINE stiff(y,dydx,n,x,htry,eps,yscal,hdid,hnext,derivs) + INTEGER n,NMAX,MAXTRY + REAL eps,hdid,hnext,htry,x,dydx(n),y(n),yscal(n),SAFETY,GROW, + *PGROW,SHRNK,PSHRNK,ERRCON,GAM,A21,A31,A32,A2X,A3X,C21,C31,C32,C41, + *C42,C43,B1,B2,B3,B4,E1,E2,E3,E4,C1X,C2X,C3X,C4X + EXTERNAL derivs + PARAMETER (NMAX=50,SAFETY=0.9,GROW=1.5,PGROW=-.25,SHRNK=0.5, + *PSHRNK=-1./3.,ERRCON=.1296,MAXTRY=40) + PARAMETER (GAM=1./2.,A21=2.,A31=48./25.,A32=6./25.,C21=-8., + *C31=372./25.,C32=12./5.,C41=-112./125.,C42=-54./125.,C43=-2./5., + *B1=19./9.,B2=1./2.,B3=25./108.,B4=125./108.,E1=17./54.,E2=7./36., + *E3=0.,E4=125./108.,C1X=1./2.,C2X=-3./2.,C3X=121./50.,C4X=29./250., + *A2X=1.,A3X=3./5.) +CU USES derivs,jacobn,lubksb,ludcmp + INTEGER i,j,jtry,indx(NMAX) + REAL d,errmax,h,xsav,a(NMAX,NMAX),dfdx(NMAX),dfdy(NMAX,NMAX), + *dysav(NMAX),err(NMAX),g1(NMAX),g2(NMAX),g3(NMAX),g4(NMAX), + *ysav(NMAX) + xsav=x + do 11 i=1,n + ysav(i)=y(i) + dysav(i)=dydx(i) +11 continue + call jacobn(xsav,ysav,dfdx,dfdy,n,NMAX) + h=htry + do 23 jtry=1,MAXTRY + do 13 i=1,n + do 12 j=1,n + a(i,j)=-dfdy(i,j) +12 continue + a(i,i)=1./(GAM*h)+a(i,i) +13 continue + call ludcmp(a,n,NMAX,indx,d) + do 14 i=1,n + g1(i)=dysav(i)+h*C1X*dfdx(i) +14 continue + call lubksb(a,n,NMAX,indx,g1) + do 15 i=1,n + y(i)=ysav(i)+A21*g1(i) +15 continue + x=xsav+A2X*h + call derivs(x,y,dydx) + do 16 i=1,n + g2(i)=dydx(i)+h*C2X*dfdx(i)+C21*g1(i)/h +16 continue + call lubksb(a,n,NMAX,indx,g2) + do 17 i=1,n + y(i)=ysav(i)+A31*g1(i)+A32*g2(i) +17 continue + x=xsav+A3X*h + call derivs(x,y,dydx) + do 18 i=1,n + g3(i)=dydx(i)+h*C3X*dfdx(i)+(C31*g1(i)+C32*g2(i))/h +18 continue + call lubksb(a,n,NMAX,indx,g3) + do 19 i=1,n + g4(i)=dydx(i)+h*C4X*dfdx(i)+(C41*g1(i)+C42*g2(i)+C43*g3(i))/h +19 continue + call lubksb(a,n,NMAX,indx,g4) + do 21 i=1,n + y(i)=ysav(i)+B1*g1(i)+B2*g2(i)+B3*g3(i)+B4*g4(i) + err(i)=E1*g1(i)+E2*g2(i)+E3*g3(i)+E4*g4(i) +21 continue + x=xsav+h + if(x.eq.xsav)pause 'stepsize not significant in stiff' + errmax=0. + do 22 i=1,n + errmax=max(errmax,abs(err(i)/yscal(i))) +22 continue + errmax=errmax/eps + if(errmax.le.1.)then + hdid=h + if(errmax.gt.ERRCON)then + hnext=SAFETY*h*errmax**PGROW + else + hnext=GROW*h + endif + return + else + hnext=SAFETY*h*errmax**PSHRNK + h=sign(max(abs(hnext),SHRNK*abs(h)),h) + endif +23 continue + pause 'exceeded MAXTRY in stiff' + END diff --git a/dataassim/math/numrec/f77_sources/stoerm.for b/dataassim/math/numrec/f77_sources/stoerm.for new file mode 100644 index 0000000..1e97306 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/stoerm.for @@ -0,0 +1,35 @@ + SUBROUTINE stoerm(y,d2y,nv,xs,htot,nstep,yout,derivs) + INTEGER nstep,nv,NMAX + REAL htot,xs,d2y(nv),y(nv),yout(nv) + EXTERNAL derivs + PARAMETER (NMAX=50) +CU USES derivs + INTEGER i,n,neqns,nn + REAL h,h2,halfh,x,ytemp(NMAX) + h=htot/nstep + halfh=0.5*h + neqns=nv/2 + do 11 i=1,neqns + n=neqns+i + ytemp(n)=h*(y(n)+halfh*d2y(i)) + ytemp(i)=y(i)+ytemp(n) +11 continue + x=xs+h + call derivs(x,ytemp,yout) + h2=h*h + do 13 nn=2,nstep + do 12 i=1,neqns + n=neqns+i + ytemp(n)=ytemp(n)+h2*yout(i) + ytemp(i)=ytemp(i)+ytemp(n) +12 continue + x=x+h + call derivs(x,ytemp,yout) +13 continue + do 14 i=1,neqns + n=neqns+i + yout(n)=ytemp(n)/h+halfh*yout(i) + yout(i)=ytemp(i) +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/svbksb.for b/dataassim/math/numrec/f77_sources/svbksb.for new file mode 100644 index 0000000..f6efe93 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/svbksb.for @@ -0,0 +1,25 @@ + SUBROUTINE svbksb(u,w,v,m,n,mp,np,b,x) + INTEGER m,mp,n,np,NMAX + REAL b(mp),u(mp,np),v(np,np),w(np),x(np) + PARAMETER (NMAX=500) + INTEGER i,j,jj + REAL s,tmp(NMAX) + do 12 j=1,n + s=0. + if(w(j).ne.0.)then + do 11 i=1,m + s=s+u(i,j)*b(i) +11 continue + s=s/w(j) + endif + tmp(j)=s +12 continue + do 14 j=1,n + s=0. + do 13 jj=1,n + s=s+v(j,jj)*tmp(jj) +13 continue + x(j)=s +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/svdcmp.for b/dataassim/math/numrec/f77_sources/svdcmp.for new file mode 100644 index 0000000..902086f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/svdcmp.for @@ -0,0 +1,224 @@ + SUBROUTINE svdcmp(a,m,n,mp,np,w,v) + INTEGER m,mp,n,np,NMAX + REAL a(mp,np),v(np,np),w(np) + PARAMETER (NMAX=500) +CU USES pythag + INTEGER i,its,j,jj,k,l,nm + REAL anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX),pythag + g=0.0 + scale=0.0 + anorm=0.0 + do 25 i=1,n + l=i+1 + rv1(i)=scale*g + g=0.0 + s=0.0 + scale=0.0 + if(i.le.m)then + do 11 k=i,m + scale=scale+abs(a(k,i)) +11 continue + if(scale.ne.0.0)then + do 12 k=i,m + a(k,i)=a(k,i)/scale + s=s+a(k,i)*a(k,i) +12 continue + f=a(i,i) + g=-sign(sqrt(s),f) + h=f*g-s + a(i,i)=f-g + do 15 j=l,n + s=0.0 + do 13 k=i,m + s=s+a(k,i)*a(k,j) +13 continue + f=s/h + do 14 k=i,m + a(k,j)=a(k,j)+f*a(k,i) +14 continue +15 continue + do 16 k=i,m + a(k,i)=scale*a(k,i) +16 continue + endif + endif + w(i)=scale *g + g=0.0 + s=0.0 + scale=0.0 + if((i.le.m).and.(i.ne.n))then + do 17 k=l,n + scale=scale+abs(a(i,k)) +17 continue + if(scale.ne.0.0)then + do 18 k=l,n + a(i,k)=a(i,k)/scale + s=s+a(i,k)*a(i,k) +18 continue + f=a(i,l) + g=-sign(sqrt(s),f) + h=f*g-s + a(i,l)=f-g + do 19 k=l,n + rv1(k)=a(i,k)/h +19 continue + do 23 j=l,m + s=0.0 + do 21 k=l,n + s=s+a(j,k)*a(i,k) +21 continue + do 22 k=l,n + a(j,k)=a(j,k)+s*rv1(k) +22 continue +23 continue + do 24 k=l,n + a(i,k)=scale*a(i,k) +24 continue + endif + endif + anorm=max(anorm,(abs(w(i))+abs(rv1(i)))) +25 continue + do 32 i=n,1,-1 + if(i.lt.n)then + if(g.ne.0.0)then + do 26 j=l,n + v(j,i)=(a(i,j)/a(i,l))/g +26 continue + do 29 j=l,n + s=0.0 + do 27 k=l,n + s=s+a(i,k)*v(k,j) +27 continue + do 28 k=l,n + v(k,j)=v(k,j)+s*v(k,i) +28 continue +29 continue + endif + do 31 j=l,n + v(i,j)=0.0 + v(j,i)=0.0 +31 continue + endif + v(i,i)=1.0 + g=rv1(i) + l=i +32 continue + do 39 i=min(m,n),1,-1 + l=i+1 + g=w(i) + do 33 j=l,n + a(i,j)=0.0 +33 continue + if(g.ne.0.0)then + g=1.0/g + do 36 j=l,n + s=0.0 + do 34 k=l,m + s=s+a(k,i)*a(k,j) +34 continue + f=(s/a(i,i))*g + do 35 k=i,m + a(k,j)=a(k,j)+f*a(k,i) +35 continue +36 continue + do 37 j=i,m + a(j,i)=a(j,i)*g +37 continue + else + do 38 j= i,m + a(j,i)=0.0 +38 continue + endif + a(i,i)=a(i,i)+1.0 +39 continue + do 49 k=n,1,-1 + do 48 its=1,30 + do 41 l=k,1,-1 + nm=l-1 + if((abs(rv1(l))+anorm).eq.anorm) goto 2 + if((abs(w(nm))+anorm).eq.anorm) goto 1 +41 continue +1 c=0.0 + s=1.0 + do 43 i=l,k + f=s*rv1(i) + rv1(i)=c*rv1(i) + if((abs(f)+anorm).eq.anorm) goto 2 + g=w(i) + h=pythag(f,g) + w(i)=h + h=1.0/h + c= (g*h) + s=-(f*h) + do 42 j=1,m + y=a(j,nm) + z=a(j,i) + a(j,nm)=(y*c)+(z*s) + a(j,i)=-(y*s)+(z*c) +42 continue +43 continue +2 z=w(k) + if(l.eq.k)then + if(z.lt.0.0)then + w(k)=-z + do 44 j=1,n + v(j,k)=-v(j,k) +44 continue + endif + goto 3 + endif + if(its.eq.30) pause 'no convergence in svdcmp' + x=w(l) + nm=k-1 + y=w(nm) + g=rv1(nm) + h=rv1(k) + f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y) + g=pythag(f,1.0) + f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x + c=1.0 + s=1.0 + do 47 j=l,nm + i=j+1 + g=rv1(i) + y=w(i) + h=s*g + g=c*g + z=pythag(f,h) + rv1(j)=z + c=f/z + s=h/z + f= (x*c)+(g*s) + g=-(x*s)+(g*c) + h=y*s + y=y*c + do 45 jj=1,n + x=v(jj,j) + z=v(jj,i) + v(jj,j)= (x*c)+(z*s) + v(jj,i)=-(x*s)+(z*c) +45 continue + z=pythag(f,h) + w(j)=z + if(z.ne.0.0)then + z=1.0/z + c=f*z + s=h*z + endif + f= (c*g)+(s*y) + x=-(s*g)+(c*y) + do 46 jj=1,m + y=a(jj,j) + z=a(jj,i) + a(jj,j)= (y*c)+(z*s) + a(jj,i)=-(y*s)+(z*c) +46 continue +47 continue + rv1(l)=0.0 + rv1(k)=f + w(k)=x +48 continue +3 continue +49 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/svdfit.for b/dataassim/math/numrec/f77_sources/svdfit.for new file mode 100644 index 0000000..5661662 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/svdfit.for @@ -0,0 +1,38 @@ + SUBROUTINE svdfit(x,y,sig,ndata,a,ma,u,v,w,mp,np,chisq,funcs) + INTEGER ma,mp,ndata,np,NMAX,MMAX + REAL chisq,a(ma),sig(ndata),u(mp,np),v(np,np),w(np),x(ndata), + *y(ndata),TOL + EXTERNAL funcs + PARAMETER (NMAX=1000,MMAX=50,TOL=1.e-5) +CU USES svbksb,svdcmp + INTEGER i,j + REAL sum,thresh,tmp,wmax,afunc(MMAX),b(NMAX) + do 12 i=1,ndata + call funcs(x(i),afunc,ma) + tmp=1./sig(i) + do 11 j=1,ma + u(i,j)=afunc(j)*tmp +11 continue + b(i)=y(i)*tmp +12 continue + call svdcmp(u,ndata,ma,mp,np,w,v) + wmax=0. + do 13 j=1,ma + if(w(j).gt.wmax)wmax=w(j) +13 continue + thresh=TOL*wmax + do 14 j=1,ma + if(w(j).lt.thresh)w(j)=0. +14 continue + call svbksb(u,w,v,ndata,ma,mp,np,b,a) + chisq=0. + do 16 i=1,ndata + call funcs(x(i),afunc,ma) + sum=0. + do 15 j=1,ma + sum=sum+a(j)*afunc(j) +15 continue + chisq=chisq+((y(i)-sum)/sig(i))**2 +16 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/svdvar.for b/dataassim/math/numrec/f77_sources/svdvar.for new file mode 100644 index 0000000..d63919e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/svdvar.for @@ -0,0 +1,22 @@ + SUBROUTINE svdvar(v,ma,np,w,cvm,ncvm) + INTEGER ma,ncvm,np,MMAX + REAL cvm(ncvm,ncvm),v(np,np),w(np) + PARAMETER (MMAX=20) + INTEGER i,j,k + REAL sum,wti(MMAX) + do 11 i=1,ma + wti(i)=0. + if(w(i).ne.0.) wti(i)=1./(w(i)*w(i)) +11 continue + do 14 i=1,ma + do 13 j=1,i + sum=0. + do 12 k=1,ma + sum=sum+v(i,k)*v(j,k)*wti(k) +12 continue + cvm(i,j)=sum + cvm(j,i)=sum +13 continue +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/toeplz.for b/dataassim/math/numrec/f77_sources/toeplz.for new file mode 100644 index 0000000..12f637f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/toeplz.for @@ -0,0 +1,55 @@ + SUBROUTINE toeplz(r,x,y,n) + INTEGER n,NMAX + REAL r(2*n-1),x(n),y(n) + PARAMETER (NMAX=100) + INTEGER j,k,m,m1,m2 + REAL pp,pt1,pt2,qq,qt1,qt2,sd,sgd,sgn,shn,sxn,g(NMAX),h(NMAX) + if(r(n).eq.0.) goto 99 + x(1)=y(1)/r(n) + if(n.eq.1)return + g(1)=r(n-1)/r(n) + h(1)=r(n+1)/r(n) + do 15 m=1,n + m1=m+1 + sxn=-y(m1) + sd=-r(n) + do 11 j=1,m + sxn=sxn+r(n+m1-j)*x(j) + sd=sd+r(n+m1-j)*g(m-j+1) +11 continue + if(sd.eq.0.)goto 99 + x(m1)=sxn/sd + do 12 j=1,m + x(j)=x(j)-x(m1)*g(m-j+1) +12 continue + if(m1.eq.n)return + sgn=-r(n-m1) + shn=-r(n+m1) + sgd=-r(n) + do 13 j=1,m + sgn=sgn+r(n+j-m1)*g(j) + shn=shn+r(n+m1-j)*h(j) + sgd=sgd+r(n+j-m1)*h(m-j+1) +13 continue + if(sd.eq.0..or.sgd.eq.0.)goto 99 + g(m1)=sgn/sgd + h(m1)=shn/sd + k=m + m2=(m+1)/2 + pp=g(m1) + qq=h(m1) + do 14 j=1,m2 + pt1=g(j) + pt2=g(k) + qt1=h(j) + qt2=h(k) + g(j)=pt1-pp*qt2 + g(k)=pt2-pp*qt1 + h(j)=qt1-qq*pt2 + h(k)=qt2-qq*pt1 + k=k-1 +14 continue +15 continue + pause 'never get here in toeplz' +99 pause 'singular principal minor in toeplz' + END diff --git a/dataassim/math/numrec/f77_sources/tptest.for b/dataassim/math/numrec/f77_sources/tptest.for new file mode 100644 index 0000000..9da1e55 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/tptest.for @@ -0,0 +1,19 @@ + SUBROUTINE tptest(data1,data2,n,t,prob) + INTEGER n + REAL prob,t,data1(n),data2(n) +CU USES avevar,betai + INTEGER j + REAL ave1,ave2,cov,df,sd,var1,var2,betai + call avevar(data1,n,ave1,var1) + call avevar(data2,n,ave2,var2) + cov=0. + do 11 j=1,n + cov=cov+(data1(j)-ave1)*(data2(j)-ave2) +11 continue + df=n-1 + cov=cov/df + sd=sqrt((var1+var2-2.*cov)/n) + t=(ave1-ave2)/sd + prob=betai(0.5*df,0.5,df/(df+t**2)) + return + END diff --git a/dataassim/math/numrec/f77_sources/tqli.for b/dataassim/math/numrec/f77_sources/tqli.for new file mode 100644 index 0000000..72c962f --- /dev/null +++ b/dataassim/math/numrec/f77_sources/tqli.for @@ -0,0 +1,59 @@ + SUBROUTINE tqli(d,e,n,np,z) + INTEGER n,np + REAL d(np),e(np),z(np,np) +CU USES pythag + INTEGER i,iter,k,l,m + REAL b,c,dd,f,g,p,r,s,pythag + do 11 i=2,n + e(i-1)=e(i) +11 continue + e(n)=0. + do 15 l=1,n + iter=0 +1 do 12 m=l,n-1 + dd=abs(d(m))+abs(d(m+1)) + if (abs(e(m))+dd.eq.dd) goto 2 +12 continue + m=n +2 if(m.ne.l)then + if(iter.eq.30)pause 'too many iterations in tqli' + iter=iter+1 + g=(d(l+1)-d(l))/(2.*e(l)) + r=pythag(g,1.) + g=d(m)-d(l)+e(l)/(g+sign(r,g)) + s=1. + c=1. + p=0. + do 14 i=m-1,l,-1 + f=s*e(i) + b=c*e(i) + r=pythag(f,g) + e(i+1)=r + if(r.eq.0.)then + d(i+1)=d(i+1)-p + e(m)=0. + goto 1 + endif + s=f/r + c=g/r + g=d(i+1)-p + r=(d(i)-g)*s+2.*c*b + p=s*r + d(i+1)=g+p + g=c*r-b +C Omit lines from here ... + do 13 k=1,n + f=z(k,i+1) + z(k,i+1)=s*z(k,i)+c*f + z(k,i)=c*z(k,i)-s*f +13 continue +C ... to here when finding only eigenvalues. +14 continue + d(l)=d(l)-p + e(l)=g + e(m)=0. + goto 1 + endif +15 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/trapzd.for b/dataassim/math/numrec/f77_sources/trapzd.for new file mode 100644 index 0000000..94c963e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/trapzd.for @@ -0,0 +1,22 @@ + SUBROUTINE trapzd(func,a,b,s,n) + INTEGER n + REAL a,b,s,func + EXTERNAL func + INTEGER it,j + REAL del,sum,tnm,x + if (n.eq.1) then + s=0.5*(b-a)*(func(a)+func(b)) + else + it=2**(n-2) + tnm=it + del=(b-a)/tnm + x=a+0.5*del + sum=0. + do 11 j=1,it + sum=sum+func(x) + x=x+del +11 continue + s=0.5*(s+(b-a)*sum/tnm) + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/tred2.for b/dataassim/math/numrec/f77_sources/tred2.for new file mode 100644 index 0000000..75e6d67 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/tred2.for @@ -0,0 +1,83 @@ + SUBROUTINE tred2(a,n,np,d,e) + INTEGER n,np + REAL a(np,np),d(np),e(np) + INTEGER i,j,k,l + REAL f,g,h,hh,scale + do 18 i=n,2,-1 + l=i-1 + h=0. + scale=0. + if(l.gt.1)then + do 11 k=1,l + scale=scale+abs(a(i,k)) +11 continue + if(scale.eq.0.)then + e(i)=a(i,l) + else + do 12 k=1,l + a(i,k)=a(i,k)/scale + h=h+a(i,k)**2 +12 continue + f=a(i,l) + g=-sign(sqrt(h),f) + e(i)=scale*g + h=h-f*g + a(i,l)=f-g + f=0. + do 15 j=1,l +C Omit following line if finding only eigenvalues + a(j,i)=a(i,j)/h + g=0. + do 13 k=1,j + g=g+a(j,k)*a(i,k) +13 continue + do 14 k=j+1,l + g=g+a(k,j)*a(i,k) +14 continue + e(j)=g/h + f=f+e(j)*a(i,j) +15 continue + hh=f/(h+h) + do 17 j=1,l + f=a(i,j) + g=e(j)-hh*f + e(j)=g + do 16 k=1,j + a(j,k)=a(j,k)-f*e(k)-g*a(i,k) +16 continue +17 continue + endif + else + e(i)=a(i,l) + endif + d(i)=h +18 continue +C Omit following line if finding only eigenvalues. + d(1)=0. + e(1)=0. + do 24 i=1,n +C Delete lines from here ... + l=i-1 + if(d(i).ne.0.)then + do 22 j=1,l + g=0. + do 19 k=1,l + g=g+a(i,k)*a(k,j) +19 continue + do 21 k=1,l + a(k,j)=a(k,j)-g*a(k,i) +21 continue +22 continue + endif +C ... to here when finding only eigenvalues. + d(i)=a(i,i) +C Also delete lines from here ... + a(i,i)=1. + do 23 j=1,l + a(i,j)=0. + a(j,i)=0. +23 continue +C ... to here when finding only eigenvalues. +24 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/tridag.for b/dataassim/math/numrec/f77_sources/tridag.for new file mode 100644 index 0000000..f3dca84 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/tridag.for @@ -0,0 +1,20 @@ + SUBROUTINE tridag(a,b,c,r,u,n) + INTEGER n,NMAX + REAL a(n),b(n),c(n),r(n),u(n) + PARAMETER (NMAX=500) + INTEGER j + REAL bet,gam(NMAX) + if(b(1).eq.0.)pause 'tridag: rewrite equations' + bet=b(1) + u(1)=r(1)/bet + do 11 j=2,n + gam(j)=c(j-1)/bet + bet=b(j)-a(j)*gam(j) + if(bet.eq.0.)pause 'tridag failed' + u(j)=(r(j)-a(j)*u(j-1))/bet +11 continue + do 12 j=n-1,1,-1 + u(j)=u(j)-gam(j+1)*u(j+1) +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/trncst.for b/dataassim/math/numrec/f77_sources/trncst.for new file mode 100644 index 0000000..c2cb651 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/trncst.for @@ -0,0 +1,19 @@ + SUBROUTINE trncst(x,y,iorder, ncity,n,de) + INTEGER ncity,iorder(ncity),n(6) + REAL de,x(ncity),y(ncity) + INTEGER ii,j + REAL xx(6),yy(6),alen,x1,x2,y1,y2 + alen(x1,x2,y1,y2)=sqrt((x2-x1)**2+(y2-y1)**2) + n(4)=1+mod(n(3),ncity) + n(5)=1+mod((n(1)+ncity-2),ncity) + n(6)=1+mod(n(2),ncity) + do 11 j=1,6 + ii=iorder(n(j)) + xx(j)=x(ii) + yy(j)=y(ii) +11 continue + de=-alen(xx(2),xx(6),yy(2),yy(6))-alen(xx(1),xx(5),yy(1), + *yy(5))-alen(xx(3),xx(4),yy(3),yy(4))+alen(xx(1),xx(3),yy(1), + *yy(3))+alen(xx(2),xx(4),yy(2),yy(4))+alen(xx(5),xx(6),yy(5),yy(6)) + return + END diff --git a/dataassim/math/numrec/f77_sources/trnspt.for b/dataassim/math/numrec/f77_sources/trnspt.for new file mode 100644 index 0000000..3133601 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/trnspt.for @@ -0,0 +1,28 @@ + SUBROUTINE trnspt(iorder,ncity,n) + INTEGER ncity,iorder(ncity),n(6),MXCITY + PARAMETER (MXCITY=1000) + INTEGER j,jj,m1,m2,m3,nn,jorder(MXCITY) + m1=1+mod((n(2)-n(1)+ncity),ncity) + m2=1+mod((n(5)-n(4)+ncity),ncity) + m3=1+mod((n(3)-n(6)+ncity),ncity) + nn=1 + do 11 j=1,m1 + jj=1+mod((j+n(1)-2),ncity) + jorder(nn)=iorder(jj) + nn=nn+1 +11 continue + do 12 j=1,m2 + jj=1+mod((j+n(4)-2),ncity) + jorder(nn)=iorder(jj) + nn=nn+1 +12 continue + do 13 j=1,m3 + jj=1+mod((j+n(6)-2),ncity) + jorder(nn)=iorder(jj) + nn=nn+1 +13 continue + do 14 j=1,ncity + iorder(j)=jorder(j) +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/ttest.for b/dataassim/math/numrec/f77_sources/ttest.for new file mode 100644 index 0000000..e397c5c --- /dev/null +++ b/dataassim/math/numrec/f77_sources/ttest.for @@ -0,0 +1,13 @@ + SUBROUTINE ttest(data1,n1,data2,n2,t,prob) + INTEGER n1,n2 + REAL prob,t,data1(n1),data2(n2) +CU USES avevar,betai + REAL ave1,ave2,df,var,var1,var2,betai + call avevar(data1,n1,ave1,var1) + call avevar(data2,n2,ave2,var2) + df=n1+n2-2 + var=((n1-1)*var1+(n2-1)*var2)/df + t=(ave1-ave2)/sqrt(var*(1./n1+1./n2)) + prob=betai(0.5*df,0.5,df/(df+t**2)) + return + END diff --git a/dataassim/math/numrec/f77_sources/tutest.for b/dataassim/math/numrec/f77_sources/tutest.for new file mode 100644 index 0000000..222bc74 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/tutest.for @@ -0,0 +1,12 @@ + SUBROUTINE tutest(data1,n1,data2,n2,t,prob) + INTEGER n1,n2 + REAL prob,t,data1(n1),data2(n2) +CU USES avevar,betai + REAL ave1,ave2,df,var1,var2,betai + call avevar(data1,n1,ave1,var1) + call avevar(data2,n2,ave2,var2) + t=(ave1-ave2)/sqrt(var1/n1+var2/n2) + df=(var1/n1+var2/n2)**2/((var1/n1)**2/(n1-1)+(var2/n2)**2/(n2-1)) + prob=betai(0.5*df,0.5,df/(df+t**2)) + return + END diff --git a/dataassim/math/numrec/f77_sources/twofft.for b/dataassim/math/numrec/f77_sources/twofft.for new file mode 100644 index 0000000..4a120d8 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/twofft.for @@ -0,0 +1,26 @@ + SUBROUTINE twofft(data1,data2,fft1,fft2,n) + INTEGER n + REAL data1(n),data2(n) + COMPLEX fft1(n),fft2(n) +CU USES four1 + INTEGER j,n2 + COMPLEX h1,h2,c1,c2 + c1=cmplx(0.5,0.0) + c2=cmplx(0.0,-0.5) + do 11 j=1,n + fft1(j)=cmplx(data1(j),data2(j)) +11 continue + call four1(fft1,n,1) + fft2(1)=cmplx(aimag(fft1(1)),0.0) + fft1(1)=cmplx(real(fft1(1)),0.0) + n2=n+2 + do 12 j=2,n/2+1 + h1=c1*(fft1(j)+conjg(fft1(n2-j))) + h2=c2*(fft1(j)-conjg(fft1(n2-j))) + fft1(j)=h1 + fft1(n2-j)=conjg(h1) + fft2(j)=h2 + fft2(n2-j)=conjg(h2) +12 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/vander.for b/dataassim/math/numrec/f77_sources/vander.for new file mode 100644 index 0000000..b74f47b --- /dev/null +++ b/dataassim/math/numrec/f77_sources/vander.for @@ -0,0 +1,35 @@ + SUBROUTINE vander(x,w,q,n) + INTEGER n,NMAX + DOUBLE PRECISION q(n),w(n),x(n) + PARAMETER (NMAX=100) + INTEGER i,j,k + DOUBLE PRECISION b,s,t,xx,c(NMAX) + if(n.eq.1)then + w(1)=q(1) + else + do 11 i=1,n + c(i)=0.d0 +11 continue + c(n)=-x(1) + do 13 i=2,n + xx=-x(i) + do 12 j=n+1-i,n-1 + c(j)=c(j)+xx*c(j+1) +12 continue + c(n)=c(n)+xx +13 continue + do 15 i=1,n + xx=x(i) + t=1.d0 + b=1.d0 + s=q(n) + do 14 k=n,2,-1 + b=c(k)+xx*b + s=s+q(k-1)*b + t=xx*t+b +14 continue + w(i)=s/t +15 continue + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/vegas.for b/dataassim/math/numrec/f77_sources/vegas.for new file mode 100644 index 0000000..3136e57 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/vegas.for @@ -0,0 +1,168 @@ + SUBROUTINE vegas(region,ndim,fxn,init,ncall,itmx,nprn,tgral,sd, + *chi2a) + INTEGER init,itmx,ncall,ndim,nprn,NDMX,MXDIM + REAL tgral,chi2a,sd,region(2*ndim),fxn,ALPH,TINY + PARAMETER (ALPH=1.5,NDMX=50,MXDIM=10,TINY=1.e-30) + EXTERNAL fxn +CU USES fxn,ran2,rebin + INTEGER i,idum,it,j,k,mds,nd,ndo,ng,npg,ia(MXDIM),kg(MXDIM) + REAL calls,dv2g,dxg,f,f2,f2b,fb,rc,ti,tsi,wgt,xjac,xn,xnd,xo, + *d(NDMX,MXDIM),di(NDMX,MXDIM),dt(MXDIM),dx(MXDIM),r(NDMX),x(MXDIM), + *xi(NDMX,MXDIM),xin(NDMX),ran2 + DOUBLE PRECISION schi,si,swgt + COMMON /ranno/ idum + SAVE + if(init.le.0)then + mds=1 + ndo=1 + do 11 j=1,ndim + xi(1,j)=1. +11 continue + endif + if (init.le.1)then + si=0. + swgt=0. + schi=0. + endif + if (init.le.2)then + nd=NDMX + ng=1 + if(mds.ne.0)then + ng=(ncall/2.+0.25)**(1./ndim) + mds=1 + if((2*ng-NDMX).ge.0)then + mds=-1 + npg=ng/NDMX+1 + nd=ng/npg + ng=npg*nd + endif + endif + k=ng**ndim + npg=max(ncall/k,2) + calls=float(npg)*float(k) + dxg=1./ng + dv2g=(calls*dxg**ndim)**2/npg/npg/(npg-1.) + xnd=nd + dxg=dxg*xnd + xjac=1./calls + do 12 j=1,ndim + dx(j)=region(j+ndim)-region(j) + xjac=xjac*dx(j) +12 continue + if(nd.ne.ndo)then + do 13 i=1,max(nd,ndo) + r(i)=1. +13 continue + do 14 j=1,ndim + call rebin(ndo/xnd,nd,r,xin,xi(1,j)) +14 continue + ndo=nd + endif + if(nprn.ge.0) write(*,200) ndim,calls,it,itmx,nprn,ALPH,mds,nd, + *(j,region(j),j,region(j+ndim),j=1,ndim) + endif + do 28 it=1,itmx + ti=0. + tsi=0. + do 16 j=1,ndim + kg(j)=1 + do 15 i=1,nd + d(i,j)=0. + di(i,j)=0. +15 continue +16 continue +10 continue + fb=0. + f2b=0. + do 19 k=1,npg + wgt=xjac + do 17 j=1,ndim + xn=(kg(j)-ran2(idum))*dxg+1. + ia(j)=max(min(int(xn),NDMX),1) + if(ia(j).gt.1)then + xo=xi(ia(j),j)-xi(ia(j)-1,j) + rc=xi(ia(j)-1,j)+(xn-ia(j))*xo + else + xo=xi(ia(j),j) + rc=(xn-ia(j))*xo + endif + x(j)=region(j)+rc*dx(j) + wgt=wgt*xo*xnd +17 continue + f=wgt*fxn(x,wgt) + f2=f*f + fb=fb+f + f2b=f2b+f2 + do 18 j=1,ndim + di(ia(j),j)=di(ia(j),j)+f + if(mds.ge.0) d(ia(j),j)=d(ia(j),j)+f2 +18 continue +19 continue + f2b=sqrt(f2b*npg) + f2b=(f2b-fb)*(f2b+fb) + if (f2b.le.0.) f2b=TINY + ti=ti+fb + tsi=tsi+f2b + if(mds.lt.0)then + do 21 j=1,ndim + d(ia(j),j)=d(ia(j),j)+f2b +21 continue + endif + do 22 k=ndim,1,-1 + kg(k)=mod(kg(k),ng)+1 + if(kg(k).ne.1) goto 10 +22 continue + tsi=tsi*dv2g + wgt=1./tsi + si=si+dble(wgt)*dble(ti) + schi=schi+dble(wgt)*dble(ti)**2 + swgt=swgt+dble(wgt) + tgral=si/swgt + chi2a=max((schi-si*tgral)/(it-.99d0),0.d0) + sd=sqrt(1./swgt) + tsi=sqrt(tsi) + if(nprn.ge.0)then + write(*,201) it,ti,tsi,tgral,sd,chi2a + if(nprn.ne.0)then + do 23 j=1,ndim + write(*,202) j,(xi(i,j),di(i,j),i=1+nprn/2,nd,nprn) +23 continue + endif + endif + do 25 j=1,ndim + xo=d(1,j) + xn=d(2,j) + d(1,j)=(xo+xn)/2. + dt(j)=d(1,j) + do 24 i=2,nd-1 + rc=xo+xn + xo=xn + xn=d(i+1,j) + d(i,j)=(rc+xn)/3. + dt(j)=dt(j)+d(i,j) +24 continue + d(nd,j)=(xo+xn)/2. + dt(j)=dt(j)+d(nd,j) +25 continue + do 27 j=1,ndim + rc=0. + do 26 i=1,nd + if(d(i,j).lt.TINY) d(i,j)=TINY + r(i)=((1.-d(i,j)/dt(j))/(log(dt(j))-log(d(i,j))))**ALPH + rc=rc+r(i) +26 continue + call rebin(rc/xnd,nd,r,xin,xi(1,j)) +27 continue +28 continue + return +200 FORMAT(/' input parameters for vegas: ndim=',i3,' ncall=', + *f8.0/28x,' it=',i5,' itmx=',i5/28x,' nprn=',i3,' alph=', + *f5.2/28x,' mds=',i3,' nd=',i4/(30x,'xl(',i2,')= ',g11.4,' xu(', + *i2,')= ',g11.4)) +201 FORMAT(/' iteration no.',I3,': ','integral =',g14.7,'+/- ',g9.2/ + *' all iterations: integral =',g14.7,'+/- ',g9.2, + *' chi**2/it''n =',g9.2) +202 FORMAT(/' data for axis ',I2/' X delta i ', + *' x delta i ',' x delta i ',/(1x, + *f7.5,1x,g11.4,5x,f7.5,1x,g11.4,5x,f7.5,1x,g11.4)) + END diff --git a/dataassim/math/numrec/f77_sources/voltra.for b/dataassim/math/numrec/f77_sources/voltra.for new file mode 100644 index 0000000..0614826 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/voltra.for @@ -0,0 +1,38 @@ + SUBROUTINE voltra(n,m,t0,h,t,f,g,ak) + INTEGER m,n,MMAX + REAL h,t0,f(m,n),t(n),g,ak + EXTERNAL ak,g + PARAMETER (MMAX=5) +CU USES ak,g,lubksb,ludcmp + INTEGER i,j,k,l,indx(MMAX) + REAL d,sum,a(MMAX,MMAX),b(MMAX) + t(1)=t0 + do 11 k=1,m + f(k,1)=g(k,t(1)) +11 continue + do 16 i=2,n + t(i)=t(i-1)+h + do 14 k=1,m + sum=g(k,t(i)) + do 13 l=1,m + sum=sum+0.5*h*ak(k,l,t(i),t(1))*f(l,1) + do 12 j=2,i-1 + sum=sum+h*ak(k,l,t(i),t(j))*f(l,j) +12 continue + if(k.eq.l)then + a(k,l)=1. + else + a(k,l)=0. + endif + a(k,l)=a(k,l)-0.5*h*ak(k,l,t(i),t(i)) +13 continue + b(k)=sum +14 continue + call ludcmp(a,m,MMAX,indx,d) + call lubksb(a,m,MMAX,indx,b) + do 15 k=1,m + f(k,i)=b(k) +15 continue +16 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/wt1.for b/dataassim/math/numrec/f77_sources/wt1.for new file mode 100644 index 0000000..abd735e --- /dev/null +++ b/dataassim/math/numrec/f77_sources/wt1.for @@ -0,0 +1,24 @@ + SUBROUTINE wt1(a,n,isign,wtstep) + INTEGER isign,n + REAL a(n) + EXTERNAL wtstep +CU USES wtstep + INTEGER nn + if (n.lt.4) return + if (isign.ge.0) then + nn=n +1 if (nn.ge.4) then + call wtstep(a,nn,isign) + nn=nn/2 + goto 1 + endif + else + nn=4 +2 if (nn.le.n) then + call wtstep(a,nn,isign) + nn=nn*2 + goto 2 + endif + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/wtn.for b/dataassim/math/numrec/f77_sources/wtn.for new file mode 100644 index 0000000..a874996 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/wtn.for @@ -0,0 +1,51 @@ + SUBROUTINE wtn(a,nn,ndim,isign,wtstep) + INTEGER isign,ndim,nn(ndim),NMAX + REAL a(*) + EXTERNAL wtstep + PARAMETER (NMAX=1024) +CU USES wtstep + INTEGER i1,i2,i3,idim,k,n,nnew,nprev,nt,ntot + REAL wksp(NMAX) + ntot=1 + do 11 idim=1,ndim + ntot=ntot*nn(idim) +11 continue + nprev=1 + do 16 idim=1,ndim + n=nn(idim) + nnew=n*nprev + if (n.gt.4) then + do 15 i2=0,ntot-1,nnew + do 14 i1=1,nprev + i3=i1+i2 + do 12 k=1,n + wksp(k)=a(i3) + i3=i3+nprev +12 continue + if (isign.ge.0) then + nt=n +1 if (nt.ge.4) then + call wtstep(wksp,nt,isign) + nt=nt/2 + goto 1 + endif + else + nt=4 +2 if (nt.le.n) then + call wtstep(wksp,nt,isign) + nt=nt*2 + goto 2 + endif + endif + i3=i1+i2 + do 13 k=1,n + a(i3)=wksp(k) + i3=i3+nprev +13 continue +14 continue +15 continue + endif + nprev=nnew +16 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/wwghts.for b/dataassim/math/numrec/f77_sources/wwghts.for new file mode 100644 index 0000000..a3ca0b3 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/wwghts.for @@ -0,0 +1,52 @@ + SUBROUTINE wwghts(wghts,n,h,kermom) + INTEGER n + REAL wghts(n),h + EXTERNAL kermom +CU USES kermom + INTEGER j,k + DOUBLE PRECISION wold(4),wnew(4),w(4),hh,hi,c,fac,a,b + hh=h + hi=1.d0/hh + do 11 j=1,n + wghts(j)=0. +11 continue + call kermom(wold,0.d0,4) + if (n.ge.4) then + b=0.d0 + do 14 j=1,n-3 + c=j-1 + a=b + b=a+hh + if (j.eq.n-3) b=(n-1)*hh + call kermom(wnew,b,4) + fac=1.d0 + do 12 k=1,4 + w(k)=(wnew(k)-wold(k))*fac + fac=fac*hi +12 continue + wghts(j)=wghts(j)+((c+1.d0)*(c+2.d0)*(c+3.d0)*w(1)-(11.d0+c* + *(12.d0+c*3.d0))*w(2)+3.d0*(c+2.d0)*w(3)-w(4))/6.d0 + wghts(j+1)=wghts(j+1)+(-c*(c+2.d0)*(c+3.d0)*w(1)+(6.d0+c* + *(10.d0+c*3.d0))*w(2)-(3.d0*c+5.d0)*w(3)+w(4))*.5d0 + wghts(j+2)=wghts(j+2)+(c*(c+1.d0)*(c+3.d0)*w(1)-(3.d0+c*(8.d0+ + *c*3.d0))*w(2)+(3.d0*c+4.d0)*w(3)-w(4))*.5d0 + wghts(j+3)=wghts(j+3)+(-c*(c+1.d0)*(c+2.d0)*w(1)+(2.d0+c* + *(6.d0+c*3.d0))*w(2)-3.d0*(c+1.d0)*w(3)+w(4))/6.d0 + do 13 k=1,4 + wold(k)=wnew(k) +13 continue +14 continue + else if (n.eq.3) then + call kermom(wnew,hh+hh,3) + w(1)=wnew(1)-wold(1) + w(2)=hi*(wnew(2)-wold(2)) + w(3)=hi**2*(wnew(3)-wold(3)) + wghts(1)=w(1)-1.5d0*w(2)+0.5d0*w(3) + wghts(2)=2.d0*w(2)-w(3) + wghts(3)=0.5d0*(w(3)-w(2)) + else if (n.eq.2) then + call kermom(wnew,hh,2) + wghts(2)=hi*(wnew(2)-wold(2)) + wghts(1)=wnew(1)-wold(1)-wghts(2) + endif + END diff --git a/dataassim/math/numrec/f77_sources/zbrac.for b/dataassim/math/numrec/f77_sources/zbrac.for new file mode 100644 index 0000000..51a0dc5 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/zbrac.for @@ -0,0 +1,25 @@ + SUBROUTINE zbrac(func,x1,x2,succes) + INTEGER NTRY + REAL x1,x2,func,FACTOR + EXTERNAL func + PARAMETER (FACTOR=1.6,NTRY=50) + INTEGER j + REAL f1,f2 + LOGICAL succes + if(x1.eq.x2)pause 'you have to guess an initial range in zbrac' + f1=func(x1) + f2=func(x2) + succes=.true. + do 11 j=1,NTRY + if(f1*f2.lt.0.)return + if(abs(f1).lt.abs(f2))then + x1=x1+FACTOR*(x1-x2) + f1=func(x1) + else + x2=x2+FACTOR*(x2-x1) + f2=func(x2) + endif +11 continue + succes=.false. + return + END diff --git a/dataassim/math/numrec/f77_sources/zbrak.for b/dataassim/math/numrec/f77_sources/zbrak.for new file mode 100644 index 0000000..c60c861 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/zbrak.for @@ -0,0 +1,25 @@ + SUBROUTINE zbrak(fx,x1,x2,n,xb1,xb2,nb) + INTEGER n,nb + REAL x1,x2,xb1(nb),xb2(nb),fx + EXTERNAL fx + INTEGER i,nbb + REAL dx,fc,fp,x + nbb=0 + x=x1 + dx=(x2-x1)/n + fp=fx(x) + do 11 i=1,n + x=x+dx + fc=fx(x) + if(fc*fp.le.0.) then + nbb=nbb+1 + xb1(nbb)=x-dx + xb2(nbb)=x + if(nbb.eq.nb)goto 1 + endif + fp=fc +11 continue +1 continue + nb=nbb + return + END diff --git a/dataassim/math/numrec/f77_sources/zbrent.for b/dataassim/math/numrec/f77_sources/zbrent.for new file mode 100644 index 0000000..d7f4ef4 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/zbrent.for @@ -0,0 +1,73 @@ + FUNCTION zbrent(func,x1,x2,tol) + INTEGER ITMAX + REAL zbrent,tol,x1,x2,func,EPS + EXTERNAL func + PARAMETER (ITMAX=100,EPS=3.e-8) + INTEGER iter + REAL a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm + a=x1 + b=x2 + fa=func(a) + fb=func(b) + if((fa.gt.0..and.fb.gt.0.).or.(fa.lt.0..and.fb.lt.0.))pause + *'root must be bracketed for zbrent' + c=b + fc=fb + do 11 iter=1,ITMAX + if((fb.gt.0..and.fc.gt.0.).or.(fb.lt.0..and.fc.lt.0.))then + c=a + fc=fa + d=b-a + e=d + endif + if(abs(fc).lt.abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + endif + tol1=2.*EPS*abs(b)+0.5*tol + xm=.5*(c-b) + if(abs(xm).le.tol1 .or. fb.eq.0.)then + zbrent=b + return + endif + if(abs(e).ge.tol1 .and. abs(fa).gt.abs(fb)) then + s=fb/fa + if(a.eq.c) then + p=2.*xm*s + q=1.-s + else + q=fa/fc + r=fb/fc + p=s*(2.*xm*q*(q-r)-(b-a)*(r-1.)) + q=(q-1.)*(r-1.)*(s-1.) + endif + if(p.gt.0.) q=-q + p=abs(p) + if(2.*p .lt. min(3.*xm*q-abs(tol1*q),abs(e*q))) then + e=d + d=p/q + else + d=xm + e=d + endif + else + d=xm + e=d + endif + a=b + fa=fb + if(abs(d) .gt. tol1) then + b=b+d + else + b=b+sign(tol1,xm) + endif + fb=func(b) +11 continue + pause 'zbrent exceeding maximum iterations' + zbrent=b + return + END diff --git a/dataassim/math/numrec/f77_sources/zrhqr.for b/dataassim/math/numrec/f77_sources/zrhqr.for new file mode 100644 index 0000000..3183aae --- /dev/null +++ b/dataassim/math/numrec/f77_sources/zrhqr.for @@ -0,0 +1,31 @@ + SUBROUTINE zrhqr(a,m,rtr,rti) + INTEGER m,MAXM + REAL a(m+1),rtr(m),rti(m) + PARAMETER (MAXM=50) +CU USES balanc,hqr + INTEGER j,k + REAL hess(MAXM,MAXM),xr,xi + if (m.gt.MAXM.or.a(m+1).eq.0.) pause 'bad args in zrhqr' + do 12 k=1,m + hess(1,k)=-a(m+1-k)/a(m+1) + do 11 j=2,m + hess(j,k)=0. +11 continue + if (k.ne.m) hess(k+1,k)=1. +12 continue + call balanc(hess,m,MAXM) + call hqr(hess,m,MAXM,rtr,rti) + do 14 j=2,m + xr=rtr(j) + xi=rti(j) + do 13 k=j-1,1,-1 + if(rtr(k).le.xr)goto 1 + rtr(k+1)=rtr(k) + rti(k+1)=rti(k) +13 continue + k=0 +1 rtr(k+1)=xr + rti(k+1)=xi +14 continue + return + END diff --git a/dataassim/math/numrec/f77_sources/zriddr.for b/dataassim/math/numrec/f77_sources/zriddr.for new file mode 100644 index 0000000..922def3 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/zriddr.for @@ -0,0 +1,50 @@ + FUNCTION zriddr(func,x1,x2,xacc) + INTEGER MAXIT + REAL zriddr,x1,x2,xacc,func,UNUSED + PARAMETER (MAXIT=60,UNUSED=-1.11E30) + EXTERNAL func +CU USES func + INTEGER j + REAL fh,fl,fm,fnew,s,xh,xl,xm,xnew + fl=func(x1) + fh=func(x2) + if((fl.gt.0..and.fh.lt.0.).or.(fl.lt.0..and.fh.gt.0.))then + xl=x1 + xh=x2 + zriddr=UNUSED + do 11 j=1,MAXIT + xm=0.5*(xl+xh) + fm=func(xm) + s=sqrt(fm**2-fl*fh) + if(s.eq.0.)return + xnew=xm+(xm-xl)*(sign(1.,fl-fh)*fm/s) + if (abs(xnew-zriddr).le.xacc) return + zriddr=xnew + fnew=func(zriddr) + if (fnew.eq.0.) return + if(sign(fm,fnew).ne.fm) then + xl=xm + fl=fm + xh=zriddr + fh=fnew + else if(sign(fl,fnew).ne.fl) then + xh=zriddr + fh=fnew + else if(sign(fh,fnew).ne.fh) then + xl=zriddr + fl=fnew + else + pause 'never get here in zriddr' + endif + if(abs(xh-xl).le.xacc) return +11 continue + pause 'zriddr exceed maximum iterations' + else if (fl.eq.0.) then + zriddr=x1 + else if (fh.eq.0.) then + zriddr=x2 + else + pause 'root must be bracketed in zriddr' + endif + return + END diff --git a/dataassim/math/numrec/f77_sources/zroots.for b/dataassim/math/numrec/f77_sources/zroots.for new file mode 100644 index 0000000..be06ac6 --- /dev/null +++ b/dataassim/math/numrec/f77_sources/zroots.for @@ -0,0 +1,40 @@ + SUBROUTINE zroots(a,m,roots,polish) + INTEGER m,MAXM + REAL EPS + COMPLEX a(m+1),roots(m) + LOGICAL polish + PARAMETER (EPS=1.e-6,MAXM=101) +CU USES laguer + INTEGER i,j,jj,its + COMPLEX ad(MAXM),x,b,c + do 11 j=1,m+1 + ad(j)=a(j) +11 continue + do 13 j=m,1,-1 + x=cmplx(0.,0.) + call laguer(ad,j,x,its) + if(abs(aimag(x)).le.2.*EPS**2*abs(real(x))) x=cmplx(real(x),0.) + roots(j)=x + b=ad(j+1) + do 12 jj=j,1,-1 + c=ad(jj) + ad(jj)=b + b=x*b+c +12 continue +13 continue + if (polish) then + do 14 j=1,m + call laguer(a,m,roots(j),its) +14 continue + endif + do 16 j=2,m + x=roots(j) + do 15 i=j-1,1,-1 + if(real(roots(i)).le.real(x))goto 10 + roots(i+1)=roots(i) +15 continue + i=0 +10 roots(i+1)=x +16 continue + return + END diff --git a/dataassim/math/optimization/CompassSearch.f b/dataassim/math/optimization/CompassSearch.f new file mode 100644 index 0000000..86e635f --- /dev/null +++ b/dataassim/math/optimization/CompassSearch.f @@ -0,0 +1,210 @@ + subroutine RepeatCompassSearch(ndim,xbest,fbest, + & bmin,bmax,funkmin,f1dim,xtol) + implicit none + integer ndim + double precision xbest(1:ndim),fbest, + & bmin(1:ndim),bmax(1:ndim),xtol + double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim) + integer i,n + logical resetran2 + common /ran2reset/resetran2 + external funkmin,f1dim +! + ftol=xtol + n=0 + resetran2=.true. +10 fvalpre=fbest + do i=1,ndim + xpre(i)=xbest(i) + enddo + call CompassSearch(ndim,xbest,fbest, + & bmin,bmax,funkmin,f1dim,xtol) + n=n+1 + dmax=dabs(xbest(1)-xpre(1)) + do i=2,ndim + if(dmax.lt.dabs(xbest(i)-xpre(i)))then + dmax=dabs(xbest(i)-xpre(i)) + endif + enddo + if(dabs(fvalpre-fbest).gt.ftol.and. + & dmax.gt.xtol.and.n.lt.2)then + do i=1,ndim + direction(i)=xbest(i)-xpre(i) + enddo + call linmin(xbest,bmin,bmax,direction, + & ndim,f1dim,fbest) + goto 10 + endif + return + end subroutine RepeatCompassSearch + + subroutine CompassSearch(ndim,xbest,fbest, + & bmin,bmax,funkmin,f1dim,xtol) + implicit none + +! This subroutine minimizes the function funkmin using the compass search method. The ! maximum number of function evaluations is maxiter. Once mexiter is reached, all +! function evaluations are ranked and returned. +! +!------------------------------------- Inputs ----------------------------------------------------- +! maxiter: the maximum number of function evaluations allowed +! xbest: the initial guess +! fbest: the cost function value at xinitial +! bmin: the lower bounds of the parameters to be optimized +! bmax: the upper bounds of the parameters to be optimized +! ndim: the number of parameters to optimize +! funkmin: the name of the function to minimize + +!------------------------------------- Outputs --------------------------------------------------- +! xobs: points where the function is evaluated. Ranked from the best to worst with the +! first point being the best point. +! fvalue: the function values at xobs +! ierr: =0 convergence criterion not reached +! =1 convergence criterion reached (minimum found) +! + integer ndim + double precision xbest(1:ndim),fbest, + & bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2 + external funkmin,f1dim +!------------------------------- Locals ----------------------------------------------------------- + double precision diftol,delta, + & xcompass(1:2*ndim,1:ndim),fcompass(1:2*ndim), + & xvec(1:ndim),xcent(1:ndim),fcent,dif,shrink, + & direction(ndim),dmax,fcent0,ran2_reset,ran2 + integer i,j,k,iter + parameter(shrink=0.618d0) +! + diftol=xtol + delta=0.618d0 + do i=1,ndim + xcent(i)=xbest(i) + enddo + fcent=fbest + iter=0 +10 continue + do i=1,ndim + do j=1,ndim + xcompass(i,j)=xcent(j) + xcompass(ndim+i,j)=xcent(j) + enddo + xcompass(i,i)=xcent(i)+delta*(bmax(i)-xcent(i)) + xcompass(ndim+i,i)=xcent(i)+delta*(bmin(i)-xcent(i)) + enddo + do i=1,2*ndim + do j=1,ndim + xvec(j)=xcompass(i,j) + enddo + call funkmin(ndim,xvec,fcompass(i)) + if(dabs(fcompass(i)).gt.1.0d+90)then + delta=delta*shrink + if(delta.lt.diftol)goto 100 + goto 10 + endif + enddo + do i=1,ndim + xbest(i)=xcompass(1,i) + enddo + fbest=fcompass(1) + do i=2,2*ndim + if(fcompass(i).lt.fbest)then + fbest=fcompass(i) + do j=1,ndim + xbest(j)=xcompass(i,j) + enddo + endif + enddo + fcent0=fcent + do i=1,ndim + xvec(i)=xcent(i) + enddo + do i=1,ndim + dx1=xcompass(i,i)-xcent(i) + dx2=xcent(i)-xcompass(i+ndim,i) + direction(i)=0.0d0 + if(dx1.ne.0.0d0)then + direction(i)=(fcompass(i)-fcent)/dx1 + endif + if(dx2.ne.0.0d0)then + direction(i)=direction(i)+ + & (fcent-fcompass(i+ndim))/dx2 + endif + direction(i)=-0.5d0*direction(i) + if(direction(i).eq.0.0d0)direction(i)= + & ran2_reset()-0.5d0 + enddo + call linmin(xcent,bmin,bmax,direction, + & ndim,f1dim,fcent) + if(fcent.gt.fcent0)then + fcent=fcent0 + do i=1,ndim + xcent(i)=xvec(i) + enddo + endif + dif=fcent-fbest + if(fbest.le.fcent)then + fcent=fbest + do i=1,ndim + xcent(i)=xbest(i) + enddo + endif + if(dif.ge.0.0d0)then + if(dif.gt.diftol)then + if(iter.lt.150)then + iter=iter+1 + goto 10 + else + iter=0 + endif + endif + if(delta.lt.diftol)goto 100 + delta=delta*shrink + goto 10 + else +!no progress + if(dabs(dif).gt.diftol)then + if(delta.lt.diftol)goto 100 + delta=delta*shrink + goto 10 + endif + dmax=dabs(xcompass(1,1)-xcompass(ndim+1,1)) + do i=2,ndim + if(dmax.lt.dabs(xcompass(i,i)- + & xcompass(ndim+i,i)))then + dmax=dabs(xcompass(i,i)- + & xcompass(ndim+i,i)) + endif + enddo + if(dmax.gt.xtol)then + if(delta.lt.diftol)goto 100 + delta=delta*shrink + goto 10 + else + goto 100 + endif + endif +100 fbest=fcent + do i=1,ndim + xbest(i)=xcent(i) + dx1=xcompass(i,i)-xcent(i) + dx2=xcent(i)-xcompass(i+ndim,i) + direction(i)=0.0d0 + if(dx1.ne.0.0d0)then + direction(i)=(fcompass(i)-fcent)/dx1 + endif + if(dx2.ne.0.0d0)then + direction(i)=direction(i)+ + & (fcent-fcompass(i+ndim))/dx2 + endif + direction(i)=-0.5d0*direction(i) + if(direction(i).eq.0.0d0)direction(i)= + & ran2_reset()-0.5d0 + enddo + call linmin(xcent,bmin,bmax,direction, + & ndim,f1dim,fcent) + if(fcent.lt.fbest)then + fbest=fcent + do i=1,ndim + xbest(i)=xcent(i) + enddo + endif + return + end subroutine CompassSearch diff --git a/dataassim/math/optimization/Externals_GenericRegres.f b/dataassim/math/optimization/Externals_GenericRegres.f new file mode 100644 index 0000000..79a13c3 --- /dev/null +++ b/dataassim/math/optimization/Externals_GenericRegres.f @@ -0,0 +1,361 @@ + subroutine funkmin_generic(ndim,beta,fvalue) + implicit none + include 'forgenericregres.h' + integer ndim + double precision beta(ndim),fvalue +!(in) ndim: the dimension of the parameter vector +!(in) beta: the parameters +!(out) fvalue: the value of the cost function at beta +!----------------------------------------------------- + integer i,j,idowhat,nparams + double precision dydxp(nyvars,(nxvars+ndim)) +! +! check to see if parameters are out of bounds + if(idobounded.eq.1)then + if(betamin(1).lt.betamax(1))then + do i=1,ndim + if(beta(i).lt.betamin(i).or. + &beta(i).gt.betamax(i))then +! parameter out of bound + fvalue=1.0d+100 + return + endif + enddo + endif + endif + fvalue=0.0d0 + if(iregrestype.eq.1)then +!orthogonal distance regression + do i=1,nobs + call shortestdist(nyvars,nxvars,yobs(i:i,1:nyvars), + & xvars(i:i,1:nxvars),xmin(i:i,1:nxvars), + & xmax(i:i,1:nxvars),ndim,beta,iknowder, + & shorty(i:i,1:nyvars),shortx(i:i,1:nxvars)) + do j=1,nyvars + fvalue=fvalue+weity(i,j)* + & (shorty(i,j)-yobs(i,j))**2 + enddo + do j=1,nxvars + fvalue=fvalue+weitx(i,j)* + & (shortx(i,j)-xvars(i,j))**2 + enddo + enddo + endif + if(iregrestype.eq.0)then + idowhat=0 + do i=1,nobs + call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars, + & xvars(i:i,1:nxvars),ndim,beta, + & dydxp(1:nyvars,1:(nxvars+ndim)),idowhat) + do j=1,nyvars + fvalue=fvalue+weity(i,j)* + & (shorty(i,j)-yobs(i,j))**2 + enddo + enddo + endif + if(iregrestype.eq.2)then + nparams=ndim-nobs + idowhat=nparams + do i=1,nobs + do j=1,nxvars + idowhat=idowhat+1 + shortx(i,j)=beta(idowhat) + enddo + enddo + idowhat=0 + do i=1,nobs + call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars, + & shortx(i:i,1:nxvars),nparams,beta, + & dydxp(1:nyvars,1:(nxvars+ndim)),idowhat) + do j=1,nyvars + fvalue=fvalue+weity(i,j)* + & (shorty(i,j)-yobs(i,j))**2 + enddo + do j=1,nxvars + fvalue=fvalue+weitx(i,j)* + & (shortx(i,j)-xvars(i,j))**2 + enddo + enddo + endif + if(iregrestype.eq.-1)then +!implicit orthogonal distance regression + idowhat=0 + do i=1,nobs + call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars, + & xvars(i:i,1:nxvars),ndim,beta, + & dydxp(1:nyvars,1:(nxvars+ndim)),idowhat) + do j=1,nyvars + fvalue=fvalue+weity(i,j)* + & shorty(i,j)**2 + enddo + enddo + endif + return + end subroutine funkmin_generic +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function f1dim_generic(x) + implicit none + double precision x +CU USES funkmin_generic + INTEGER j +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /f1com/ pcom,xicom,ncom + save /f1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + double precision xt(NMAX) +!----------------------------------------------------- + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call funkmin_generic(ncom,xt,f1dim_generic) + return + END +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + SUBROUTINE FCN_generic(N,M,NP,NQ, + + LDN,LDM,LDNP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,F,FJACB,FJACD, + + ISTOP) + implicit none + include 'forgenericregres.h' + +C SUBROUTINE ARGUMENTS +C ==> N NUMBER OF OBSERVATIONS +C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N +C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M +C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP +C ==> BETA CURRENT VALUES OF PARAMETERS +C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED +C <== F PREDICTED FUNCTION VALUES +C <== FJACB JACOBIAN WITH RESPECT TO BETA +C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA +C <== ISTOP STOPPING CONDITION, WHERE +C 0 MEANS CURRENT BETA AND X+DELTA WERE +C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY +C 1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES +C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE +C -1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD STOP + +C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE: + INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ + DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M) + INTEGER IFIXB(NP),IFIXX(LDIFX,M) +C OUTPUT ARGUMENTS: + DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) + double precision ymod(NQ),dydxp(NQ,(M+NP)) + integer k,idowhat +!----------------------------------------------------- + if(idobounded.eq.1)then + if(betamin(1).lt.betamax(1))then + do I=1,NP + if(BETA(I).lt.betamin(I).or.BETA(I).gt.betamax(I))then + ISTOP = 1 + RETURN + endif + enddo + endif + endif + ISTOP=0 + IF (MOD(IDEVAL,10).GE.1) THEN + idowhat=0 + DO 100 I = 1,N + call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M), + & NP,BETA,dydxp(1:NQ,1:(M+NP)),idowhat) + DO 110 L = 1,NQ + F(I,L)=ymod(L) +110 CONTINUE +100 CONTINUE + END IF + +C COMPUTE DERIVATIVES WITH RESPECT TO BETA + IF (MOD(IDEVAL/10,10).GE.1) THEN + idowhat=2 + DO 200 I = 1,N + call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M), + & NP,BETA,dydxp(1:NQ,1:(M+NP)),idowhat) + DO 210 L = 1,NQ + do k=1,NP + FJACB(I,k,L)=dydxp(L,k) + enddo + 210 CONTINUE + 200 CONTINUE + ENDIF + +c compute derivatives with respect to delta + IF (MOD(IDEVAL/100,10).GE.1) THEN + idowhat=1 + DO 300 I = 1,N + call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M), + & NP,BETA,dydxp(1:NQ,1:(M+NP)),idowhat) + DO 310 L = 1,NQ + do k=1,M + FJACD(I,k,L)=dydxp(L,k) + enddo + 310 CONTINUE + 300 CONTINUE + ENDIF + RETURN + END +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function generic_pikaia(ndim,beta01) + implicit none + include 'forgenericregres.h' + integer ndim,i + double precision beta01(ndim),beta(ndim),fvalue + do i=1,ndim +! beta01(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + beta(i)=betamin(i)+beta01(i)*(betamax(i)-betamin(i)) + enddo + call funkmin_generic(ndim,beta,fvalue) + generic_pikaia=1.0d0/(fvalue+0.00001d0) + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine distcenter(nx,x,fequ,fvalue,idowhat) + implicit none + include 'leastdistance.h' +!idowhat=1, evaluating the system of equations and calculating the sum of squares. +!idowhat=2, calculating the distance. + integer nx,idowhat + double precision x(nx),fequ(nx),fvalue +!---------------------------------------------------------- + integer i,j,ider + double precision y(my),dydxp(my,(nx+nparams)), + & xcopy(nx),sum,yplush(my),yminush(my),h + parameter(h=1.0d-7) +!==============End of Variable Declaration================== + j=0 + call surffunc(my,y,nx,x,nparams,params, + & dydxp(1:my,1:(nx+nparams)),j) + if(idowhat.eq.1)then + if(iknowder.eq.1)then + call surffunc(my,y,nx,x,nparams,params, + & dydxp(1:my,1:(nx+nparams)),iknowder) + endif + if(iknowder.eq.0)then + do i=1,nx + xcopy(i)=x(i) + enddo + do i=1,nx + xcopy(i)=x(i)+h + call surffunc(my,yplush,nx,xcopy,nparams,params, + & dydxp(1:my,1:(nx+nparams)),iknowder) + xcopy(i)=x(i)-h + call surffunc(my,yminush,nx,xcopy,nparams,params, + & dydxp(1:my,1:(nx+nparams)),iknowder) + do j=1,my + dydxp(j,i)=(yplush(j)-yminush(j))/(2.0d0*h) + enddo + xcopy(i)=x(i) + enddo + endif + do i=1,nx + sum=0.0d0 + do j=1,my + sum=sum+(y(j)-targety(j))*dydxp(j,i) + enddo + fequ(i)=x(i)-(targetx(i)-sum) + enddo + fvalue=0.0d0 + do i=1,nx + fvalue=fvalue+fequ(i)*fequ(i) + enddo + endif + if(idowhat.eq.2)then + fvalue=0.0d0 + do i=1,my + fvalue=fvalue+(y(i)-targety(i))**2 + enddo + do i=1,nx + fvalue=fvalue+(x(i)-targetx(i))**2 + enddo + endif + return + end subroutine distcenter +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine distcentersys(nunknowns,x,fequ,fsqsum) + implicit none + integer nunknowns,idowhat + double precision x(nunknowns), + & fequ(nunknowns),fsqsum + parameter(idowhat=1) + call distcenter(nunknowns,x,fequ,fsqsum,idowhat) + return + end subroutine distcentersys +!----------------------------------------------------------- + subroutine fsqsum_distcenter(nunknowns,x,fsqsum) + implicit none + integer nunknowns,idowhat + double precision x(nunknowns),fsqsum, + & fequ(nunknowns) + parameter(idowhat=1) + call distcenter(nunknowns,x,fequ,fsqsum,idowhat) + return + end +!----------------------------------------------------------- + double precision function f1dimsqsum_distcenter(x) + implicit none + double precision x + INTEGER j,idowhat +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /cpf1com/ pcom,xicom,ncom + save /cpf1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + double precision xt(NMAX),fequ(NMAX) + parameter(idowhat=1) + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call distcenter(ncom,xt,fequ, + & f1dimsqsum_distcenter,idowhat) + return + END +!------------------------------------------------------------ + subroutine s2_distcenter(nunknowns,x,s2) + implicit none + integer nunknowns,idowhat + double precision x(nunknowns),s2,fequ(nunknowns) + parameter(idowhat=2) + call distcenter(nunknowns,x,fequ,s2,idowhat) + return + end +!----------------------------------------------------------- + double precision function f1dims2_distcenter(x) + implicit none + double precision x + INTEGER j,idowhat +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /cpf1com/ pcom,xicom,ncom + save /cpf1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + double precision xt(NMAX),fequ(NMAX) + parameter(idowhat=2) + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call distcenter(ncom,xt,fequ, + & f1dims2_distcenter,idowhat) + return + END +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/optimization/FCN_neural.f b/dataassim/math/optimization/FCN_neural.f new file mode 100644 index 0000000..2c8ee7b --- /dev/null +++ b/dataassim/math/optimization/FCN_neural.f @@ -0,0 +1,146 @@ + subroutine funkmin_neural(ndim,beta,fvalue) + implicit none + include 'NeuralNetRegres.h' + integer ndim + double precision beta(ndim),fvalue +!(in) ndim: the dimension of the parameter vector +!(in) beta: the parameters +!(out) fvalue: the value of the cost function at beta +!----------------------------------------------------- + integer i,j,k,idowhat + double precision w(maxnx,maxnh),bph(maxnh),q(maxnh), + &bend,annfunc,ypred +! +! check to see if parameters are out of bounds + if(betamin(1).lt.betamax(1))then + do i=1,ndim + if(beta(i).lt.betamin(i).or. + & beta(i).gt.betamax(i))then +! parameter out of bound + fvalue=1.0d+100 + return + endif + enddo + endif + idowhat=1 + call coeff_beta(idowhat,nx,nh,beta,w(1:nx,1:nh),bph,q,bend) + fvalue=0.0d0 + do i=1,nobs + ypred=annfunc(nx,xsamp(i:i,1:nx),nh,q,w(1:nx,1:nh),bph,bend) + fvalue=fvalue+(ysamp(i)-ypred)*(ysamp(i)-ypred) + enddo + return + end subroutine funkmin_neural +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function f1dim_neural(x) + implicit none + double precision x +CU USES funkmin_neural + INTEGER j +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /f1com/ pcom,xicom,ncom + save /f1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + double precision xt(NMAX) +!----------------------------------------------------- + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call funkmin_neural(ncom,xt,f1dim_neural) + return + END +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + SUBROUTINE FCN_neural(N,M,NP,NQ, + + LDN,LDM,LDNP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,F,FJACB,FJACD, + + ISTOP) + implicit none +C SUBROUTINE ARGUMENTS +C ==> N NUMBER OF OBSERVATIONS +C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N +C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M +C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP +C ==> BETA CURRENT VALUES OF PARAMETERS +C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED +C <== F PREDICTED FUNCTION VALUES +C <== FJACB JACOBIAN WITH RESPECT TO BETA +C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA +C <== ISTOP STOPPING CONDITION, WHERE +C 0 MEANS CURRENT BETA AND X+DELTA WERE +C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY +C 1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES +C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE +C -1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD STOP + +C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE: + INTEGER II,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ + DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M) + INTEGER IFIXB(NP),IFIXX(LDIFX,M) +C OUTPUT ARGUMENTS: + DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) +! + integer k,i,j,s,t,ierr,idowhat + include 'NeuralNetRegres.h' + double precision w(maxnx,maxnh),bph(maxnh), + & q(maxnh),bend,xnew(maxnx),annfunc, + & derBETA(NP),derw(maxnx,maxnh),derbph(maxnh), + & derq(maxnh),derbend +C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM +c + do I=1,NP + if(BETA(I).lt.betamin(I).or.BETA(I).gt.betamax(I))then + ISTOP = 1 + RETURN + endif + enddo + idowhat=1 + call coeff_beta(idowhat,nx,nh,BETA, + & w(1:nx,1:nh),bph,q,bend) +!---------------- find the ann function values-------------------------- + IF (MOD(IDEVAL,10).GE.1) THEN + DO 110 L = 1,NQ + DO 100 I = 1,N + do k=1,M + xnew(k)=XPLUSD(I,k) + enddo + F(I,L)=annfunc(nx,xnew,nh,q,w(1:nx,1:nh),bph,bend) + 100 CONTINUE + 110 CONTINUE + END IF +!---------------------------------------------------------------------- +C COMPUTE DERIVATIVES WITH RESPECT TO BETA + IF (MOD(IDEVAL/10,10).GE.1) THEN + idowhat=2 + DO 200 I = 1,N + do k=1,M + xnew(k)=XPLUSD(I,k) + enddo + call derannfunc(nx,xnew,nh,q,w(1:nx,1:nh), + & bph,bend,derq,derw(1:nx,1:nh),derbph,derbend) + call coeff_beta(idowhat,nx,nh,derBETA, + & derw(1:nx,1:nh),derbph,derq,derbend) + DO 210 L = 1,NQ + do k=1,NP + FJACB(I,k,L)=derBETA(k) + enddo + 210 CONTINUE + 200 CONTINUE + END IF + RETURN + END +! +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/optimization/FilterNeuralNetRegres.f b/dataassim/math/optimization/FilterNeuralNetRegres.f new file mode 100644 index 0000000..3463bc7 --- /dev/null +++ b/dataassim/math/optimization/FilterNeuralNetRegres.f @@ -0,0 +1,72 @@ + subroutine FilterNeuralNetRegres(idowhat,nx0,nobs0,nh0, + &xsamp0,ysamp0,yatxsamp0,rsq,w,bph,q,bend,xnew,ypred) + implicit none +! +!=============Inputs regardless of idowhat========================= +!idowhat: =1, fit the data and estimate the coefficients. Provide the +! initial guess for the coefficients or set bend to -9999 +! =2, coefficients are already available, calculate y at xnew +!nx0: the number of independent (x) variables +!nobs0: the total number of samples +!nh0: the total number of hidden nodes to use. One hidden layer is +! assumed. +!============When idowhat=1======================================== +! --------Inputs-------- +!xsamp0: the values of the independent (x) variables +!ysamp0: the values of the dependent (y) variable. y is one dimension. +! --------Outputs------- +!w: the slope coefficient to time the normalized x in the activation function +!bph: the intercept coefficient in the activation function +!q: the coefficient to time the value of the activation function +!bend: the residual constant in the neural network regression +!yatxsamp0: the predicted y value at xsamp0 +!rsq: R squared +!============When idowhat=2========================================= +! --------Inputs-------- +!w: the slope coefficient to time the normalized x in the activation function +!bph: the intercept coefficient in the activation function +!q: the coefficient to time the value of the activation function +!bend: the residual constant in the neural network regression +!xnew: the new x point who y value is to be estimated (when idowhat=2) +! --------Outputs------- +!ypred: the predicted y value at xnew +! + integer idowhat,nx0,nobs0,nh0 + double precision xsamp0(nobs0,nx0),ysamp0(nobs0), + & yatxsamp0(nobs0),rsq,w(nx0,nh0),bph(nh0),q(nh0), + & bend,xnew(nx0),ypred,fn9999,dif_y(nobs0) + parameter(fn9999=-9999.0d0) +!============Locals========================================= + integer i,j,m,n,nobs,isoutlier_2sides +! + if(idowhat.eq.1)then + nobs=nobs0 +10 n=0 + do i=1,nobs + if(dabs(ysamp0(i)-fn9999).gt.1.0d-6)then + n=n+1 + ysamp0(n)=ysamp0(i) + do j=1,nx0 + xsamp0(n,j)=xsamp0(i,j) + enddo + endif + enddo + nobs=n + call NeuralNetRegres(idowhat,nx0,nobs,nh0,xsamp0(1:nobs,1:nx0), + &ysamp0,yatxsamp0,rsq,w(1:nx0,1:nh0),bph,q,bend,xnew,ypred) + do i=1,nobs + dif_y(i)=ysamp0(i)-yatxsamp0(i) + enddo + m=isoutlier_2sides(nobs,dif_y) + if(m.gt.0)then + ysamp0(m)=fn9999 + goto 10 + endif + return + endif + if(idowhat.eq.2)call NeuralNetRegres(idowhat,nx0,nobs0,nh0, + &xsamp0(1:nobs0,1:nx0),ysamp0,yatxsamp0,rsq,w(1:nx0,1:nh0),bph, + &q,bend,xnew,ypred) + return + end +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& diff --git a/dataassim/math/optimization/FilterRegres.f b/dataassim/math/optimization/FilterRegres.f new file mode 100644 index 0000000..021821a --- /dev/null +++ b/dataassim/math/optimization/FilterRegres.f @@ -0,0 +1,54 @@ + Subroutine FilterRegres(nobs,ny,yobs,nx,xobs,weity0, + &weitx,ndim,beta,betamin,betamax,xmin,xmax, + &iderivative,iregrestype,shorty,shortx,fatbeta) + implicit none +!Generic Regression with outlier filtering. Use the subroutine GenericRegres. +!iregrestype=0, ordinary distance regression +!iregrestype=1, orthogonal distance regression. Direct search methods +! determine the shortest distance within the iteration +!iregrestype=2, orthogonal distance regression. Direct search methods +! expand the parameter vector to include x positions. +!iregrestype=-1, implicit regression +!iderivative=0, no derivatives provided, using central finite difference +!iderivative=1, derivatives provided. +!If the weity0(i,j) is modified on exit, the corresponding point is detected +!as an outlier + integer nobs,ny,nx,iderivative,ndim,iregrestype + double precision yobs(nobs,ny),xobs(nobs,nx),weity0(nobs,ny), + &weity(nobs,ny),weitx(nobs,nx),xmin(nobs,nx),xmax(nobs,nx), + &beta(ndim),betamin(ndim),betamax(ndim),shorty(nobs,ny), + &shortx(nobs,nx),fatbeta,dif_y(nobs),tiny + parameter(tiny=1.0d-9) +! + integer i,j,k,m,isoutlier_2sides,iok,ivector(nobs) +!----------------------------------------------------- + do i=1,nobs + do j=1,ny + weity(i,j)=weity0(i,j) + enddo + enddo +10 call GenericRegres(nobs,ny,yobs(1:nobs,1:ny),nx,xobs(1:nobs,1:nx), + &weity(1:nobs,1:ny),weitx(1:nobs,1:nx),ndim,beta,betamin,betamax, + &xmin(1:nobs,1:nx),xmax(1:nobs,1:nx),iderivative,iregrestype, + &shorty(1:nobs,1:ny),shortx(1:nobs,1:nx),fatbeta) + k=0 + do j=1,ny + iok=0 + do i=1,nobs + if(dabs(weity(i,j)).gt.tiny)then +!do not consider points with weit = 0 for the purpose of identifying outliers + iok=iok+1 + ivector(iok)=i + dif_y(iok)=weity(i,j)*(yobs(i,j)-shorty(i,j)) + endif + enddo + m=isoutlier_2sides(iok,dif_y) + if(m.gt.0)then + k=k+1 + weity(ivector(m),j)=0.0d0 + endif + enddo + if(k.gt.0)goto 10 + return + end subroutine FilterRegres +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/optimization/GSA.f b/dataassim/math/optimization/GSA.f new file mode 100644 index 0000000..41cc26d --- /dev/null +++ b/dataassim/math/optimization/GSA.f @@ -0,0 +1,334 @@ + program test + implicit none + integer ndim + double precision x0(10),xt(10),fvalue + + ndim=2 + x0(1)=-90.0d0 + x0(2)=1000.0d0 + call GSA(ndim,x0,xt,fvalue) + write(*,*)fvalue,xt(1),xt(2) + end + +* Generalized Simulated Annealing - Code +* Program developed by Members of Lab. of Molecular Modeling +* Kleber C. Mundim (1995) +* ------------------------------------------------------ +* Global optimization method using Generalized Simulated Annealing +* as for example; +* GSA Procedure + Your objective/coust function +* ______________ __________________ +* | | Set of Parameters | | +* | | =================> | Routine with | +* | GSA-routine | | your objective | +* | | <================= | function | +* |______________| Objective function |__________________| +* +* ------------------------------------------------------ +* First Version Jan./1994 (Kleber Mundim and Constantino Tsallis) +* Second Version Jun./1995 (Marcelo Moret) +* Third Version Sep./1995 (Thierry Lemaire and Amin Bassrei) +* +* Some Basic References and literature citation: +* +*1- Title : Geometry Optimization and Conformational Analysis Through +* Generalized Simulated Annealing +* Authors : Kleber C. Mundim and Constantino Tsallis +* Journal : Int.Journal of Quantum Chemistry, 58 (1996),373-381 +* +*2- Title : Stochastic Molecular Optimization using Generalized +* Simulated Annealing +* Authors : Marcelo Moret, Pedro G. Pascutti, Paulo M. Bish +* and Kleber C. Mundim +* Journal : Journal of Computational Chemistry, 19 (1998) 647-657 +* +*3- Title : Modeling Gravity Anomalies Through Generalized +* Simulated Annealing +* Authors : Kleber C. Mundim, Thierry Lemaire and Amin Bassrei +* Journal : Physica A, 252 (1998) 405-416 +* ------------------------------------------------------ +* Most important vectors and parameters used in the GSA routines. +* NDimension --> Number of parameters to be optimized (problem dependent). +* X_t(i) --> This vector contains the parameters. +* X_0(i) --> X_0(i) contains X_t at the time t-1. +* X_Min --> Minimal parameters obtained. +* To --> Initial Temperature. +* qV --> qV caracterize the Visiting Probability Function. +* qA --> qA Acceptance Parameter. +* qT --> qT Temperature parameter +* NStopMax --> Maximum number of GSA loops (problem dependent). + +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | + subroutine GSA(ndim,X0,Xt,fvalue) +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | +* This routine start the GSA-loop + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER (MaxDim=500) + dimension X0(ndim),Xt(ndim) + + COMMON /Par1/ qV1,qV2,qA1,qT1,D,exp1,exp2,Coef,Tqt,To,ToScale + COMMON /Par2/ qA,qV,qT + COMMON /Par3/ NDimension,NStopMax,NRAN + + COMMON /Xvector/ X_t(Maxdim), X_0(Maxdim), X_Min(Maxdim) + + DATA One /1.0D+00/ + NDimension=ndim + CALL GSAini() + DO i=1,NDimension + X_0(i)=X0(i) + X_Min(i) = X_0(i) + X_t(i) = X_0(i) + ENDDO + func_0 = func(X_0) + func_Min = func_0 + func_t = func_0 + OneqA1 = One/qA1 + Time = 0.0D0 + NCycle = 0 + DO WHILE (NCycle.LE.NStopMax) + Time = Time + One + NCycle = NCycle + 1 + T = Tqt/((One+Time)**qT1 - One) + IF(D.EQ.0.0D0) THEN + Tup = One + ELSE + Tup = T**(D/(qT-3.0D0)) + ENDIF + CALL Gfunc(T,Tup) + func_t = func(X_t) + IF(func_t .LE. func_0) THEN + DO I=1, NDimension + X_0(I) = X_t(I) + ENDDO + func_0 = func_t + IF(func_t .LE. func_Min) THEN + func_Min = func_t + DO I=1,NDimension + X_Min(I) = X_t(I) + ENDDO + ENDIF + ELSE + DeltaE = func_t - func_0 + qA1= qA - One + PqA = One/((One+qA1*DeltaE/T)**OneqA1) + Rand = RAN3(NRAN) + IF(Rand .LT. PqA) THEN + DO I=1,NDimension + X_0(I) = X_t(I) + ENDDO + func_0 = func_t + ENDIF + ENDIF + ENDDO + fvalue=func_t + do I=1,ndim + Xt(I)=X_t(I) + enddo + return + END + +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | + SUBROUTINE Gfunc(T,Tup) +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | +* This routine evaluate the new set o parameters using the +* visiting probability function g(q,T). + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER (MaxDim=500) + COMMON /Par1/ qV1,qV2,qA1,qT1,D,exp1,exp2,Coef,Tqt,To,ToScale + COMMON /Par3/ NDimension,NStopMax,NRAN + COMMON /Xvector/ X_t(Maxdim), X_0(Maxdim), X_Min(Maxdim) + + DATA One /1.00000D+00/ + + DO I = 1,NDimension + R = RAN3(NRAN) + S = RAN3(NRAN) + DeltaX = Coef*Tup/(One+qV1*R*R/T**exp1)**exp2 + IF(S.LE.0.5) DeltaX = -DeltaX + X_t(I) = X_0(I) + DeltaX + ENDDO + + + RETURN + END + +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | + FUNCTION dgamma(r) +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | +* This routine evaluate usual Gamma function. + + IMPLICIT REAL*8 (a - h, o - z) + + PARAMETER ( + 1 p0 = 0.999999999999999990d+00, p1 = -0.422784335098466784d+00, + 2 p2 = -0.233093736421782878d+00, p3 = 0.191091101387638410d+00, + 3 p4 = -0.024552490005641278d+00, p5 = -0.017645244547851414d+00, + 4 p6 = 0.008023273027855346d+00) + PARAMETER ( + 1 p7 = -0.000804329819255744d+00,p8 = -0.000360837876648255d+00, + 2 p9 = 0.000145596568617526d+00,p10 = -0.000017545539395205d+00, + 3 p11 = -0.000002591225267689d+00,p12 = 0.000001337767384067d+00, + 4 p13 = -0.000000199542863674d+00) + + n = NINT(r - 2) + w = r - (n + 2) + y = ((((((((((((p13 * w + p12)* w + p11)* w + p10)* + 1 w + p9) * w + p8) * w + p7) * w + p6) * w + p5) * + 2 w + p4) * w + p3) * w + p2) * w + p1) * w + p0 + IF (n .gt. 0) THEN + w = r - 1 + DO k = 2, n + w = w * (r - k) + END DO + ELSE + w = 1 + DO k = 0, -n - 1 + y = y * (r + k) + END DO + END IF + dgamma = w / y + + RETURN + END + +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | + DOUBLE PRECISION FUNCTION RAN3(IDUM) +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +* This routine return an randomic number 0<= r <= 1 + +C IMPLICIT REAL*4(M) +C PARAMETER (MBIG=4000000.,MSEED=1618033.,MZ=0.,FAC=2.5D-7) + PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1.D-9) + COMMON /RAN1A/ IFF,MJ,MK,INEXT,INEXTP,MA(55) +* DATA IFF /0/ +* INEXT=0 +* INEXTP=31 + + IF(IDUM.LT.0.OR.IFF.EQ.0)THEN + IFF=1 + MJ=MSEED-IABS(IDUM) + MJ=MOD(MJ,MBIG) + MA(55)=MJ + MK=1 + DO 11 I=1,54 + II=MOD(21*I,55) + MA(II)=MK + MK=MJ-MK + IF(MK.LT.MZ)MK=MK+MBIG + MJ=MA(II) +11 CONTINUE + DO 13 K=1,4 + DO 12 I=1,55 + MA(I)=MA(I)-MA(1+MOD(I+30,55)) + IF(MA(I).LT.MZ)MA(I)=MA(I)+MBIG +12 CONTINUE +13 CONTINUE + INEXT=0 + INEXTP=31 + IDUM=1 + ENDIF + + INEXT=INEXT+1 + IF(INEXT.EQ.56)INEXT=1 + INEXTP=INEXTP+1 + IF(INEXTP.EQ.56)INEXTP=1 + MJ=MA(INEXT)-MA(INEXTP) + IF(MJ.LT.MZ)MJ=MJ+MBIG + MA(INEXT)=MJ + RAN3=MJ*FAC + + RETURN + END + +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | + SUBROUTINE GSAini() +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | +* This routine read and initialize the GSA parameters +* The number of parameters to be optimized (NDIMENSION) is problem +* dependent. + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER (MaxDim=500) + COMMON /Par1/ qV1,qV2,qA1,qT1,D,exp1,exp2,Coef,Tqt,To,ToScale + COMMON /Par2/ qA,qV,qT + COMMON /Par3/ NDimension,NStopMax,NRAN + + DATA One /1.00000D+00/ + CHARACTER tempo*8 + + qA=1.5d0 + qT=1.5d0 + qV=1.5d0 + NStopMax=1000 + To=1.0E-00 + CALL TIME(tempo) + READ(tempo(7:8),"(I2)")NRAN + NRAN = -NRAN + + D = 10.5d0 + + Pi = 3.14159265359D0 + +* Acceptance probability + qA1= qA - One + +* Temperature + qT1 = qT - One + Tqt = To*(2.0D0**qT1-One) + +* Visiting probability + qV1= qV - One + qV2= 2.0D0**qV1 - One + tmp= One/qV1 - 0.5D0 + GamaDown = dgamma(tmp) + exp1 = 2.0D0/(3.0D0 - qV) + + IF(D.EQ.0.0D0) THEN + Coef1 = One + exp2 = One/qv1 - 0.5D0 + GamaUp = GamaDown + ELSE + Coef1 = (qV1/Pi)**(D*0.5D0) + exp2 = One/qV1 + 0.5D0*D - 0.5D0 + GamaUp = dgamma(exp2) + ENDIF + + Coef = Coef1*GamaUp/GamaDown + + + RETURN + END + + +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | + FUNCTION func(X) +* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * | + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER (MaxDim=500) +* This subrotuine make link between GSA and your Objective function +* X(nDimension) is a vector that contains the parameters set. +* GSA Procedure + Your objective/coust function +* ______________ __________________ +* | | Set of Parameters X(i) | | +* | | =================> | Routine with | +* | GSA-routine | | your objective | +* | | <================= | function | +* |______________| Value of the function (f) |__________________| + + COMMON /Par3/ NDimension,NStopMax,NRAN + + DIMENSION X(MaxDim) + +* CALL here your routine with the objective function +* X(i) is parameters set and f is the value of the objective function +! CALL funct(X,f) +! func = f + + func=(X(1)-2.0d0)*(X(1)-2.0d0)+(X(2)-13.8d0)*(X(2)-13.8d0) + RETURN + END + diff --git a/dataassim/math/optimization/GSA.in b/dataassim/math/optimization/GSA.in new file mode 100644 index 0000000..b6cdbeb --- /dev/null +++ b/dataassim/math/optimization/GSA.in @@ -0,0 +1,6 @@ +Initial GSA parameters + 1.5 qA Acceptance index + 1.5 qT Temperature index + 1.5 qV Visiting index + 1000 NStopMax Max number of GSA-loops + 1.0E-00 To Initial Temperature diff --git a/dataassim/math/optimization/GenericRegres.f b/dataassim/math/optimization/GenericRegres.f new file mode 100644 index 0000000..bd9c715 --- /dev/null +++ b/dataassim/math/optimization/GenericRegres.f @@ -0,0 +1,333 @@ + Subroutine GenericRegres(npoints,ny,y,nx,x,weity0, + &weitx0,ndim0,beta_in_out,betamin0,betamax0,xmin0,xmax0, + &iderivative,iregrestype0,shorty0,shortx0,fatbeta) + implicit none +!iregrestype0=0, ordinary regression +!iregrestype0=1, orthogonal distance regression. Direct search methods +! determine the shortest distance within the iteration +!iregrestype0=2, orthogonal distance regression. Direct search methods +! expand the parameter vector to include x positions. +!iregrestype0=-1, implicit regression +!iderivative=0, no derivative provided +!iderivative=1, derivative provided + include 'forgenericregres.h' + integer npoints,ny,nx,iderivative,ndim0,iregrestype0 + double precision y(npoints,ny),x(npoints,nx),weity0(npoints,ny), + &weitx0(npoints,nx),xmin0(npoints,nx),xmax0(npoints,nx), + &beta_in_out(ndim0),betamin0(ndim0),betamax0(ndim0), + &shorty0(npoints,ny),shortx0(npoints,nx),fatbeta +! + integer i,j,INFO,ndim,k + double precision xtol,beta(ndim0+nx*npoints), + &betacp(ndim0+nx*npoints),fatbetacp,beta0(ndim0+nx*npoints), + &fatbeta0,ftol,gacontrol(12),ran2,ftol_relax + parameter(xtol=1.0d-7,ftol=1.0d-7) + external funkmin_generic,FCN_generic,f1dim_generic,generic_pikaia +!----------------------------------------------------- + ndim=ndim0 + nxvars=nx + nyvars=ny + if((nx*npoints+ndim0).gt.1000)iregrestype0=0 + iregrestype=iregrestype0 + iknowder=iderivative + nobs=npoints + do i=1,npoints + do j=1,nxvars + xvars(i,j)=x(i,j) + xmin(i,j)=xmin0(i,j) + xmax(i,j)=xmax0(i,j) + weitx0(i,j)=1.0d0 + weitx(i,j)=weitx0(i,j) + enddo + do j=1,nyvars + yobs(i,j)=y(i,j) + weity(i,j)=weity0(i,j) + enddo + enddo + do i=1,ndim + betamin(i)=betamin0(i) + betamax(i)=betamax0(i) + beta(i)=beta_in_out(i) + enddo + if(iregrestype.eq.2)iregrestype=1 +c gacontrol( 1) - number of individuals in a population (default +c is 100) +c gacontrol( 2) - number of generations over which solution is +c to evolve (default is 500) +c gacontrol( 3) - number of significant digits (i.e., number of +c genes) retained in chromosomal encoding (default +c is 6) (Note: This number is limited by the +c machine floating point precision. Most 32-bit +c floating point representations have only 6 full +c digits of precision. To achieve greater preci- +c sion this routine could be converted to double +c precision, but note that this would also require +c a double precision random number generator, which +c likely would not have more than 9 digits of +c precision if it used 4-byte integers internally.) +c gacontrol( 4) - crossover probability; must be <= 1.0 (default +c is 0.85). If crossover takes place, either one +c or two splicing points are used, with equal +c probabilities +c gacontrol( 5) - mutation mode; 1/2/3/4/5 (default is 2) +c 1=one-point mutation, fixed rate +c 2=one-point, adjustable rate based on fitness +c 3=one-point, adjustable rate based on distance +c 4=one-point+creep, fixed rate +c 5=one-point+creep, adjustable rate based on fitness +c 6=one-point+creep, adjustable rate based on distance +c gacontrol( 6) - initial mutation rate; should be small (default +c is 0.005) (Note: the mutation rate is the proba- +c bility that any one gene locus will mutate in +c any one generation.) +c gacontrol( 7) - minimum mutation rate; must be >= 0.0 (default +c is 0.0005) +c gacontrol( 8) - maximum mutation rate; must be <= 1.0 (default +c is 0.25) +c gacontrol( 9) - relative fitness differential; range from 0 +c (none) to 1 (maximum). (default is 1.) +c gacontrol(10) - reproduction plan; 1/2/3=Full generational +c replacement/Steady-state-replace-random/Steady- +c state-replace-worst (default is 3) +c gacontrol(11) - elitism flag; 0/1=off/on (default is 0) +c (Applies only to reproduction plans 1 and 2) +c gacontrol(12) - printed output 0/1/2=None/Minimal/Verbose +c (default is 0) + idobounded=1 +10 call funkmin_generic(ndim,beta,fatbeta) + do i=1,ndim + beta0(i)=beta(i) + enddo + fatbeta0=fatbeta + j=0 + k=0 + ftol_relax=ftol*100.0d0 +30 call nongradopt(ndim,funkmin_generic, + &f1dim_generic,beta,betamin,betamax,ftol_relax,fatbeta) + call funkmin_generic(ndim,beta,fatbeta) + if((fatbeta+1.0d0).eq.fatbeta.or.fatbeta.gt.fatbeta0)then + do i=1,ndim + beta(i)=beta0(i) + enddo + fatbeta=fatbeta0 + else + if((fatbeta0-fatbeta).lt.ftol_relax)then +!increment the counter for arriving at the same minimum + k=k+1 + else +!reset the counter for arriving at a better minimum + k=0 + endif + do i=1,ndim + beta0(i)=beta(i) + enddo + fatbeta0=fatbeta + endif + j=j+1 +!try different initial guesses + if(j.lt.100.and.k.lt.5)then + if(ran2().gt.0.3d0)then + do i=1,ndim + if(ran2().gt.0.5d0)then + beta(i)=beta(i)+(ran2()**(3.0d0/dble(k+1)))* + &(betamax(i)-beta(i)) + else + beta(i)=beta(i)-(ran2()**(3.0d0/dble(k+1)))* + &(beta(i)-betamin(i)) + endif + enddo + else + do i=1,ndim + beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i)) + enddo + endif + call funkmin_generic(ndim,beta,fatbeta) + goto 30 + else + if((ftol_relax-ftol).gt.ftol)then + ftol_relax=ftol + goto 30 + endif + endif + call RepeatCompassSearch(ndim,beta,fatbeta, + &betamin,betamax,funkmin_generic,f1dim_generic,xtol) + call funkmin_generic(ndim,beta,fatbeta) + k=0 + if((fatbeta+1.0d0).eq.fatbeta)k=1 + do i=1,ndim + if((beta(i)+1.0d0).eq.beta(i))k=1 + enddo + if(k.eq.1)then + do i=1,ndim + beta(i)=betamin(i)+(betamax(i)-betamin(i))*ran2() + enddo + goto 10 + endif + if(fatbeta.ge.fatbeta0)then +!if RepeatCompassSearch cannot improve, we end the search + do i=1,ndim + beta(i)=beta0(i) + enddo + fatbeta=fatbeta0 + goto 110 + else + if((fatbeta0-fatbeta).lt.ftol)goto 40 + endif + do i=1,12 + gacontrol(i)=-1.0d0 + enddo + gacontrol(1)=250.0d0 + gacontrol(2)=5000.0d0 + gacontrol(3)=8.0d0 + do i=1,ndim + beta0(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + enddo + idobounded=0 + call pikaia(generic_pikaia,ndim,gacontrol,beta0,fatbeta0,j) + fatbeta0=1.0d+100 + if(j.eq.0)then + do i=1,ndim + beta0(i)=betamin(i)+beta0(i)*(betamax(i)-betamin(i)) + enddo + idobounded=1 + call funkmin_generic(ndim,beta0,fatbeta0) + k=0 + if((fatbeta0+1.0d0).eq.fatbeta0)k=1 + do i=1,ndim + if((beta0(i)+1.0d0).eq.beta0(i))k=1 + enddo + if(k.eq.1)fatbeta0=1.0d+100 + endif + +40 if(fatbeta0.gt.fatbeta)then + fatbeta0=fatbeta + do i=1,ndim + beta0(i)=beta(i) + enddo + endif + do i=1,ndim + beta(i)=beta0(i) + enddo + fatbeta=fatbeta0 +! + INFO=iregrestype + idobounded=0 + call odr_leastsquare(ndim,FCN_generic,beta,nobs, + &xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars), + &nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars), + &iderivative,shortx(1:nobs,1:nxvars), + &shorty(1:nobs,1:nyvars),fatbeta,INFO) + idobounded=1 + call funkmin_generic(ndim,beta,fatbeta) + k=0 + if((fatbeta+1.0d0).eq.fatbeta)k=1 + do i=1,ndim + if((beta(i)+1.0d0).eq.beta(i))k=1 + enddo + if(k.eq.1)fatbeta=1.0d+100 + if(dabs(fatbeta).le.dabs(fatbeta0))then + else + do i=1,ndim + beta(i)=beta0(i) + enddo + fatbeta=fatbeta0 + endif + do i=1,ndim + if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then + do j=1,ndim + beta(j)=beta0(j) + enddo + fatbeta=fatbeta0 + endif + enddo + fatbeta0=fatbeta + iregrestype=iregrestype0 + if(iregrestype.eq.2)then + do i=1,npoints + do j=1,nx + ndim=ndim+1 + beta(ndim)=shortx(i,j) + betamin(ndim)=xmin0(i,j) + betamax(ndim)=xmax0(i,j) + if(beta(ndim).lt.betamin(ndim).or. + &beta(ndim).gt.betamax(ndim))then + beta(ndim)=x(i,j) + endif + enddo + enddo + call funkmin_generic(ndim,beta,fatbeta) + endif + j=0 +100 j=j+1 + fatbeta0=fatbeta + do i=1,ndim + beta0(i)=beta(i) + enddo + call nongradopt(ndim,funkmin_generic, + &f1dim_generic,beta,betamin,betamax,ftol,fatbeta) + call funkmin_generic(ndim,beta,fatbeta) + k=0 + if((fatbeta+1.0d0).eq.fatbeta)k=1 + do i=1,ndim + if((beta(i)+1.0d0).eq.beta(i))k=1 + enddo + if(k.eq.1)fatbeta=1.0d+100 + if(dabs(fatbeta).ge.dabs(fatbeta0))then + fatbeta=fatbeta0 + do i=1,ndim + beta(i)=beta0(i) + enddo + goto 110 + endif + fatbetacp=fatbeta + do i=1,ndim + betacp(i)=beta(i) + enddo + call RepeatCompassSearch(ndim,betacp,fatbetacp, + &betamin,betamax,funkmin_generic,f1dim_generic,xtol) + call funkmin_generic(ndim,betacp,fatbetacp) + k=0 + if((fatbetacp+1.0d0).eq.fatbetacp)k=1 + do i=1,ndim + if((betacp(i)+1.0d0).eq.betacp(i))k=1 + enddo + if(k.eq.1)fatbetacp=1.0d+100 + if(dabs(fatbetacp).lt.dabs(fatbeta))then + fatbeta=fatbetacp + do i=1,ndim + beta(i)=betacp(i) + enddo + else + goto 110 + endif + if(j.ge.2.or.fatbeta.eq.fatbeta0)goto 110 + if(dabs(fatbeta0-fatbeta).gt.ftol)then + do i=1,ndim + betacp(i)=beta(i)-beta0(i) + beta0(i)=beta(i) + enddo + fatbeta0=fatbeta + call linmin(beta,betamin,betamax,betacp,ndim, + &f1dim_generic,fatbeta) + call funkmin_generic(ndim,beta,fatbeta) + if(dabs(fatbeta).lt.dabs(fatbeta0))goto 100 + fatbeta=fatbeta0 + do i=1,ndim + beta(i)=beta0(i) + enddo + endif +110 call funkmin_generic(ndim,beta,fatbeta) + do i=1,ndim0 + beta_in_out(i)=beta(i) + enddo + do i=1,npoints + do j=1,nyvars + shorty0(i,j)=shorty(i,j) + enddo + do j=1,nxvars + shortx0(i,j)=shortx(i,j) + enddo + enddo + return + end subroutine GenericRegres +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/optimization/Lbfgsb_2_4.f b/dataassim/math/optimization/Lbfgsb_2_4.f new file mode 100644 index 0000000..640e36b --- /dev/null +++ b/dataassim/math/optimization/Lbfgsb_2_4.f @@ -0,0 +1,358 @@ + +c DRIVER 2 +c -------------------------------------------------------------- +c CUSTOMIZED DRIVER FOR L-BFGS-B (version 2.4) +c -------------------------------------------------------------- +c +c L-BFGS-B is a code for solving large nonlinear optimization +c problems with simple bounds on the variables. +c +c The code can also be used for unconstrained problems and is +c as efficient for these problems as the earlier limited memory +c code L-BFGS. +c +c This driver illustrates how to control the termination of the +c run and how to design customized output. +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN +c Subroutines for Large Scale Bound Constrained Optimization'' +c Tech. Report, NAM-11, EECS Department, Northwestern University, +c 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to ece.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision April 1997.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************** + + subroutine Lbfgsb_2_4(n,x,f,l,u,nbd,funkminfjac, + & pgtol,info) + implicit none + +! info =0, best parameters on output +! info =1, output may not be best parameters +! info <0: parameter out of bounds. |info| denotes the out-of-bound parameter +! info =11: the correlation matrix is not postitive definite (the determinant is negative) + +c This driver shows how to replace the default stopping test +c by other termination criteria. It also illustrates how to +c print the values of several parameters during the course of +c the iteration. The sample problem used here is the same as in +c DRIVER1 (the extended Rosenbrock function with bounds on the +c variables). + + integer nmax, mmax, lenwa + parameter (nmax = 1024, mmax = 17) + parameter (lenwa = 2*mmax*nmax + 4*nmax + + + 11*mmax*mmax + 8*mmax) + +c nmax is the dimension of the largest problem to be solved. +c mmax is the maximum number of limited memory corrections. +c lenwa is the corresponding real workspace required. + +c Declare the variables needed by the code. +c A description of all these variables is given at the end of +c driver1. + + character*60 task, csave + logical lsave(4) + integer n, m, iprint, maxiter,info,idogradient, + + nbd(nmax), iwa(3*nmax), isave(44) + double precision f, factr, pgtol, + + x(nmax), l(nmax), u(nmax), g(nmax), dsave(29), + + wa(lenwa) + parameter(maxiter=2000) + external funkminfjac + +c Declare a few additional local variables. + + integer i + +c We suppress the default output. + + iprint = -1 + +c We suppress both code-supplied stopping tests because the +c user is providing his own stopping criteria. + + factr = 1.0d+1 + +! require funkminfjac to do function value and derivative calculations together + idogradient=1 + +c We specify the number +c m of limited memory corrections stored. (n and m should not +c exceed the limits nmax and mmax respectively.) + + m = 5 + +c All variables have both lower and upper bounds + +! do 10 i = 1, n +! nbd(i) = 2 +! 10 continue + +c We now define the starting point. + +c We start the iteration by initializing task. + + task = 'START' + info=0 + +c ------- The beginning of the loop ---------- + 111 continue + +c This is the call to the L-BFGS-B code. + + call setulb(n,m,x,l,u,nbd,f,g,factr,pgtol,wa,iwa,task,iprint, + + csave,lsave,isave,dsave) + if (task(1:2) .eq. 'FG') then + +c The minimization routine has returned to request the +c function f and gradient g values at the current x. + +c Compute the cost function value f + +! call funkmin(n,x,f) + +c Compute gradient g of the cost function at x + +! call fjac(n,x,f,g) + + call funkminfjac(n,x,idogradient,f,g,info) + + if(info.lt.0.or.info.eq.11)return + +c Go back to the minimization routine. + goto 111 + + elseif (task(1:5) .eq. 'NEW_X') then +c +c The minimization routine has returned with a new iterate. +c At this point have the opportunity of stopping the iteration +c or observing the values of certain parameters +c +c First are two examples of stopping tests. + +c Note: task(1:4) must be assigned the value 'STOP' to terminate +c the iteration and ensure that the final results are +c printed in the default format. The rest of the character +c string task may be used to store other information. + +c 1) Terminate if the total number of f and g evaluations +c exceeds maxiter. + + if (isave(34) .ge. maxiter) + + task='STOP: TOTAL NO. of f AND g EVALUATIONS EXCEEDS LIMIT' + +c 2) Terminate if |proj g|/(1 + |f|) < pgtol, where +c "proj g" denoted the projected gradient + + if (dsave(13) .le. pgtol*(1.0d0 + dabs(f))) + + task='STOP: THE PROJECTED GRADIENT IS SUFFICIENTLY SMALL' + +c We now wish to get the following information at each +c iteration: +c +c 1) the current iteration number, isave(30), +c 2) the total number of f and g evaluations, isave(34), +c 3) the value of the objective function f, +c 4) the norm of the projected gradient, dsve(13) +c +c See the comments at the end of driver1 for a description +c of the variables isave and dsave. +c Go back to the minimization routine. + goto 111 + + else + +c We terminate execution when task is neither FG nor NEW_X. +c We print the information contained in the string task +c if the default output is not used and the execution is +c not stopped intentionally by the user. In this case the last +! x and f may not be the best + + if (task(1:4).eq.'ERROR')info=1 + + endif + +c ---------- the end of the loop ------------- + + return + + end subroutine Lbfgsb_2_4 + +c======================= The end of Lbfgsb_2_4 ============================ + +c -------------------------------------------------------------- +c DESCRIPTION OF THE VARIABLES IN L-BFGS-B +c -------------------------------------------------------------- +c +c n is an INTEGER variable that must be set by the user to the +c number of variables. It is not altered by the routine. +c +c m is an INTEGER variable that must be set by the user to the +c number of corrections used in the limited memory matrix. +c It is not altered by the routine. Values of m < 3 are +c not recommended, and large values of m can result in excessive +c computing time. The range 3 <= m <= 20 is recommended. +c +c x is a DOUBLE PRECISION array of length n. On initial entry +c it must be set by the user to the values of the initial +c estimate of the solution vector. Upon successful exit, it +c contains the values of the variables at the best point +c found (usually an approximate solution). +c +c l is a DOUBLE PRECISION array of length n that must be set by +c the user to the values of the lower bounds on the variables. If +c the i-th variable has no lower bound, l(i) need not be defined. +c +c u is a DOUBLE PRECISION array of length n that must be set by +c the user to the values of the upper bounds on the variables. If +c the i-th variable has no upper bound, u(i) need not be defined. +c +c nbd is an INTEGER array of dimension n that must be set by the +c user to the type of bounds imposed on the variables: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, +c 3 if x(i) has only an upper bound. +c +c f is a DOUBLE PRECISION variable. If the routine setulb returns +c with task(1:2)= 'FG', then f must be set by the user to +c contain the value of the function at the point x. +c +c g is a DOUBLE PRECISION array of length n. If the routine setulb +c returns with taskb(1:2)= 'FG', then g must be set by the user to +c contain the components of the gradient at the point x. +c +c factr is a DOUBLE PRECISION variable that must be set by the user. +c It is a tolerance in the termination test for the algorithm. +c The iteration will stop when +c +c (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch +c +c where epsmch is the machine precision which is automatically +c generated by the code. Typical values for factr on a computer +c with 15 digits of accuracy in double precision are: +c factr=1.d+12 for low accuracy; +c 1.d+7 for moderate accuracy; +c 1.d+1 for extremely high accuracy. +c The user can suppress this termination test by setting factr=0. +c +c pgtol is a double precision variable. +c On entry pgtol >= 0 is specified by the user. The iteration +c will stop when +c +c max{|proj g_i | i = 1, ..., n} <= pgtol +c +c where pg_i is the ith component of the projected gradient. +c The user can suppress this termination test by setting pgtol=0. +c +c wa is a DOUBLE PRECISION array of length +c (2mmax + 4)nmax + 11mmax^2 + 8mmax used as workspace. +c This array must not be altered by the user. +c +c iwa is an INTEGER array of length 3nmax used as +c workspace. This array must not be altered by the user. +c +c task is a CHARACTER string of length 60. +c On first entry, it must be set to 'START'. +c On a return with task(1:2)='FG', the user must evaluate the +c function f and gradient g at the returned value of x. +c On a return with task(1:5)='NEW_X', an iteration of the +c algorithm has concluded, and f and g contain f(x) and g(x) +c respectively. The user can decide whether to continue or stop +c the iteration. +c When +c task(1:4)='CONV', the termination test in L-BFGS-B has been +c satisfied; +c task(1:4)='ABNO', the routine has terminated abnormally +c without being able to satisfy the termination conditions, +c x contains the best approximation found, +c f and g contain f(x) and g(x) respectively; +c task(1:5)='ERROR', the routine has detected an error in the +c input parameters; +c On exit with task = 'CONV', 'ABNO' or 'ERROR', the variable task +c contains additional information that the user can print. +c This array should not be altered unless the user wants to +c stop the run for some reason. See driver2 or driver3 +c for a detailed explanation on how to stop the run +c by assigning task(1:4)='STOP' in the driver. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c csave is a CHARACTER working array of length 60. +c +c lsave is a LOGICAL working array of dimension 4. +c On exit with task = 'NEW_X', the following information is +c available: +c lsave(1) = .true. the initial x did not satisfy the bounds; +c lsave(2) = .true. the problem contains bounds; +c lsave(3) = .true. each variable has upper and lower bounds. +c +c isave is an INTEGER working array of dimension 44. +c On exit with task = 'NEW_X', it contains information that +c the user may want to access: +c isave(30) = the current iteration number; +c isave(34) = the total number of function and gradient +c evaluations; +c isave(36) = the number of function value or gradient +c evaluations in the current iteration; +c isave(38) = the number of free variables in the current +c iteration; +c isave(39) = the number of active constraints at the current +c iteration; +c +c See the subroutine setulb.f for a description of other +c information contained in isave. +c +c dsave is a DOUBLE PRECISION working array of dimension 29. +c On exit with task = 'NEW_X', it contains information that +c the user may want to access: +c dsave(2) = the value of f at the previous iteration; +c dsave(5) = the machine precision epsmch generated by the code; +c dsave(13) = the infinity norm of the projected gradient; +c +c See the subroutine setulb.f for a description of other +c information contained in dsave. +c +c -------------------------------------------------------------- +c END OF THE DESCRIPTION OF THE VARIABLES IN L-BFGS-B +c -------------------------------------------------------------- +c +c << An example of subroutine 'timer' for AIX Version 3.2 >> +c +c subroutine timer(ttime) +c double precision ttime +c integer itemp, integer mclock +c +c itemp = mclock() +c ttime = dble(itemp)*1.0d-2 +c return +c end +c----------------------------------------------------------------------- \ No newline at end of file diff --git a/dataassim/math/optimization/MultiFit_GenericRegres.f b/dataassim/math/optimization/MultiFit_GenericRegres.f new file mode 100644 index 0000000..978a242 --- /dev/null +++ b/dataassim/math/optimization/MultiFit_GenericRegres.f @@ -0,0 +1,411 @@ + subroutine funkmin_generic(ndim,beta,fvalue) + implicit none + include 'forgenericregres.h' + integer ndim + double precision beta(ndim),fvalue +!(in) ndim: the dimension of the parameter vector +!(in) beta: the parameters +!(out) fvalue: the value of the cost function at beta +!----------------------------------------------------- + integer i,j,k,idowhat,nparams,ibreak + double precision dydxp(nyvars,(nxvars+ndim)),params(ndim) + + ibreak=39 +! +! check to see if parameters are out of bounds + if(betamin(1).lt.betamax(1))then + do i=1,ndim + if(beta(i).lt.betamin(i).or. + & beta(i).gt.betamax(i))then +! parameter out of bound + fvalue=1.0d+100 + return + endif + enddo + endif + fvalue=0.0d0 + if(iregrestype.eq.0)then + idowhat=0 + do i=1,nobs + if(i.le.ibreak)then + nparams=ndim-1 + do j=1,nparams + params(j)=beta(j) + enddo + else + nparams=ndim-1 + do j=1,nparams + params(j)=beta(j) + enddo + params(nparams)=beta(ndim) + endif + call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars, + & xvars(i:i,1:nxvars),nparams,params, + & dydxp(1:nyvars,1:(nxvars+nparams)),idowhat) + do j=1,nyvars + fvalue=fvalue+weity(i,j)* + & (shorty(i,j)-yobs(i,j))**2 + enddo + enddo + endif + return + + if(iregrestype.eq.1)then +!orthogonal distance regression + do i=1,nobs + call shortestdist(nyvars,nxvars,yobs(i:i,1:nyvars), + & xvars(i:i,1:nxvars),xmin(i:i,1:nxvars), + & xmax(i:i,1:nxvars),ndim,beta,iknowder, + & shorty(i:i,1:nyvars),shortx(i:i,1:nxvars)) + do j=1,nyvars + fvalue=fvalue+weity(i,j)* + & (shorty(i,j)-yobs(i,j))**2 + enddo + do j=1,nxvars + fvalue=fvalue+weitx(i,j)* + & (shortx(i,j)-xvars(i,j))**2 + enddo + enddo + endif + if(iregrestype.eq.2)then + nparams=ndim-nobs + idowhat=nparams + do i=1,nobs + do j=1,nxvars + idowhat=idowhat+1 + shortx(i,j)=beta(idowhat) + enddo + enddo + idowhat=0 + do i=1,nobs + call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars, + & shortx(i:i,1:nxvars),nparams,beta, + & dydxp(1:nyvars,1:(nxvars+ndim)),idowhat) + do j=1,nyvars + fvalue=fvalue+weity(i,j)* + & (shorty(i,j)-yobs(i,j))**2 + enddo + do j=1,nxvars + fvalue=fvalue+weitx(i,j)* + & (shortx(i,j)-xvars(i,j))**2 + enddo + enddo + endif + if(iregrestype.eq.-1)then +!implicit orthogonal distance regression + idowhat=0 + do i=1,nobs + call surffunc(nyvars,shorty(i:i,1:nyvars),nxvars, + & xvars(i:i,1:nxvars),ndim,beta, + & dydxp(1:nyvars,1:(nxvars+ndim)),idowhat) + do j=1,nyvars + fvalue=fvalue+weity(i,j)* + & shorty(i,j)**2 + enddo + enddo + endif + return + end subroutine funkmin_generic +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function f1dim_generic(x) + implicit none + double precision x +CU USES funkmin_generic + INTEGER j +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /f1com/ pcom,xicom,ncom + save /f1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + double precision xt(NMAX) +!----------------------------------------------------- + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call funkmin_generic(ncom,xt,f1dim_generic) + return + END +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + SUBROUTINE FCN_generic(N,M,NP,NQ, + + LDN,LDM,LDNP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,F,FJACB,FJACD, + + ISTOP) + implicit none + include 'forgenericregres.h' + +C SUBROUTINE ARGUMENTS +C ==> N NUMBER OF OBSERVATIONS +C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N +C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M +C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP +C ==> BETA CURRENT VALUES OF PARAMETERS +C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED +C <== F PREDICTED FUNCTION VALUES +C <== FJACB JACOBIAN WITH RESPECT TO BETA +C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA +C <== ISTOP STOPPING CONDITION, WHERE +C 0 MEANS CURRENT BETA AND X+DELTA WERE +C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY +C 1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES +C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE +C -1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD STOP + +C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE: + INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ + DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M) + INTEGER IFIXB(NP),IFIXX(LDIFX,M) +C OUTPUT ARGUMENTS: + DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) + double precision ymod(NQ),dydxp(NQ,(M+NP)),params(NP) + integer k,idowhat,nparams,ibreak +!----------------------------------------------------- + + ibreak=39 + + if(betamin(1).lt.betamax(1))then + do I=1,NP + if(BETA(I).lt.betamin(I).or.BETA(I).gt.betamax(I))then + ISTOP = 1 + RETURN + endif + enddo + endif + ISTOP=0 + IF (MOD(IDEVAL,10).GE.1) THEN + idowhat=0 + DO 100 I = 1,N + + if(I.le.ibreak)then + nparams=NP-1 + do k=1,nparams + params(k)=BETA(k) + enddo + else + nparams=NP-1 + do k=1,nparams + params(k)=BETA(k) + enddo + params(nparams)=BETA(NP) + endif + + call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M), + &nparams,params,dydxp(1:NQ,1:(M+nparams)),idowhat) + + DO 110 L = 1,NQ + F(I,L)=ymod(L) +110 CONTINUE +100 CONTINUE + END IF + +C COMPUTE DERIVATIVES WITH RESPECT TO BETA + IF (MOD(IDEVAL/10,10).GE.1) THEN + idowhat=2 + DO 200 I = 1,N + + if(I.le.ibreak)then + nparams=NP-1 + do k=1,nparams + params(k)=BETA(k) + enddo + else + nparams=NP-1 + do k=1,nparams + params(k)=BETA(k) + enddo + params(nparams)=BETA(NP) + endif + + call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M), + &nparams,params,dydxp(1:NQ,1:(M+nparams)),idowhat) + DO 210 L = 1,NQ + do k=1,nparams + FJACB(I,k,L)=dydxp(L,k) + enddo + + if(I.le.ibreak)then + FJACB(I,NP,L)=0.0d0 + else + FJACB(I,NP,L)=dydxp(L,nparams) + FJACB(I,nparams,L)=0.0d0 + endif + + 210 CONTINUE + 200 CONTINUE + ENDIF + +c compute derivatives with respect to delta + IF (MOD(IDEVAL/100,10).GE.1) THEN + idowhat=1 + DO 300 I = 1,N + + if(I.le.ibreak)then + nparams=NP-1 + do k=1,nparams + params(k)=BETA(k) + enddo + else + nparams=NP-1 + do k=1,nparams + params(k)=BETA(k) + enddo + params(nparams)=BETA(NP) + endif + + call surffunc(NQ,ymod,M,XPLUSD(I:I,1:M), + &nparams,params,dydxp(1:NQ,1:(M+nparams)),idowhat) + DO 310 L = 1,NQ + do k=1,M + FJACD(I,k,L)=dydxp(L,k) + enddo + 310 CONTINUE + 300 CONTINUE + ENDIF + RETURN + END +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine distcenter(nx,x,fequ,fvalue,idowhat) + implicit none + include 'leastdistance.h' +!idowhat=1, evaluating the system of equations and calculating the sum of squares. +!idowhat=2, calculating the distance. + integer nx,idowhat + double precision x(nx),fequ(nx),fvalue +!---------------------------------------------------------- + integer i,j,ider + double precision y(my),dydxp(my,(nx+nparams)), + & xcopy(nx),sum,yplush(my),yminush(my),h + parameter(h=1.0d-7) +!==============End of Variable Declaration================== + j=0 + call surffunc(my,y,nx,x,nparams,params, + & dydxp(1:my,1:(nx+nparams)),j) + if(idowhat.eq.1)then + if(iknowder.eq.1)then + call surffunc(my,y,nx,x,nparams,params, + & dydxp(1:my,1:(nx+nparams)),iknowder) + endif + if(iknowder.eq.0)then + do i=1,nx + xcopy(i)=x(i) + enddo + do i=1,nx + xcopy(i)=x(i)+h + call surffunc(my,yplush,nx,xcopy,nparams,params, + & dydxp(1:my,1:(nx+nparams)),iknowder) + xcopy(i)=x(i)-h + call surffunc(my,yminush,nx,xcopy,nparams,params, + & dydxp(1:my,1:(nx+nparams)),iknowder) + do j=1,my + dydxp(j,i)=(yplush(j)-yminush(j))/(2.0d0*h) + enddo + xcopy(i)=x(i) + enddo + endif + do i=1,nx + sum=0.0d0 + do j=1,my + sum=sum+(y(j)-targety(j))*dydxp(j,i) + enddo + fequ(i)=x(i)-(targetx(i)-sum) + enddo + fvalue=0.0d0 + do i=1,nx + fvalue=fvalue+fequ(i)*fequ(i) + enddo + endif + if(idowhat.eq.2)then + fvalue=0.0d0 + do i=1,my + fvalue=fvalue+(y(i)-targety(i))**2 + enddo + do i=1,nx + fvalue=fvalue+(x(i)-targetx(i))**2 + enddo + endif + return + end subroutine distcenter +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine distcentersys(nunknowns,x,fequ,fsqsum) + implicit none + integer nunknowns,idowhat + double precision x(nunknowns), + & fequ(nunknowns),fsqsum + parameter(idowhat=1) + call distcenter(nunknowns,x,fequ,fsqsum,idowhat) + return + end subroutine distcentersys +!----------------------------------------------------------- + subroutine fsqsum_distcenter(nunknowns,x,fsqsum) + implicit none + integer nunknowns,idowhat + double precision x(nunknowns),fsqsum, + & fequ(nunknowns) + parameter(idowhat=1) + call distcenter(nunknowns,x,fequ,fsqsum,idowhat) + return + end +!----------------------------------------------------------- + double precision function f1dimsqsum_distcenter(x) + implicit none + double precision x + INTEGER j,idowhat +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /cpf1com/ pcom,xicom,ncom + save /cpf1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + double precision xt(NMAX),fequ(NMAX) + parameter(idowhat=1) + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call distcenter(ncom,xt,fequ, + & f1dimsqsum_distcenter,idowhat) + return + END +!------------------------------------------------------------ + subroutine s2_distcenter(nunknowns,x,s2) + implicit none + integer nunknowns,idowhat + double precision x(nunknowns),s2,fequ(nunknowns) + parameter(idowhat=2) + call distcenter(nunknowns,x,fequ,s2,idowhat) + return + end +!----------------------------------------------------------- + double precision function f1dims2_distcenter(x) + implicit none + double precision x + INTEGER j,idowhat +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /cpf1com/ pcom,xicom,ncom + save /cpf1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + double precision xt(NMAX),fequ(NMAX) + parameter(idowhat=2) + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call distcenter(ncom,xt,fequ, + & f1dims2_distcenter,idowhat) + return + END +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/optimization/NeuralNetRegres.f b/dataassim/math/optimization/NeuralNetRegres.f new file mode 100644 index 0000000..04fd6dc --- /dev/null +++ b/dataassim/math/optimization/NeuralNetRegres.f @@ -0,0 +1,179 @@ + subroutine NeuralNetRegres(idowhat,nx0,nobs0,nh0,xsamp0, + &ysamp0,yatxsamp0,rsq,w,bph,q,bend,xnew,ypred) + implicit none + include 'NeuralNetRegres.h' +! +!=============Inputs regardless of idowhat========================= +!idowhat: =1, fit the data and estimate the coefficients. Provide the +! initial guess for the coefficients or set bend to -9999 +! =2, coefficients are already available, calculate y at xnew +!nx0: the number of independent (x) variables +!nobs0: the total number of samples +!nh0: the total number of hidden nodes to use. One hidden layer is +! assumed. +!============When idowhat=1======================================== +! --------Inputs-------- +!xsamp0: the values of the independent (x) variables +!ysamp0: the values of the dependent (y) variable. y is one dimension. +! --------Outputs------- +!w: the slope coefficient to time the normalized x in the activation function +!bph: the intercept coefficient in the activation function +!q: the coefficient to time the value of the activation function +!bend: the residual constant in the neural network regression +!yatxsamp0: the predicted y value at xsamp0 +!rsq: R squared +!============When idowhat=2========================================= +! --------Inputs-------- +!w: the slope coefficient to time the normalized x in the activation function +!bph: the intercept coefficient in the activation function +!q: the coefficient to time the value of the activation function +!bend: the residual constant in the neural network regression +!xnew: the new x point who y value is to be estimated (when idowhat=2) +! --------Outputs------- +!ypred: the predicted y value at xnew +! + integer idowhat,nx0,nobs0,nh0 + double precision xsamp0(nobs0,nx0),ysamp0(nobs0), + & yatxsamp0(nobs0),rsq,w(nx0,nh0),bph(nh0),q(nh0), + & bend,xnew(nx0),ypred +!============Locals========================================= + integer i,j,ndim,ny,INFO,iderivative,iregrestype +!iregrestype=0, ordinary distance regression + double precision xnormk(nx0),xnormb(nx0),std,fmean, + & xmin,xmax,fatbeta,fatbeta0,fatbetacp,ftol, + & beta(nx0*nh0+2*nh0+1),betacp(nx0*nh0+2*nh0+1),rms, + & agrind,ran2,annfunc,weitx(1:nobs0,1:nx0), + & weity(1:nobs0),shortx(1:nobs0,1:nx0), + & shorty(1:nobs0),yv(nobs0),fn9999,tiny + parameter(ftol=1.0d-8,iderivative=1,iregrestype=0, + &fn9999=-9999.0d0,tiny=1.0d-8) + external funkmin_neural,f1dim_neural,FCN_neural +! + if(idowhat.eq.1)then +!Regression + nx=nx0 + nobs=nobs0 + nh=nh0 +!xnormk: the slope of the linear transformation for xsamp0 +!xnormb: the intercept of the linear transformation for xsamp0 +!Transform xsamp to become bounded (-1,1) so that different independent variables +!are comparable in magnitude +!xmin ~ -1 +!xmax ~ +1 + do i=1,nobs + ysamp(i)=ysamp0(i) + weity(i)=1.0d0 + do j=1,nx + weitx(i,j)=1.0d0 + enddo + enddo + do i=1,nx + call stdmaxmeanmin(nobs,xsamp0(1:nobs,i:i), + & std,fmean,xmin,xmax) + if(xmax.eq.xmin)then + xnormk(i)=1.0d0 + xnormb(i)=0.0d0 + else + xnormk(i)=2.0d0/(xmax-xmin) + xnormb(i)=-(xmax+xmin)/(xmax-xmin) + endif + do j=1,nobs + xsamp(j,i)=xnormk(i)*xsamp0(j,i)+xnormb(i) + enddo + enddo + ndim=2*nh+nh*nx+1 + do i=1,ndim + betamin(i)=-1.0d+20 + betamax(i)=1.0d+20 + enddo + if(dabs(bend-fn9999).lt.tiny)then +!no initial guess. Use the general guess + do i=1,ndim + beta(i)=(ran2()-0.5d0)*2.0d0 + enddo + else +!initial guess provided. transform the guessed bph and w coefficients to correspond +!to the transformed x. + do i=1,nh0 + do j=1,nx0 + w(j,i)=w(j,i)/xnormk(j) + enddo + enddo + do i=1,nh0 + do j=1,nx0 + bph(i)=bph(i)-w(j,i)*xnormb(j) + enddo + enddo + call coeff_beta(2,nx,nh,beta,w(1:nx,1:nh),bph,q,bend) + endif + do i=1,ndim + betacp(i)=beta(i) + if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then +! write(*,*)'Inproper initial guess in NeuralNetRegres.f' + beta(i)=ran2() + endif + betacp(i)=beta(i) + enddo + call funkmin_neural(ndim,beta,fatbeta0) + INFO=iregrestype + ny=1 + fatbeta=fatbeta0 +90 call odr_leastsquare(ndim,FCN_neural,beta,nobs, + &xsamp(1:nobs,1:nx),nx,ysamp(1:nobs),ny,weitx(1:nobs,1:nx), + &weity(1:nobs),iderivative,shortx(1:nobs,1:nx),shorty(1:nobs), + &fatbeta,INFO) + call funkmin_neural(ndim,beta,fatbeta) +! if((fatbeta0-fatbeta).gt.ftol)then +! fatbeta0=fatbeta +! do i=1,ndim +! betacp(i)=beta(i) +! enddo +! goto 90 +! endif + if(fatbeta.gt.fatbeta0)then + j=0 + do i=1,ndim + beta(i)=betacp(i) + if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))j=1 + enddo + fatbeta=fatbeta0 + if(j.ne.0)then + do i=1,ndim + beta(i)=(ran2()-0.5d0)*2.0d0 + enddo + call funkmin_neural(ndim,beta,fatbeta) + endif + endif +100 fatbetacp=fatbeta + call nongradopt(ndim,funkmin_neural,f1dim_neural, + &beta,betamin,betamax,ftol,fatbeta) +! call RepeatCompassSearch(ndim,beta,fatbeta, +! &betamin,betamax,funkmin_neural,f1dim_neural,ftol) +! if(dabs(fatbetacp-fatbeta).gt.ftol)goto 100 + call funkmin_neural(ndim,beta,fatbeta) + call coeff_beta(idowhat,nx,nh,beta,w(1:nx,1:nh),bph,q,bend) +!transform the estimated bph and w coefficients so that the original x +!values can be used directly. + do i=1,nh0 + do j=1,nx0 + bph(i)=bph(i)+w(j,i)*xnormb(j) + enddo + enddo + do i=1,nh0 + do j=1,nx0 + w(j,i)=w(j,i)*xnormk(j) + enddo + enddo + do i=1,nobs0 + yatxsamp0(i)=annfunc(nx0,xsamp0(i:i,1:nx0),nh0,q, + & w(1:nx0,1:nh0),bph,bend) + enddo + call rsq_rms(ysamp0,yatxsamp0,nobs0,rsq,rms,agrind) + endif + if(idowhat.eq.2)then +!Predict y at x with the regression coefficients already estimated + ypred=annfunc(nx0,xnew,nh0,q,w(1:nx0,1:nh0),bph,bend) + endif + return + end +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& diff --git a/dataassim/math/optimization/NeuralNetRegres.h b/dataassim/math/optimization/NeuralNetRegres.h new file mode 100644 index 0000000..7570527 --- /dev/null +++ b/dataassim/math/optimization/NeuralNetRegres.h @@ -0,0 +1,9 @@ + integer maxnobs,maxnx,maxnh + parameter(maxnx=30,maxnh=maxnx*10,maxnobs=maxnx*1000) + integer nx,nh,nobs + common /annintegers/nx,nh,nobs + + double precision ysamp(maxnobs),xsamp(maxnobs,maxnx), + & betamin(maxnx*maxnh+2*maxnh), + & betamax(maxnx*maxnh+2*maxnh) + common /anndouble/ysamp,xsamp,betamin,betamax diff --git a/dataassim/math/optimization/amebsa.f b/dataassim/math/optimization/amebsa.f new file mode 100644 index 0000000..8cadaf2 --- /dev/null +++ b/dataassim/math/optimization/amebsa.f @@ -0,0 +1,121 @@ + SUBROUTINE amebsa(p,y,mp,np,ndim,pb,yb,ftol,funk,iter,temptr) + INTEGER iter,mp,ndim,np,NMAX + double precision ftol,temptr,yb,p(mp,np),pb(np),y(mp),funk + PARAMETER (NMAX=200) + EXTERNAL funk +CU USES amotsa,funk,ran1 + INTEGER i,idum,ihi,ilo,inhi,j,m,n + double precision rtol,sum,swap,tt,yhi,ylo,ynhi,ysave,yt,ytry, + &psum(NMAX),amotsa,ran1 + COMMON /ambsa/ tt,idum + tt=-temptr +1 do 12 n=1,ndim + sum=0.0d0 + do 11 m=1,ndim+1 + sum=sum+p(m,n) +11 continue + psum(n)=sum +12 continue +2 ilo=1 + inhi=1 + ihi=2 + ylo=y(1)+tt*dlog(ran1(idum)) + ynhi=ylo + yhi=y(2)+tt*dlog(ran1(idum)) + if (ylo.gt.yhi) then + ihi=1 + inhi=2 + ilo=2 + ynhi=yhi + yhi=ylo + ylo=ynhi + endif + do 13 i=3,ndim+1 + yt=y(i)+tt*dlog(ran1(idum)) + if(yt.le.ylo) then + ilo=i + ylo=yt + endif + if(yt.gt.yhi) then + inhi=ihi + ynhi=yhi + ihi=i + yhi=yt + else if(yt.gt.ynhi) then + inhi=i + ynhi=yt + endif +13 continue + rtol=2.0d0*dabs(yhi-ylo)/(dabs(yhi)+dabs(ylo)) + if(rtol.lt.ftol.or.iter.lt.0) then + swap=y(1) + y(1)=y(ilo) + y(ilo)=swap + do 14 n=1,ndim + swap=p(1,n) + p(1,n)=p(ilo,n) + p(ilo,n)=swap +14 continue + return + endif + iter=iter-2 + ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,-1.0d0) + if (ytry.le.ylo) then + ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,2.0d0) + else if (ytry.ge.ynhi) then + ysave=yhi + ytry=amotsa(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,0.5d0) + if (ytry.ge.ysave) then + do 16 i=1,ndim+1 + if(i.ne.ilo)then + do 15 j=1,ndim + psum(j)=0.5d0*(p(i,j)+p(ilo,j)) + p(i,j)=psum(j) +15 continue + y(i)=funk(psum) + endif +16 continue + iter=iter-ndim + goto 1 + endif + else + iter=iter+1 + endif + goto 2 + END + + double precision FUNCTION amotsa + &(p,y,psum,mp,np,ndim,pb,yb,funk,ihi,yhi,fac) + INTEGER ihi,mp,ndim,np,NMAX + double precision amotsa,fac,yb,yhi,p(mp,np),pb(np),psum(np), + &y(mp),funk + PARAMETER (NMAX=200) + EXTERNAL funk +CU USES funk,ran1 + INTEGER idum,j + double precision fac1,fac2,tt,yflu,ytry,ptry(NMAX),ran1 + COMMON /ambsa/ tt,idum + fac1=(1.-fac)/ndim + fac2=fac1-fac + do 11 j=1,ndim + ptry(j)=psum(j)*fac1-p(ihi,j)*fac2 +11 continue + ytry=funk(ptry) + if (ytry.le.yb) then + do 12 j=1,ndim + pb(j)=ptry(j) +12 continue + yb=ytry + endif + yflu=ytry-tt*log(ran1(idum)) + if (yflu.lt.yhi) then + y(ihi)=ytry + yhi=yflu + do 13 j=1,ndim + psum(j)=psum(j)-p(ihi,j)+ptry(j) + p(ihi,j)=ptry(j) +13 continue + endif + amotsa=yflu + return + END diff --git a/dataassim/math/optimization/annactivatefunc.f b/dataassim/math/optimization/annactivatefunc.f new file mode 100644 index 0000000..fcf9bac --- /dev/null +++ b/dataassim/math/optimization/annactivatefunc.f @@ -0,0 +1,103 @@ +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function annfunc(nparams,params,nh,q,w,bph,bend) + implicit none + integer nparams,nh +!nh is the number of hidden nodes in one hiden layer +!params is the inputs +!w is the weighting coefficients for the inputs + double precision params(nparams),q(nh), + &w(nparams,nh),bph(nh),bend + integer i,v + double precision term,activatefunc + annfunc=bend + do i=1,nh + term=bph(i) + do v=1,nparams + term=term+w(v,i)*params(v) + enddo + annfunc=annfunc+q(i)*activatefunc(term) + enddo + end + + subroutine derannfunc(nparams,params,nh,q,w,bph, + & bend,derq,derw,derbph,derbend) + implicit none + integer nparams,nh +!nh is the number of hidden nodes in one hiden layer +!params is the inputs +!w is the weighting coefficients for the inputs + double precision params(nparams),q(nh),w(nparams,nh), + &bph(nh),bend,derq(nh),derw(nparams,nh),derbph(nh),derbend + integer i,v + double precision term,activatefunc,gradactivatefunc + derbend=1.0d0 + do i=1,nh + term=bph(i) + do v=1,nparams + term=term+w(v,i)*params(v) + enddo + derq(i)=activatefunc(term) + derbph(i)=q(i)*gradactivatefunc(term) + do v=1,nparams + derw(v,i)=derbph(i)*params(v) + enddo + enddo + end + + double precision function activatefunc(x) + implicit none + double precision x,crit + parameter(crit=300) + +! activatefunc=2.0d0*datan(x)/3.14159265d0 +! return + + if(x.gt.-crit)then + activatefunc=1.0d0/(1.0d0+dexp(-x)) + else + activatefunc=dexp(x)/(1.0d0+dexp(x)) + endif + return + end + + double precision function gradactivatefunc(x) + implicit none + double precision x,crit + parameter(crit=600) + +! gradactivatefunc=2.0d0/(3.14159265d0*(1.0d0+x*x)) +! return + + if(x.gt.-crit.and.x.lt.crit)then + gradactivatefunc= + & (1.0d0/(dexp(x/2.0d0)+dexp(-x/2.0d0)))**2 + else + gradactivatefunc=0.0d0 + endif + return + end + + subroutine gradannfunc(nparams,params,nh,q,w,bph, + &der_params) + implicit none + integer nparams,nh + double precision params(nparams),der_params(nparams), + &q(nh),w(nparams,nh),bph(nh) + integer i,v + double precision term,dsigdterm, + & gradactivatefunc,activatefunc + do i=1,nparams + der_params(i)=0.0d0 + enddo + do i=1,nh + term=bph(i) + do v=1,nparams + term=term+w(v,i)*params(v) + enddo + dsigdterm=gradactivatefunc(term) + do v=1,nparams + der_params(v)=der_params(v)+q(i)*dsigdterm*w(v,i) + enddo + enddo + return + end diff --git a/dataassim/math/optimization/coeff_beta.f b/dataassim/math/optimization/coeff_beta.f new file mode 100644 index 0000000..6cbce23 --- /dev/null +++ b/dataassim/math/optimization/coeff_beta.f @@ -0,0 +1,49 @@ + subroutine coeff_beta(idowhat,nx,nh,BETA,w,bph,q,bend) + implicit none +!idowhat=1, allocate BETA to w, bph, q +! =2, allocate w, bph, q to BETA +! + integer k,i,nx,nh,j,idowhat + double precision w(1:nx,1:nh),bph(nh),q(nh), + & bend,BETA(nx*nh+2*nh+1) + if(idowhat.eq.1)then + k=0 + do i=1,nx + do j=1,nh + k=k+1 + w(i,j)=BETA(k) + enddo + enddo + do i=1,nh + k=k+1 + bph(i)=BETA(k) + enddo + do i=1,nh + k=k+1 + q(i)=BETA(k) + enddo + k=k+1 + bend=BETA(k) + endif +! + if(idowhat.eq.2)then + k=0 + do i=1,nx + do j=1,nh + k=k+1 + BETA(k)=w(i,j) + enddo + enddo + do i=1,nh + k=k+1 + BETA(k)=bph(i) + enddo + do i=1,nh + k=k+1 + BETA(k)=q(i) + enddo + k=k+1 + BETA(k)=bend + endif + return + end diff --git a/dataassim/math/optimization/cpCompassSearch.f b/dataassim/math/optimization/cpCompassSearch.f new file mode 100644 index 0000000..186b50a --- /dev/null +++ b/dataassim/math/optimization/cpCompassSearch.f @@ -0,0 +1,198 @@ + subroutine cpRepeatCompassSearch(ndim,xbest,fbest, + & bmin,bmax,funkmin,f1dim,xtol) + implicit none + integer ndim + double precision xbest(1:ndim),fbest, + & bmin(1:ndim),bmax(1:ndim),xtol + double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim) + parameter(ftol=1.0d-7) + integer i,n + logical resetran2 + common /cpran2reset/resetran2 + external funkmin,f1dim +! + n=0 + resetran2=.true. +10 fvalpre=fbest + do i=1,ndim + xpre(i)=xbest(i) + enddo + call cpCompassSearch(ndim,xbest,fbest, + & bmin,bmax,funkmin,f1dim,xtol) + n=n+1 + dmax=dabs(xbest(1)-xpre(1)) + do i=2,ndim + if(dmax.lt.dabs(xbest(i)-xpre(i)))then + dmax=dabs(xbest(i)-xpre(i)) + endif + enddo + if(dabs(fvalpre-fbest).gt.ftol.and. + & dmax.gt.xtol.and.n.lt.5000)then + do i=1,ndim + direction(i)=xbest(i)-xpre(i) + enddo + call linmin(xbest,bmin,bmax,direction, + & ndim,f1dim,fbest) + goto 10 + endif + return + end subroutine cpRepeatCompassSearch + + subroutine cpCompassSearch(ndim,xbest,fbest, + & bmin,bmax,funkmin,f1dim,xtol) + implicit none + +! This subroutine minimizes the function funkmin using the compass search method. The ! maximum number of function evaluations is maxiter. Once mexiter is reached, all +! function evaluations are ranked and returned. +! +!------------------------------------- Inputs ----------------------------------------------------- +! maxiter: the maximum number of function evaluations allowed +! xbest: the initial guess +! fbest: the cost function value at xinitial +! bmin: the lower bounds of the parameters to be optimized +! bmax: the upper bounds of the parameters to be optimized +! ndim: the number of parameters to optimize +! funkmin: the name of the function to minimize + +!------------------------------------- Outputs --------------------------------------------------- +! xobs: points where the function is evaluated. Ranked from the best to worst with the +! first point being the best point. +! fvalue: the function values at xobs +! ierr: =0 convergence criterion not reached +! =1 convergence criterion reached (minimum found) +! + integer ndim + double precision xbest(1:ndim),fbest, + & bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2 + external funkmin,f1dim +!------------------------------- Locals ----------------------------------------------------------- + double precision diftol,delta, + & xcompass(1:2*ndim,1:ndim),fcompass(1:2*ndim), + & xvec(1:ndim),xcent(1:ndim),fcent,dif,shrink, + & direction(ndim),dmax,fcent0,cpran2_reset + + parameter(shrink=0.618d0,diftol=1.0d-7) + integer i,j,k +! + delta=0.618d0 + do i=1,ndim + xcent(i)=xbest(i) + enddo + fcent=fbest +10 continue + do i=1,ndim + do j=1,ndim + xcompass(i,j)=xcent(j) + xcompass(ndim+i,j)=xcent(j) + enddo + xcompass(i,i)=xcent(i)+delta*(bmax(i)-xcent(i)) + xcompass(ndim+i,i)=xcent(i)+delta*(bmin(i)-xcent(i)) + enddo + + do i=1,2*ndim + do j=1,ndim + xvec(j)=xcompass(i,j) + enddo + call funkmin(ndim,xvec,fcompass(i)) + enddo + do i=1,ndim + xbest(i)=xcompass(1,i) + enddo + fbest=fcompass(1) + do i=2,2*ndim + if(fcompass(i).lt.fbest)then + fbest=fcompass(i) + do j=1,ndim + xbest(j)=xcompass(i,j) + enddo + endif + enddo + fcent0=fcent + do i=1,ndim + xvec(i)=xcent(i) + enddo + do i=1,ndim + dx1=xcompass(i,i)-xcent(i) + dx2=xcent(i)-xcompass(i+ndim,i) + direction(i)=0.0d0 + if(dx1.ne.0.0d0)then + direction(i)=(fcompass(i)-fcent)/dx1 + endif + if(dx2.ne.0.0d0)then + direction(i)=direction(i)+ + & (fcent-fcompass(i+ndim))/dx2 + endif + direction(i)=-0.5d0*direction(i) + if(direction(i).eq.0.0d0)direction(i)= + & cpran2_reset()-0.5d0 + enddo + call cplinmin(xcent,bmin,bmax,direction, + & ndim,f1dim,fcent) + if(fcent.gt.fcent0)then + fcent=fcent0 + do i=1,ndim + xcent(i)=xvec(i) + enddo + endif + dif=fcent-fbest + if(fbest.le.fcent)then + fcent=fbest + do i=1,ndim + xcent(i)=xbest(i) + enddo + endif + if(dif.ge.0.0d0)then + if(dif.gt.diftol)goto 10 + if(delta.lt.diftol)goto 100 + delta=delta*shrink + goto 10 + else +!no progress + if(dabs(dif).gt.diftol)then + if(delta.lt.diftol)goto 100 + delta=delta*shrink + goto 10 + endif + dmax=dabs(xcompass(1,1)-xcompass(ndim+1,1)) + do i=2,ndim + if(dmax.lt.dabs(xcompass(i,i)- + & xcompass(ndim+i,i)))then + dmax=dabs(xcompass(i,i)- + & xcompass(ndim+i,i)) + endif + enddo + if(dmax.gt.xtol)then + if(delta.lt.diftol)goto 100 + delta=delta*shrink + goto 10 + else + goto 100 + endif + endif +100 fbest=fcent + do i=1,ndim + xbest(i)=xcent(i) + dx1=xcompass(i,i)-xcent(i) + dx2=xcent(i)-xcompass(i+ndim,i) + direction(i)=0.0d0 + if(dx1.ne.0.0d0)then + direction(i)=(fcompass(i)-fcent)/dx1 + endif + if(dx2.ne.0.0d0)then + direction(i)=direction(i)+ + & (fcent-fcompass(i+ndim))/dx2 + endif + direction(i)=-0.5d0*direction(i) + if(direction(i).eq.0.0d0)direction(i)= + & cpran2_reset()-0.5d0 + enddo + call cplinmin(xcent,bmin,bmax,direction, + & ndim,f1dim,fcent) + if(fcent.lt.fbest)then + fbest=fcent + do i=1,ndim + xbest(i)=xcent(i) + enddo + endif + return + end subroutine cpCompassSearch diff --git a/dataassim/math/optimization/cpnongradopt.f b/dataassim/math/optimization/cpnongradopt.f new file mode 100644 index 0000000..7b7c460 --- /dev/null +++ b/dataassim/math/optimization/cpnongradopt.f @@ -0,0 +1,247 @@ + subroutine cpnongradopt(ndim,funkmin,f1dim,beta, + & bmin,bmax,ftol,fatbeta) + implicit none +! +! This subroutine minimizes function funkmin to estimate ndim parameters +! using non-gradient based methods +! + integer ndim + double precision beta(1:ndim),bmin(1:ndim), + & bmax(1:ndim),ftol,fatbeta +! +! ------------------ Inputs ----------------------------- +! ndim: the total number of parameters to be estimated +! bmax: the maximum possible value of beta, used to determine the distance scaling factor +! bmin: the minimum possible value of beta, used to determine the distance scaling factor +! beta: initial guess, overwritten upon return +! ftol: tolerance for convergence +! fatbeta: the cost function valuate at beta, overwritten upon return +! funkmin is the name of the subroutine that computes the cost function +! f1dim: the one dimensional cost function + +! ------------------ Outputs ---------------------------- +! beta: The best parameters obtained +! fatbeta: the cost function value at beta + + integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX, + & icycle + parameter(maxredo=20,ITMAX=20000) + double precision fbest,xbest(1:ndim), + & xinidir(1:ndim,1:ndim),xbest0(1:ndim), + & pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1) + external funkmin,f1dim +! End of declaration of variables +!--------------------------------------------------------------- + icycle=0 +1 iredo=0 +3 do n=1,ndim + xbest(n)=beta(n) + do nn=1,ndim + xinidir(n,nn)=0.0d0 + enddo + xinidir(n,n)=1.0d0 + enddo + fbest=fatbeta + call cppowell(beta,xinidir(1:ndim,1:ndim),ndim, + &ndim,ftol,fatbeta,bmin,bmax,funkmin,f1dim,ITMAX) + if(fatbeta.gt.fbest)then + do n=1,ndim + beta(n)=xbest(n) + enddo + fatbeta=fbest + goto 10 + endif + if((fbest-fatbeta).gt.ftol)then + if(iredo.gt.maxredo)goto 10 + iredo=iredo+1 + goto 3 + endif + +10 iredo=0 +20 do n=1,ndim + xbest(n)=beta(n) + enddo + fbest=fatbeta + do nn=1,ndim + pamoeba(1,nn)=beta(nn) + enddo + famoeba(1)=fatbeta + do n=2,ndim+1 + do nn=1,ndim + pamoeba(n,nn)=beta(nn) + enddo + if((bmax(n-1)-pamoeba(n,n-1)) + & .gt.(pamoeba(n,n-1)-bmin(n-1)))then + pamoeba(n,n-1)=pamoeba(n,n-1)+ + & (bmax(n-1)-pamoeba(n,n-1))*0.1d0 + else + pamoeba(n,n-1)=pamoeba(n,n-1)- + & (pamoeba(n,n-1)-bmin(n-1))*0.1d0 + endif + do nn=1,ndim + xbest0(nn)=pamoeba(n,nn) + enddo + call funkmin(ndim,xbest0,famoeba(n)) + enddo + mpamoeba=ndim+1 + npamoeba=ndim + call cpguamoeba(pamoeba(1:ndim+1,1:ndim), + & famoeba(1:ndim+1),mpamoeba,npamoeba,ndim, + & ftol,funkmin,ITMAX/20) + nn=1 + do n=2,ndim+1 + if(famoeba(n).lt.famoeba(nn))nn=n + enddo + fatbeta=famoeba(nn) + do n=1,ndim + beta(n)=pamoeba(nn,n) + if(beta(n).lt.bmin(n).or.beta(n).gt.bmax(n))then + do nn=1,ndim + beta(nn)=xbest(nn) + enddo + fatbeta=fbest + return + endif + enddo + if((fbest-fatbeta).gt.ftol)then + if(iredo.gt.maxredo)then + if(icycle.lt.maxredo)then + icycle=icycle+1 + goto 1 + else + return + endif + endif + iredo=iredo+1 + goto 20 + endif + return + end subroutine cpnongradopt +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + SUBROUTINE cpguamoeba(p,y,mp,np,ndim,ftol,funkmin,ITMAX) + implicit none + INTEGER iter,mp,ndim,np,NMAX,ITMAX + double precision ftol,p(mp,np),y(mp),TINY + PARAMETER (TINY=1.0d-20) + external funkmin +CU USES cpguamotry,funkmin + INTEGER i,ihi,ilo,inhi,j,m,n + double precision rtol,sum,swap,ysave,ytry,psum(ndim), + & cpguamotry,degen + iter=0 +1 do 12 n=1,ndim + sum=0.0d0 + do 11 m=1,ndim+1 + sum=sum+p(m,n) +11 continue + psum(n)=sum +12 continue +2 ilo=1 + if (y(1).gt.y(2)) then + ihi=1 + inhi=2 + else + ihi=2 + inhi=1 + endif + do 13 i=1,ndim+1 + if(y(i).le.y(ilo)) ilo=i + if(y(i).gt.y(ihi)) then + inhi=ihi + ihi=i + else if(y(i).gt.y(inhi)) then + if(i.ne.ihi) inhi=i + endif +13 continue + rtol=2.0d0*dabs(y(ihi)-y(ilo))/ + & (dabs(y(ihi))+dabs(y(ilo))+TINY) + if (rtol.lt.ftol) then + swap=y(1) + y(1)=y(ilo) + y(ilo)=swap + do 14 n=1,ndim + swap=p(1,n) + p(1,n)=p(ilo,n) + p(ilo,n)=swap +14 continue + return + endif + +! check to see if the simplex is degenerate; if so, stop + degen=0.0d0 + do i=1,mp + do m=i+1,mp + do n=1,np + if(dabs(p(m,n)-p(i,n)).gt.degen)then + degen=dabs(p(m,n)-p(i,n)) + endif + enddo + enddo + enddo + if(degen.lt.ftol*ftol)then + swap=y(1) + y(1)=y(ilo) + y(ilo)=swap + do n=1,ndim + swap=p(1,n) + p(1,n)=p(ilo,n) + p(ilo,n)=swap + enddo + return + endif + if(iter.ge.ITMAX)return + iter=iter+2 + ytry=cpguamotry(p,y,psum,mp,np,ndim,funkmin,ihi,-1.0d0) + if (ytry.le.y(ilo))then + ytry=cpguamotry(p,y,psum,mp,np,ndim,funkmin,ihi,2.0d0) + else if (ytry.ge.y(inhi)) then + ysave=y(ihi) + ytry=cpguamotry(p,y,psum,mp,np,ndim,funkmin,ihi,0.5d0) + if (ytry.ge.ysave) then + do 16 i=1,ndim+1 + if(i.ne.ilo)then + do 15 j=1,ndim + psum(j)=0.5d0*(p(i,j)+p(ilo,j)) + p(i,j)=psum(j) +15 continue + call funkmin(ndim,psum,y(i)) + endif +16 continue + iter=iter+ndim + goto 1 + endif + else + iter=iter-1 + endif + goto 2 + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + DOUBLE PRECISION FUNCTION cpguamotry(p,y,psum, + & mp,np,ndim,funkmin,ihi,fac) + implicit none + INTEGER ihi,mp,ndim,np + double precision fac,p(mp,np),psum(np),y(mp) + EXTERNAL funkmin +CU USES funkmin + INTEGER j + double precision fac1,fac2,ytry,ptry(ndim) + fac1=(1.0d0-fac)/dble(ndim) + fac2=fac1-fac + do 11 j=1,ndim + ptry(j)=psum(j)*fac1-p(ihi,j)*fac2 +11 continue + call funkmin(ndim,ptry,ytry) + if (ytry.lt.y(ihi)) then + y(ihi)=ytry + do 12 j=1,ndim + psum(j)=psum(j)-p(ihi,j)+ptry(j) + p(ihi,j)=ptry(j) +12 continue + endif + cpguamotry=ytry + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + +c####################################################################### diff --git a/dataassim/math/optimization/cpodr_leastsquare.f b/dataassim/math/optimization/cpodr_leastsquare.f new file mode 100644 index 0000000..651d773 --- /dev/null +++ b/dataassim/math/optimization/cpodr_leastsquare.f @@ -0,0 +1,152 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine cpodr_leastsquare(nparams,FCN,params, + & npoints,xobs,yobs,iderivative,INFO) + implicit none +!if derivatives are provided, set iderivative to 1, otherwise set it to 0 +C ODRPACK ARGUMENT DEFINITIONS +C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE +C ==> N NUMBER OF OBSERVATIONS +C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C <==> BETA FUNCTION PARAMETERS +C ==> Y RESPONSE VARIABLE +C ==> LDY LEADING DIMENSION OF ARRAY Y +C ==> X EXPLANATORY VARIABLE +C ==> LDX LEADING DIMENSION OF ARRAY X +C ==> WE "EPSILON" WEIGHTS +C ==> LDWE LEADING DIMENSION OF ARRAY WE +C ==> LD2WE SECOND DIMENSION OF ARRAY WE +C ==> WD "DELTA" WEIGHTS +C ==> LDWD LEADING DIMENSION OF ARRAY WD +C ==> LD2WD SECOND DIMENSION OF ARRAY WD +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> JOB TASK TO BE PERFORMED +C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS +C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR +C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION +C ==> PARTOL PARAMETER CONVERGENCE CRITERION +C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS +C ==> IPRINT PRINT CONTROL +C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS +C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS +C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA +C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA +C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD +C ==> SCLB SCALE VALUES FOR PARAMETERS BETA +C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE +C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD +C <==> WORK DOUBLE PRECISION WORK VECTOR +C ==> LWORK DIMENSION OF VECTOR WORK +C <== IWORK INTEGER WORK VECTOR +C ==> LIWORK DIMENSION OF VECTOR IWORK +C <== INFO STOPPING CONDITION + +C PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER +C MAXN MAXIMUM NUMBER OF OBSERVATIONS +C MAXM MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C MAXNP MAXIMUM NUMBER OF FUNCTION PARAMETERS +C MAXNQ MAXIMUM NUMBER OF RESPONSES PER OBSERVATION + +C PARAMETER DECLARATIONS AND SPECIFICATIONS + INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ + PARAMETER (MAXM=25,MAXN=10000,MAXNP=30,MAXNQ=1, + + LDY=MAXN,LDX=MAXN, + + LDWE=1,LD2WE=1,LDWD=1,LD2WD=1, + + LDIFX=MAXN,LDSTPD=1,LDSCLD=1, + + LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + + + 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP + + + 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + + + 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ, + + LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM)) +C VARIABLE DECLARATIONS + INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N, + + NDIGIT,NP,NQ + INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK) + DOUBLE PRECISION PARTOL,SSTOL,TAUFAC + DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM), + + STPB(MAXNP),STPD(LDSTPD,MAXM), + + WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ), + + WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ) +c + integer npoints,i1,i2,i3,i4,i5,nparams,iderivative + double precision yobs(npoints),xobs(npoints), + & params(nparams) + + EXTERNAL FCN +c +C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS + WE(1,1,1) = -1.0D0 + WD(1,1,1) = -1.0D0 + IFIXB(1) = -1 +! IFIXX(1,1) = -1 + if(iderivative.eq.0)then +!no derivatives provided, using central finite difference + JOB=13 + else + JOB=43 + endif + NDIGIT = -1 + TAUFAC = -1.0D0 + SSTOL = -1.0D0 + PARTOL = -1.0D0 + MAXIT = -1 +! IPRINT = -1 + IPRINT=0 + LUNERR = -1 + LUNRPT = -1 + STPB(1) = -1.0D0 + STPD(1,1) = -1.0D0 + SCLB(1) = -1.0D0 + SCLD(1,1) = -1.0D0 + + MAXIT = 200000 +C SET UP ODRPACK REPORT FILES + LUNERR = 107 + LUNRPT = 108 +c + N=npoints + NP=nparams + M=1 + NQ=1 + do I=1,NP + BETA(I)=params(I) + enddo + do I=1,N + X(I,1)=xobs(I) + Y(I,1)=yobs(I) + enddo + NQ=1 + +C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX + DO 10 I=1,N + DO 15 J=1, M + IFIXX(I,J) = 1 +15 CONTINUE +10 CONTINUE +60 CALL DODRC(FCN, + + N,M,NP,NQ, + + BETA, + + Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, + + SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, + + SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + i1=mod(INFO,10) + i2=(mod(INFO,100)-i1)/10 + i3=(mod(INFO,1000)-mod(INFO,100))/100 + i4=(mod(INFO,10000)-mod(INFO,1000))/1000 + i5=(INFO-mod(INFO,10000))/10000 + do I=1,NP + params(I)=BETA(I) + enddo + return + END diff --git a/dataassim/math/optimization/cppowell.f b/dataassim/math/optimization/cppowell.f new file mode 100644 index 0000000..f74ee1f --- /dev/null +++ b/dataassim/math/optimization/cppowell.f @@ -0,0 +1,344 @@ + SUBROUTINE cppowell(p,xi,n,np,ftol,fret,pmin,pmax, + & funkmin,f1dim,ITMAX) +! fret must be given on entry + implicit none + INTEGER iter,n,np,NMAX,ITMAX + double precision fret,ftol,p(np),xi(np,np),TINY, + & pmin(np),pmax(np) + PARAMETER (NMAX=1000,TINY=1.0d-25) +CU USES funkmin,linmin + INTEGER i,ibig,j + double precision del,fp,fptt,t,pt(NMAX), + & ptt(NMAX),xit(NMAX) + external funkmin,f1dim + do 11 j=1,n + pt(j)=p(j) +11 continue + iter=0 +1 iter=iter+1 + fp=fret + ibig=0 + del=0.0d0 + do 13 i=1,n + do 12 j=1,n + xit(j)=xi(j,i) +12 continue + fptt=fret + call cplinmin(p,pmin,pmax,xit,n,f1dim,fret) + if(fptt-fret.gt.del)then + del=fptt-fret + ibig=i + endif +13 continue + if(2.0d0*(fp-fret).le.ftol*(dabs(fp)+dabs(fret))+TINY)return + if(iter.eq.ITMAX)then +! write(*,*)'powell exceeding maximum iterations' + return + endif + do 14 j=1,n + ptt(j)=2.0d0*p(j)-pt(j) + xit(j)=p(j)-pt(j) + pt(j)=p(j) +14 continue + call funkmin(n,ptt,fptt) + if(fptt.ge.fp)goto 1 + t=2.0d0*(fp-2.0d0*fret+fptt)*(fp-fret-del)**2- + & del*(fp-fptt)**2 + if(t.ge.0.0d0)goto 1 + call cplinmin(p,pmin,pmax,xit,n,f1dim,fret) + do 15 j=1,n + xi(j,ibig)=xi(j,n) + xi(j,n)=xit(j) +15 continue + goto 1 + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + SUBROUTINE cplinmin(p,pmin,pmax,xi,n,f1dim,fret) + implicit none + INTEGER n + double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n) + PARAMETER (TOL=1.0d-8) +CU USES brent,f1dim,mnbrak + INTEGER j,k,ierr + double precision ax,bx,fa,fb,fx,xmin,xx,cpbrent,xxmin,xxmax +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /cpf1com/ pcom,xicom,ncom + save /cpf1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + EXTERNAL f1dim + ncom=n + do j=1,n + pcom(j)=p(j) + xicom(j)=xi(j) + enddo + xxmax=1.0d+100 + xxmin=-1.0d+100 + do j=1,n + if(xicom(j).gt.1.0d-100)then +! if(xicom(j).gt.0.0d0)then + xx=(pmax(j)-pcom(j))/xicom(j) + ax=(pmin(j)-pcom(j))/xicom(j) + else + if(xicom(j).lt.(-1.0d-100))then +! if(xicom(j).lt.0.0d0)then + ax=(pmax(j)-pcom(j))/xicom(j) + xx=(pmin(j)-pcom(j))/xicom(j) + else + xx=1.0d+100 + ax=-1.0d+100 + endif + endif + if(xxmax.gt.xx)then + xxmax=xx + endif + if(xxmin.lt.ax)then + xxmin=ax + endif + enddo + ax=0.0d0 + if(dabs(xxmax).gt.dabs(xxmin))then + xx=0.25d0*xxmax + else + xx=0.25d0*xxmin + endif + call cpmnbrak(ax,xx,bx,fa,fx,fb, + & xxmin,xxmax,ierr,f1dim) + if(ierr.eq.0)then + fret=cpbrent(ax,xx,bx,f1dim,TOL,xmin) + else + xmin=xx + fret=fx + endif + do 12 j=1,n + xi(j)=xmin*xi(j) + p(j)=p(j)+xi(j) +12 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. +! + double precision function cpbrent(ax,bx,cx,f,tol,xmin) + implicit none + INTEGER ITMAX + double precision ax,bx,cx,tol,xmin,f,CGOLD,ZEPS + EXTERNAL f + PARAMETER (ITMAX=10000,CGOLD=.381966d0,ZEPS=1.0d-10) + INTEGER iter + double precision a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1, + & tol2,u,v,w,x,xm + a=dmin1(ax,cx) + b=dmax1(ax,cx) + v=bx + w=v + x=v + e=0.0d0 + fx=f(x) + fv=fx + fw=fx + do 11 iter=1,ITMAX + xm=0.5d0*(a+b) + tol1=tol*dabs(x)+ZEPS + tol2=2.0d0*tol1 + if(dabs(x-xm).le.(tol2-.5d0*(b-a))) goto 3 + if(dabs(e).gt.tol1) then + r=(x-w)*(fx-fv) + q=(x-v)*(fx-fw) + p=(x-v)*q-(x-w)*r + q=2.0d0*(q-r) + if(q.gt.0.0d0) p=-p + q=dabs(q) + etemp=e + e=d + if(dabs(p).ge.dabs(.5d0*q*etemp).or. + & p.le.q*(a-x).or.p.ge.q*(b-x))goto 1 + d=p/q + u=x+d + if(u-a.lt.tol2.or.b-u.lt.tol2)d=dsign(tol1,xm-x) + goto 2 + endif +1 if(x.ge.xm)then + e=a-x + else + e=b-x + endif + d=CGOLD*e +2 if(dabs(d).ge.tol1) then + u=x+d + else + u=x+dsign(tol1,d) + endif + fu=f(u) + if(fu.le.fx)then + if(u.ge.x)then + a=x + else + b=x + endif + v=w + fv=fw + w=x + fw=fx + x=u + fx=fu + else + if(u.lt.x) then + a=u + else + b=u + endif + if(fu.le.fw.or.w.eq.x)then + v=w + fv=fw + w=u + fw=fu + else if(fu.le.fv.or.v.eq.x.or.v.eq.w)then + v=u + fv=fu + endif + endif +11 continue +! write(*,*) 'brent exceed maximum iterations' +3 xmin=x + cpbrent=fx + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + +! double precision function f1dim(x) +! implicit none +! double precision x +!CU USES funkmin +! INTEGER j +!(((((((((((((((((((((((((((((((((((((((((((((((((((( +! integer NMAX,ncom +! parameter(NMAX=1000) +! double precision pcom(NMAX),xicom(NMAX) +! COMMON /cpf1com/ pcom,xicom,ncom +! save /cpf1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) +! double precision xt(NMAX) +! do 11 j=1,ncom +! xt(j)=pcom(j)+x*xicom(j) +!11 continue +! call funkmin(ncom,xt,f1dim) +! return +! END +!C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + SUBROUTINE cpmnbrak(ax,bx,cx,fa,fb,fc,xxmin,xxmax, + & ierr,func) + implicit none + double precision ax,bx,cx,fa,fb,fc, + & func,GOLD,GLIMIT,TINY + EXTERNAL func + PARAMETER(GOLD=1.618034d0,GLIMIT=100.0d0,TINY=1.0d-20) + double precision dum,fu,q,r,u,ulim,xxmin,xxmax + integer ierr + ierr=0 + fa=func(ax) + fb=func(bx) + if(fb.gt.fa)then + dum=ax + ax=bx + bx=dum + dum=fb + fb=fa + fa=dum + endif + if(fa.eq.fb)then + cx=(bx+ax)/2.0d0 + fc=func(cx) + if(fc.le.fa)return + endif + cx=bx+GOLD*(bx-ax) + if(cx.le.xxmin)then + cx=0.5d0*(dmin1(ax,bx)+xxmin) + endif + if(cx.ge.xxmax)then + cx=0.5d0*(dmax1(ax,bx)+xxmax) + endif + fc=func(cx) +1 if(fb.ge.fc)then + r=(bx-ax)*(fb-fc) + q=(bx-cx)*(fb-fa) + u=bx-((bx-cx)*q-(bx-ax)*r)/ + & (2.0d0*dsign(dmax1(dabs(q-r),TINY),q-r)) + ulim=bx+GLIMIT*(cx-bx) + if(ulim.ge.xxmax)then + ulim=xxmax-tiny + endif + if(ulim.le.xxmin)then + ulim=xxmin+tiny + endif + if((bx-u)*(u-cx).gt.0.0d0)then + fu=func(u) + if(fu.lt.fc)then + ax=bx + fa=fb + bx=u + fb=fu + return + elseif(fu.gt.fb)then + cx=u + fc=fu + return + endif + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fu=func(u) + elseif((cx-u)*(u-ulim).gt.0.0d0)then + fu=func(u) + if(fu.lt.fc)then + bx=cx + cx=u + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fb=fc + fc=fu + fu=func(u) + endif + else if((u-ulim)*(ulim-cx).ge.0.0d0)then + u=ulim + fu=func(u) + else + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fu=func(u) + endif + ax=bx + bx=cx + cx=u + fa=fb + fb=fc + fc=fu + r=dmin1(dabs(ax-bx),dabs(ax-cx)) + r=dmin1(r,dabs(bx-cx)) + if(r.lt.tiny)then +! bracketing failed + ierr=1 + return + endif + goto 1 + endif + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. diff --git a/dataassim/math/optimization/d_odr.f b/dataassim/math/optimization/d_odr.f new file mode 100644 index 0000000..5fab496 --- /dev/null +++ b/dataassim/math/optimization/d_odr.f @@ -0,0 +1,13439 @@ +*DMPREC + DOUBLE PRECISION FUNCTION DMPREC() +C***BEGIN PROLOGUE DPREC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE DETERMINE MACHINE PRECISION FOR TARGET MACHINE AND COMPILER +C ASSUMING FLOATING-POINT NUMBERS ARE REPRESENTED IN THE +C T-DIGIT, BASE-B FORM +C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, AND +C 0 .LT. X(1). +C TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE, +C EITHER +C ACTIVATE THE DESIRED SET OF DATA STATEMENTS BY +C REMOVING THE C FROM COLUMN 1 +C OR +C SET B, TD AND TS USING I1MACH BY ACTIVATING +C THE DECLARATION STATEMENTS FOR I1MACH +C AND THE STATEMENTS PRECEEDING THE FIRST +C EXECUTABLE STATEMENT BELOW. +C***END PROLOGUE DPREC + +C...LOCAL SCALARS + DOUBLE PRECISION + + B + INTEGER + + TD,TS + +C...EXTERNAL FUNCTIONS +C INTEGER +C + I1MACH +C EXTERNAL +C + I1MACH + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) + +C DOUBLE PRECISION B +C THE BASE OF THE TARGET MACHINE. +C (MAY BE DEFINED USING I1MACH(10).) +C INTEGER TD +C THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION. +C (MAY BE DEFINED USING I1MACH(14).) +C INTEGER TS +C THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION. +C (MAY BE DEFINED USING I1MACH(11).) + + +C MACHINE CONSTANTS FOR COMPUTERS FOLLOWING IEEE ARITHMETIC STANDARD +C (E.G., MOTOROLA 68000 BASED MACHINES SUCH AS SUN AND SPARC +C WORKSTATIONS, AND AT&T PC 7300; AND 8087 BASED MICROS SUCH AS THE +C IBM PC AND THE AT&T 6300). +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 53 / + +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 60 / + +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C THE BURROUGHS 6700/7700 SYSTEMS +C DATA B / 8 / +C DATA TS / 13 / +C DATA TD / 26 / + +C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN5 COMPILER) +C THE CYBER 170/180 SERIES UNDER NOS +C DATA B / 2 / +C DATA TS / 48 / +C DATA TD / 96 / + +C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN COMPILER) +C THE CYBER 170/180 SERIES UNDER NOS/VE +C THE CYBER 200 SERIES +C DATA B / 2 / +C DATA TS / 47 / +C DATA TD / 94 / + +C MACHINE CONSTANTS FOR THE CRAY +C DATA B / 2 / +C DATA TS / 47 / +C DATA TD / 94 / + +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + +C MACHINE CONSTANTS FOR THE HARRIS COMPUTER +C DATA B / 2 / +C DATA TS / 23 / +C DATA TD / 38 / + +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 +C THE HONEYWELL 600/6000 SERIES +C DATA B / 2 / +C DATA TS / 27 / +C DATA TD / 63 / + +C MACHINE CONSTANTS FOR THE HP 2100 +C (3 WORD DOUBLE PRECISION OPTION WITH FTN4) +C DATA B / 2 / +C DATA TS / 23 / +C DATA TD / 39 / + +C MACHINE CONSTANTS FOR THE HP 2100 +C (4 WORD DOUBLE PRECISION OPTION WITH FTN4) +C DATA B / 2 / +C DATA TS / 23 / +C DATA TD / 55 / + +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + +C MACHINE CONSTANTS FOR THE IBM PC +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 53 / + +C MACHINE CONSTANTS FOR THE INTERDATA (PERKIN ELMER) 7/32 +C INTERDATA (PERKIN ELMER) 8/32 +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). +C DATA B / 2 / +C DATA TS / 27 / +C DATA TD / 54 / + +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). +C DATA B / 2 / +C DATA TS / 27 / +C DATA TD / 62 / + +C MACHINE CONSTANTS FOR THE PDP-11 SYSTEM +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 56 / + +C MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230 +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + +C MACHINE CONSTANTS FOR THE PRIME 850 AND PRIME 4050 +C DATA B / 2 / +C DATA TS / 23 / +C DATA TD / 47 / + +C MACHINE CONSTANTS FOR THE SEL SYSTEMS 85/86 +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + +C MACHINE CONSTANTS FOR SUN AND SPARC WORKSTATIONS +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 53 / + +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES +C DATA B / 2 / +C DATA TS / 27 / +C DATA TD / 60 / + +C MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS COMPILER +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 56 / + +C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITHOUT G_FLOATING +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 56 / + +C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITH G_FLOATING +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 53 / + +C MACHINE CONSTANTS FOR THE XEROX SIGMA 5/7/9 +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + + +C***FIRST EXECUTABLE STATEMENT DMPREC + + +C B = I1MACH(10) +C TS = I1MACH(11) +C TD = I1MACH(14) + + DMPREC = B ** (1-TD) + + RETURN + + END + +*DASUM + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +C***BEGIN PROLOGUE DASUM +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A3A +C***KEYWORDS ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM, +C VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE SUM OF MAGNITUDES OF D.P. VECTOR COMPONENTS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DASUM DOUBLE PRECISION RESULT (ZERO IF N .LE. 0) +C RETURNS SUM OF MAGNITUDES OF DOUBLE PRECISION DX. +C DASUM = SUM FROM 0 TO N-1 OF DABS(DX(1+I*INCX)) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DASUM + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + INTEGER + + I,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,MOD + + +C***FIRST EXECUTABLE STATEMENT DASUM + + + DASUM = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + NS = N*INCX + DO 10 I=1,NS,INCX + DASUM = DASUM + DABS(DX(I)) + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. + + 20 M = MOD(N,6) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DASUM = DASUM + DABS(DX(I)) + 30 CONTINUE + IF( N .LT. 6 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) + 1 + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) + 50 CONTINUE + RETURN + END +*DAXPY + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DAXPY +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A7 +C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,TRIAD,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P COMPUTATION Y = A*X + Y +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DA DOUBLE PRECISION SCALAR MULTIPLIER +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DY DOUBLE PRECISION RESULT (UNCHANGED IF N .LE. 0) +C OVERWRITE DOUBLE PRECISION DY WITH DOUBLE PRECISION DA*DX + DY. +C FOR I = 0 TO N-1, REPLACE DY(LY+I*INCY) WITH DA*DX(LX+I*INCX) + +C DY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N +C AND LY IS DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DAXPY + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DAXPY + + + IF(N.LE.0.OR.DA.EQ.0.D0) RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. + + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I + 1) = DY(I + 1) + DA*DX(I + 1) + DY(I + 2) = DY(I + 2) + DA*DX(I + 2) + DY(I + 3) = DY(I + 3) + DA*DX(I + 3) + 50 CONTINUE + RETURN + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DY(I) = DA*DX(I) + DY(I) + 70 CONTINUE + RETURN + END +*DCHEX + SUBROUTINE DCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB) +C***BEGIN PROLOGUE DCHEX +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D7B +C***KEYWORDS CHOLESKY DECOMPOSITION,DOUBLE PRECISION,EXCHANGE, +C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE UPDATES THE CHOLESKY FACTORIZATION A=TRANS(R)*R OF A +C POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL +C PERMUTATIONS OF THE FORM TRANS(E)*A*E WHERE E IS A +C PERMUTATION MATRIX. +C***DESCRIPTION +C DCHEX UPDATES THE CHOLESKY FACTORIZATION +C A = TRANS(R)*R +C OF A POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL +C PERMUTATIONS OF THE FORM +C TRANS(E)*A*E +C WHERE E IS A PERMUTATION MATRIX. SPECIFICALLY, GIVEN +C AN UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX +C E (WHICH IS SPECIFIED BY K, L, AND JOB), DCHEX DETERMINES +C AN ORTHOGONAL MATRIX U SUCH THAT +C U*R*E = RR, +C WHERE RR IS UPPER TRIANGULAR. AT THE USERS OPTION, THE +C TRANSFORMATION U WILL BE MULTIPLIED INTO THE ARRAY Z. +C IF A = TRANS(X)*X, SO THAT R IS THE TRIANGULAR PART OF THE +C QR FACTORIZATION OF X, THEN RR IS THE TRIANGULAR PART OF THE +C QR FACTORIZATION OF X*E, I.E. X WITH ITS COLUMNS PERMUTED. +C FOR A LESS TERSE DESCRIPTION OF WHAT DCHEX DOES AND HOW +C IT MAY BE APPLIED, SEE THE LINPACK GUIDE. +C THE MATRIX Q IS DETERMINED AS THE PRODUCT U(L-K)*...*U(1) +C OF PLANE ROTATIONS OF THE FORM +C ( C(I) S(I) ) +C ( ) , +C ( -S(I) C(I) ) +C WHERE C(I) IS DOUBLE PRECISION. THE ROWS THESE ROTATIONS OPERATE +C ON ARE DESCRIBED BELOW. +C THERE ARE TWO TYPES OF PERMUTATIONS, WHICH ARE DETERMINED +C BY THE VALUE OF JOB. +C 1. RIGHT CIRCULAR SHIFT (JOB = 1). +C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER. +C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. +C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) +C ACTS IN THE (L-I,L-I+1)-PLANE. +C 2. LEFT CIRCULAR SHIFT (JOB = 2). +C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER +C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. +C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) +C ACTS IN THE (K+I-1,K+I)-PLANE. +C ON ENTRY +C R DOUBLE PRECISION(LDR,P), WHERE LDR .GE. P. +C R CONTAINS THE UPPER TRIANGULAR FACTOR +C THAT IS TO BE UPDATED. ELEMENTS OF R +C BELOW THE DIAGONAL ARE NOT REFERENCED. +C LDR INTEGER. +C LDR IS THE LEADING DIMENSION OF THE ARRAY R. +C P INTEGER. +C P IS THE ORDER OF THE MATRIX R. +C K INTEGER. +C K IS THE FIRST COLUMN TO BE PERMUTED. +C L INTEGER. +C L IS THE LAST COLUMN TO BE PERMUTED. +C L MUST BE STRICTLY GREATER THAN K. +C Z DOUBLE PRECISION(LDZ,N)Z), WHERE LDZ .GE. P. +C Z IS AN ARRAY OF NZ P-VECTORS INTO WHICH THE +C TRANSFORMATION U IS MULTIPLIED. Z IS +C NOT REFERENCED IF NZ = 0. +C LDZ INTEGER. +C LDZ IS THE LEADING DIMENSION OF THE ARRAY Z. +C NZ INTEGER. +C NZ IS THE NUMBER OF COLUMNS OF THE MATRIX Z. +C JOB INTEGER. +C JOB DETERMINES THE TYPE OF PERMUTATION. +C JOB = 1 RIGHT CIRCULAR SHIFT. +C JOB = 2 LEFT CIRCULAR SHIFT. +C ON RETURN +C R CONTAINS THE UPDATED FACTOR. +C Z CONTAINS THE UPDATED MATRIX Z. +C C DOUBLE PRECISION(P). +C C CONTAINS THE COSINES OF THE TRANSFORMING ROTATIONS. +C S DOUBLE PRECISION(P). +C S CONTAINS THE SINES OF THE TRANSFORMING ROTATIONS. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DROTG +C***END PROLOGUE DCHEX + +C...SCALAR ARGUMENTS + INTEGER + + JOB,K,L,LDR,LDZ,NZ,P + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + C(*),R(LDR,*),S(*),Z(LDZ,*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + T,T1 + INTEGER + + I,II,IL,IU,J,JJ,KM1,KP1,LM1,LMK + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DROTG + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MAX0,MIN0 + + +C***FIRST EXECUTABLE STATEMENT DCHEX + + + KM1 = K - 1 + KP1 = K + 1 + LMK = L - K + LM1 = L - 1 + +C PERFORM THE APPROPRIATE TASK. + + GO TO (10,130), JOB + +C RIGHT CIRCULAR SHIFT. + + 10 CONTINUE + +C REORDER THE COLUMNS. + + DO 20 I = 1, L + II = L - I + 1 + S(I) = R(II,L) + 20 CONTINUE + DO 40 JJ = K, LM1 + J = LM1 - JJ + K + DO 30 I = 1, J + R(I,J+1) = R(I,J) + 30 CONTINUE + R(J+1,J+1) = 0.0D0 + 40 CONTINUE + IF (K .EQ. 1) GO TO 60 + DO 50 I = 1, KM1 + II = L - I + 1 + R(I,K) = S(II) + 50 CONTINUE + 60 CONTINUE + +C CALCULATE THE ROTATIONS. + + T = S(1) + DO 70 I = 1, LMK + T1 = S(I) + CALL DROTG(S(I+1),T,C(I),T1) + S(I) = T1 + T = S(I+1) + 70 CONTINUE + R(K,K) = T + DO 90 J = KP1, P + IL = MAX0(1,L-J+1) + DO 80 II = IL, LMK + I = L - II + T = C(II)*R(I,J) + S(II)*R(I+1,J) + R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) + R(I,J) = T + 80 CONTINUE + 90 CONTINUE + +C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. + + IF (NZ .LT. 1) GO TO 120 + DO 110 J = 1, NZ + DO 100 II = 1, LMK + I = L - II + T = C(II)*Z(I,J) + S(II)*Z(I+1,J) + Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) + Z(I,J) = T + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + GO TO 260 + +C LEFT CIRCULAR SHIFT + + 130 CONTINUE + +C REORDER THE COLUMNS + + DO 140 I = 1, K + II = LMK + I + S(II) = R(I,K) + 140 CONTINUE + DO 160 J = K, LM1 + DO 150 I = 1, J + R(I,J) = R(I,J+1) + 150 CONTINUE + JJ = J - KM1 + S(JJ) = R(J+1,J+1) + 160 CONTINUE + DO 170 I = 1, K + II = LMK + I + R(I,L) = S(II) + 170 CONTINUE + DO 180 I = KP1, L + R(I,L) = 0.0D0 + 180 CONTINUE + +C REDUCTION LOOP. + + DO 220 J = K, P + IF (J .EQ. K) GO TO 200 + +C APPLY THE ROTATIONS. + + IU = MIN0(J-1,L-1) + DO 190 I = K, IU + II = I - K + 1 + T = C(II)*R(I,J) + S(II)*R(I+1,J) + R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) + R(I,J) = T + 190 CONTINUE + 200 CONTINUE + IF (J .GE. L) GO TO 210 + JJ = J - K + 1 + T = S(JJ) + CALL DROTG(R(J,J),T,C(JJ),S(JJ)) + 210 CONTINUE + 220 CONTINUE + +C APPLY THE ROTATIONS TO Z. + + IF (NZ .LT. 1) GO TO 250 + DO 240 J = 1, NZ + DO 230 I = K, LM1 + II = I - KM1 + T = C(II)*Z(I,J) + S(II)*Z(I+1,J) + Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) + Z(I,J) = T + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN + END +*DCOPY + SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DCOPY +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A5 +C***KEYWORDS BLAS,COPY,DOUBLE PRECISION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. VECTOR COPY Y = X +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DY COPY OF VECTOR DX (UNCHANGED IF N .LE. 0) +C COPY DOUBLE PRECISION DX TO DOUBLE PRECISION DY. +C FOR I = 0 TO N-1, COPY DX(LX+I*INCX) TO DY(LY+I*INCY), +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DCOPY + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DCOPY + + + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. + + 20 M = MOD(N,7) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DX(I) + 30 CONTINUE + IF( N .LT. 7 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,7 + DY(I) = DX(I) + DY(I + 1) = DX(I + 1) + DY(I + 2) = DX(I + 2) + DY(I + 3) = DX(I + 3) + DY(I + 4) = DX(I + 4) + DY(I + 5) = DX(I + 5) + DY(I + 6) = DX(I + 6) + 50 CONTINUE + RETURN + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + 60 CONTINUE + NS=N*INCX + DO 70 I=1,NS,INCX + DY(I) = DX(I) + 70 CONTINUE + RETURN + END +*DDOT + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DDOT +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A4 +C***KEYWORDS BLAS,DOUBLE PRECISION,INNER PRODUCT,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. INNER PRODUCT OF D.P. VECTORS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DDOT DOUBLE PRECISION DOT PRODUCT (ZERO IF N .LE. 0) +C RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. +C DDOT = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DDOT + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DDOT + + + DDOT = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DDOT = DDOT + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1. + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. + + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DDOT = DDOT + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + 1 DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + RETURN + +C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. + + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DDOT = DDOT + DX(I)*DY(I) + 70 CONTINUE + RETURN + END +*DNRM2 + DOUBLE PRECISION FUNCTION DNRM2(N,DX,INCX) +C***BEGIN PROLOGUE DNRM2 +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A3B +C***KEYWORDS BLAS,DOUBLE PRECISION,EUCLIDEAN,L2,LENGTH,LINEAR ALGEBRA, +C NORM,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE EUCLIDEAN LENGTH (L2 NORM) OF D.P. VECTOR +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DNRM2 DOUBLE PRECISION RESULT (ZERO IF N .LE. 0) +C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE +C INCREMENT INCX . +C IF N .LE. 0 RETURN WITH RESULT = 0. +C IF N .GE. 1 THEN INCX MUST BE .GE. 1 +C C.L. LAWSON, 1978 JAN 08 +C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE +C HOPEFULLY APPLICABLE TO ALL MACHINES. +C CUTLO = MAXIMUM OF DSQRT(U/EPS) OVER ALL KNOWN MACHINES. +C CUTHI = MINIMUM OF DSQRT(V) OVER ALL KNOWN MACHINES. +C WHERE +C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. +C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) +C V = LARGEST NO. (OVERFLOW LIMIT) +C BRIEF OUTLINE OF ALGORITHM.. +C PHASE 1 SCANS ZERO COMPONENTS. +C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO +C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO +C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M +C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. + +C VALUES FOR CUTLO AND CUTHI.. +C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER +C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. +C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE +C UNIVAC AND DEC AT 2**(-103) +C THUS CUTLO = 2**(-51) = 4.44089E-16 +C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. +C THUS CUTHI = 2**(63.5) = 1.30438E19 +C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. +C THUS CUTLO = 2**(-33.5) = 8.23181D-11 +C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 +C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / +C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DNRM2 + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + CUTHI,CUTLO,HITEST,ONE,SUM,XMAX,ZERO + INTEGER + + I,J,NEXT,NN + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DSQRT,FLOAT + +C...DATA STATEMENTS + DATA + + ZERO,ONE/0.0D0,1.0D0/ + DATA + + CUTLO,CUTHI/8.232D-11,1.304D19/ + + +C***FIRST EXECUTABLE STATEMENT DNRM2 + + + XMAX = ZERO + IF(N .GT. 0) GO TO 10 + DNRM2 = ZERO + GO TO 300 + + 10 ASSIGN 30 TO NEXT + SUM = ZERO + NN = N * INCX +C BEGIN MAIN LOOP + I = 1 +C 20 GO TO NEXT,(30, 50, 70, 110) + 20 GO TO NEXT + 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + ASSIGN 50 TO NEXT + XMAX = ZERO + +C PHASE 1. SUM IS ZERO + + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + +C PREPARE FOR PHASE 2. + ASSIGN 70 TO NEXT + GO TO 105 + +C PREPARE FOR PHASE 4. + + 100 I = J + ASSIGN 110 TO NEXT + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = DABS(DX(I)) + GO TO 115 + +C PHASE 2. SUM IS SMALL. +C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. + + 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 + +C COMMON CODE FOR PHASES 2 AND 4. +C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. + + 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = DABS(DX(I)) + GO TO 200 + + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 + + +C PREPARE FOR PHASE 3. + + 75 SUM = (SUM * XMAX) * XMAX + + +C FOR REAL OR D.P. SET HITEST = CUTHI/N +C FOR COMPLEX SET HITEST = CUTHI/(2*N) + + 85 HITEST = CUTHI/FLOAT( N ) + +C PHASE 3. SUM IS MID-RANGE. NO SCALING. + + DO 95 J =I,NN,INCX + IF(DABS(DX(J)) .GE. HITEST) GO TO 100 + 95 SUM = SUM + DX(J)**2 + DNRM2 = DSQRT( SUM ) + GO TO 300 + + 200 CONTINUE + I = I + INCX + IF ( I .LE. NN ) GO TO 20 + +C END OF MAIN LOOP. + +C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. + + DNRM2 = XMAX * DSQRT(SUM) + 300 CONTINUE + RETURN + END +*DPODI + SUBROUTINE DPODI(A,LDA,N,DET,JOB) +C***BEGIN PROLOGUE DPODI +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2B1B,D3B1B +C***KEYWORDS DETERMINANT,DOUBLE PRECISION,FACTOR,INVERSE, +C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN DOUBLE +C PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE ABSTRACT) +C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. +C***DESCRIPTION +C DPODI COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN +C DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE BELOW) +C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. +C ON ENTRY +C A DOUBLE PRECISION(LDA, N) +C THE OUTPUT A FROM DPOCO OR DPOFA +C OR THE OUTPUT X FROM DQRDC. +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY A . +C N INTEGER +C THE ORDER OF THE MATRIX A . +C JOB INTEGER +C = 11 BOTH DETERMINANT AND INVERSE. +C = 01 INVERSE ONLY. +C = 10 DETERMINANT ONLY. +C ON RETURN +C A IF DPOCO OR DPOFA WAS USED TO FACTOR A , THEN +C DPODI PRODUCES THE UPPER HALF OF INVERSE(A) . +C IF DQRDC WAS USED TO DECOMPOSE X , THEN +C DPODI PRODUCES THE UPPER HALF OF INVERSE(TRANS(X)*X) +C WHERE TRANS(X) IS THE TRANSPOSE. +C ELEMENTS OF A BELOW THE DIAGONAL ARE UNCHANGED. +C IF THE UNITS DIGIT OF JOB IS ZERO, A IS UNCHANGED. +C DET DOUBLE PRECISION(2) +C DETERMINANT OF A OR OF TRANS(X)*X IF REQUESTED. +C OTHERWISE NOT REFERENCED. +C DETERMINANT = DET(1) * 10.0**DET(2) +C WITH 1.0 .LE. DET(1) .LT. 10.0 +C OR DET(1) .EQ. 0.0 . +C ERROR CONDITION +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 DPOCO OR DPOFA HAS SET INFO .EQ. 0 . +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DSCAL +C***END PROLOGUE DPODI + +C...SCALAR ARGUMENTS + INTEGER JOB,LDA,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION A(LDA,*),DET(*) + +C...LOCAL SCALARS + DOUBLE PRECISION S,T + INTEGER I,J,JM1,K,KP1 + +C...EXTERNAL SUBROUTINES + EXTERNAL DAXPY,DSCAL + +C...INTRINSIC FUNCTIONS + INTRINSIC MOD + + +C***FIRST EXECUTABLE STATEMENT DPODI + + + IF (JOB/10 .EQ. 0) GO TO 70 + DET(1) = 1.0D0 + DET(2) = 0.0D0 + S = 10.0D0 + DO 50 I = 1, N + DET(1) = A(I,I)**2*DET(1) +C ...EXIT + IF (DET(1) .EQ. 0.0D0) GO TO 60 + 10 IF (DET(1) .GE. 1.0D0) GO TO 20 + DET(1) = S*DET(1) + DET(2) = DET(2) - 1.0D0 + GO TO 10 + 20 CONTINUE + 30 IF (DET(1) .LT. S) GO TO 40 + DET(1) = DET(1)/S + DET(2) = DET(2) + 1.0D0 + GO TO 30 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + +C COMPUTE INVERSE(R) + + IF (MOD(JOB,10) .EQ. 0) GO TO 140 + 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 FORM INVERSE(R) * TRANS(INVERSE(R)) + + DO 130 J = 1, N + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 120 + DO 110 K = 1, JM1 + T = A(K,J) + CALL DAXPY(K,T,A(1,J),1,A(1,K),1) + 110 CONTINUE + 120 CONTINUE + T = A(J,J) + CALL DSCAL(J,T,A(1,J),1) + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DQRDC + SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB) +C***BEGIN PROLOGUE DQRDC +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D5 +C***KEYWORDS DECOMPOSITION,DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK, +C MATRIX,ORTHOGONAL TRIANGULAR +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR FACTORI- +C ZATION OF N BY P MATRIX X. COLUMN PIVOTING IS OPTIONAL. +C***DESCRIPTION +C DQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR +C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING +C BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE +C PERFORMED AT THE USER'S OPTION. +C ON ENTRY +C X DOUBLE PRECISION(LDX,P), WHERE LDX .GE. N. +C X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE +C COMPUTED. +C LDX INTEGER. +C LDX IS THE LEADING DIMENSION OF THE ARRAY X. +C N INTEGER. +C N IS THE NUMBER OF ROWS OF THE MATRIX X. +C P INTEGER. +C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. +C JPVT INTEGER(P). +C JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION +C OF THE PIVOT COLUMNS. THE K-TH COLUMN X(K) OF X +C IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE +C VALUE OF JPVT(K). +C IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL +C COLUMN. +C IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN. +C IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN. +C BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS +C ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL +C COLUMNS TO THE END. BOTH INITIAL AND FINAL COLUMNS +C ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY +C FREE COLUMNS ARE MOVED. AT THE K-TH STAGE OF THE +C REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN +C IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST +C REDUCED NORM. JPVT IS NOT REFERENCED IF +C JOB .EQ. 0. +C WORK DOUBLE PRECISION(P). +C WORK IS A WORK ARRAY. WORK IS NOT REFERENCED IF +C JOB .EQ. 0. +C JOB INTEGER. +C JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING. +C IF JOB .EQ. 0, NO PIVOTING IS DONE. +C IF JOB .NE. 0, PIVOTING IS DONE. +C ON RETURN +C X X CONTAINS IN ITS UPPER TRIANGLE THE UPPER +C TRIANGULAR MATRIX R OF THE QR FACTORIZATION. +C BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM +C WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION +C CAN BE RECOVERED. NOTE THAT IF PIVOTING HAS +C BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT +C OF THE ORIGINAL MATRIX X BUT THAT OF X +C WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT. +C QRAUX DOUBLE PRECISION(P). +C QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER +C THE ORTHOGONAL PART OF THE DECOMPOSITION. +C JPVT JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE +C ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO +C THE K-TH COLUMN, IF PIVOTING WAS REQUESTED. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DDOT,DNRM2,DSCAL,DSWAP +C***END PROLOGUE DQRDC + +C...SCALAR ARGUMENTS + INTEGER + + JOB,LDX,N,P + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + QRAUX(*),WORK(*),X(LDX,*) + INTEGER + + JPVT(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + MAXNRM,NRMXL,T,TT + INTEGER + + J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU + LOGICAL + + NEGJ,SWAPJ + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT,DNRM2 + EXTERNAL + + DDOT,DNRM2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY,DSCAL,DSWAP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DMAX1,DSIGN,DSQRT,MIN0 + + +C***FIRST EXECUTABLE STATEMENT DQRDC + + + PL = 1 + PU = 0 + IF (JOB .EQ. 0) GO TO 60 + +C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS +C ACCORDING TO JPVT. + + DO 20 J = 1, P + SWAPJ = JPVT(J) .GT. 0 + NEGJ = JPVT(J) .LT. 0 + JPVT(J) = J + IF (NEGJ) JPVT(J) = -J + IF (.NOT.SWAPJ) GO TO 10 + IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1) + JPVT(J) = JPVT(PL) + JPVT(PL) = J + PL = PL + 1 + 10 CONTINUE + 20 CONTINUE + PU = P + DO 50 JJ = 1, P + J = P - JJ + 1 + IF (JPVT(J) .GE. 0) GO TO 40 + JPVT(J) = -JPVT(J) + IF (J .EQ. PU) GO TO 30 + CALL DSWAP(N,X(1,PU),1,X(1,J),1) + JP = JPVT(PU) + JPVT(PU) = JPVT(J) + JPVT(J) = JP + 30 CONTINUE + PU = PU - 1 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + +C COMPUTE THE NORMS OF THE FREE COLUMNS. + + IF (PU .LT. PL) GO TO 80 + DO 70 J = PL, PU + QRAUX(J) = DNRM2(N,X(1,J),1) + WORK(J) = QRAUX(J) + 70 CONTINUE + 80 CONTINUE + +C PERFORM THE HOUSEHOLDER REDUCTION OF X. + + LUP = MIN0(N,P) + DO 200 L = 1, LUP + IF (L .LT. PL .OR. L .GE. PU) GO TO 120 + +C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT +C INTO THE PIVOT POSITION. + + MAXNRM = 0.0D0 + MAXJ = L + DO 100 J = L, PU + IF (QRAUX(J) .LE. MAXNRM) GO TO 90 + MAXNRM = QRAUX(J) + MAXJ = J + 90 CONTINUE + 100 CONTINUE + IF (MAXJ .EQ. L) GO TO 110 + CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1) + QRAUX(MAXJ) = QRAUX(L) + WORK(MAXJ) = WORK(L) + JP = JPVT(MAXJ) + JPVT(MAXJ) = JPVT(L) + JPVT(L) = JP + 110 CONTINUE + 120 CONTINUE + QRAUX(L) = 0.0D0 + IF (L .EQ. N) GO TO 190 + +C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. + + NRMXL = DNRM2(N-L+1,X(L,L),1) + IF (NRMXL .EQ. 0.0D0) GO TO 180 + IF (X(L,L) .NE. 0.0D0) NRMXL = DSIGN(NRMXL,X(L,L)) + CALL DSCAL(N-L+1,1.0D0/NRMXL,X(L,L),1) + X(L,L) = 1.0D0 + X(L,L) + +C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, +C UPDATING THE NORMS. + + LP1 = L + 1 + IF (P .LT. LP1) GO TO 170 + DO 160 J = LP1, P + T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) + CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1) + IF (J .LT. PL .OR. J .GT. PU) GO TO 150 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 150 + TT = 1.0D0 - (DABS(X(L,J))/QRAUX(J))**2 + TT = DMAX1(TT,0.0D0) + T = TT + TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2 + IF (TT .EQ. 1.0D0) GO TO 130 + QRAUX(J) = QRAUX(J)*DSQRT(T) + GO TO 140 + 130 CONTINUE + QRAUX(J) = DNRM2(N-L,X(L+1,J),1) + WORK(J) = QRAUX(J) + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + +C SAVE THE TRANSFORMATION. + + QRAUX(L) = X(L,L) + X(L,L) = -NRMXL + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + RETURN + END +*DQRSL + SUBROUTINE DQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) +C***BEGIN PROLOGUE DQRSL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D9,D2A1 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX, +C ORTHOGONAL TRIANGULAR,SOLVE +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE +C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. +C***DESCRIPTION +C DQRSL APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE +C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. +C FOR K .LE. MIN(N,P), LET XK BE THE MATRIX +C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) +C FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL +C N X P MATRIX X THAT WAS INPUT TO DQRDC (IF NO PIVOTING WAS +C DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR +C ORIGINAL ORDER). DQRDC PRODUCES A FACTORED ORTHOGONAL MATRIX Q +C AND AN UPPER TRIANGULAR MATRIX R SUCH THAT +C XK = Q * (R) +C (0) +C THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS +C X AND QRAUX. +C ON ENTRY +C X DOUBLE PRECISION(LDX,P). +C X CONTAINS THE OUTPUT OF DQRDC. +C LDX INTEGER. +C LDX IS THE LEADING DIMENSION OF THE ARRAY X. +C N INTEGER. +C N IS THE NUMBER OF ROWS OF THE MATRIX XK. IT MUST +C HAVE THE SAME VALUE AS N IN DQRDC. +C K INTEGER. +C K IS THE NUMBER OF COLUMNS OF THE MATRIX XK. K +C MUST NOT BE GREATER THAN MIN(N,P), WHERE P IS THE +C SAME AS IN THE CALLING SEQUENCE TO DQRDC. +C QRAUX DOUBLE PRECISION(P). +C QRAUX CONTAINS THE AUXILIARY OUTPUT FROM DQRDC. +C Y DOUBLE PRECISION(N) +C Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED +C BY DQRSL. +C JOB INTEGER. +C JOB SPECIFIES WHAT IS TO BE COMPUTED. JOB HAS +C THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING +C MEANING. +C IF A .NE. 0, COMPUTE QY. +C IF B,C,D, OR E .NE. 0, COMPUTE QTY. +C IF C .NE. 0, COMPUTE B. +C IF D .NE. 0, COMPUTE RSD. +C IF E .NE. 0, COMPUTE XB. +C NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB +C AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR +C WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING +C SEQUENCE. +C ON RETURN +C QY DOUBLE PRECISION(N). +C QY CONTAINS Q*Y, IF ITS COMPUTATION HAS BEEN +C REQUESTED. +C QTY DOUBLE PRECISION(N). +C QTY CONTAINS TRANS(Q)*Y, IF ITS COMPUTATION HAS +C BEEN REQUESTED. HERE TRANS(Q) IS THE +C TRANSPOSE OF THE MATRIX Q. +C B DOUBLE PRECISION(K) +C B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM +C MINIMIZE NORM2(Y - XK*B), +C IF ITS COMPUTATION HAS BEEN REQUESTED. (NOTE THAT +C IF PIVOTING WAS REQUESTED IN DQRDC, THE J-TH +C COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J) +C OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO DQRDC.) +C RSD DOUBLE PRECISION(N). +C RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B, +C IF ITS COMPUTATION HAS BEEN REQUESTED. RSD IS +C ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE +C ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK. +C XB DOUBLE PRECISION(N). +C XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B, +C IF ITS COMPUTATION HAS BEEN REQUESTED. XB IS ALSO +C THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE +C OF X. +C INFO INTEGER. +C INFO IS ZERO UNLESS THE COMPUTATION OF B HAS +C BEEN REQUESTED AND R IS EXACTLY SINGULAR. IN +C THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO +C DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED. +C THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED +C IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE +C CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM. +C TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME +C ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE. A +C FREQUENTLY OCCURING EXAMPLE IS WHEN ONE WISHES TO COMPUTE +C ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY. IN THIS +C CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE +C PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE +C COMPUTED. THUS THE CALLING SEQUENCE +C CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) +C WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD +C OVERWRITING Y. MORE GENERALLY, EACH ITEM IN THE FOLLOWING +C LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR +C A SINGLE CALLING SEQUENCE. +C 1. (Y,QTY,B) (RSD) (XB) (QY) +C 2. (Y,QTY,RSD) (B) (XB) (QY) +C 3. (Y,QTY,XB) (B) (RSD) (QY) +C 4. (Y,QY) (QTY,B) (RSD) (XB) +C 5. (Y,QY) (QTY,RSD) (B) (XB) +C 6. (Y,QY) (QTY,XB) (B) (RSD) +C IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO +C THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DCOPY,DDOT +C***END PROLOGUE DQRSL + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,K,LDX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(*),QRAUX(*),QTY(*),QY(*),RSD(*),X(LDX,*),XB(*), + + Y(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + T,TEMP + INTEGER + + I,J,JJ,JU,KP1 + LOGICAL + + CB,CQTY,CQY,CR,CXB + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT + EXTERNAL + + DDOT + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY,DCOPY + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN0,MOD + + +C***FIRST EXECUTABLE STATEMENT DQRSL + + + INFO = 0 + +C DETERMINE WHAT IS TO BE COMPUTED. + + CQY = JOB/10000 .NE. 0 + CQTY = MOD(JOB,10000) .NE. 0 + CB = MOD(JOB,1000)/100 .NE. 0 + CR = MOD(JOB,100)/10 .NE. 0 + CXB = MOD(JOB,10) .NE. 0 + JU = MIN0(K,N-1) + +C SPECIAL ACTION WHEN N=1. + + IF (JU .NE. 0) GO TO 40 + IF (CQY) QY(1) = Y(1) + IF (CQTY) QTY(1) = Y(1) + IF (CXB) XB(1) = Y(1) + IF (.NOT.CB) GO TO 30 + IF (X(1,1) .NE. 0.0D0) GO TO 10 + INFO = 1 + GO TO 20 + 10 CONTINUE + B(1) = Y(1)/X(1,1) + 20 CONTINUE + 30 CONTINUE + IF (CR) RSD(1) = 0.0D0 + GO TO 250 + 40 CONTINUE + +C SET UP TO COMPUTE QY OR QTY. + + IF (CQY) CALL DCOPY(N,Y,1,QY,1) + IF (CQTY) CALL DCOPY(N,Y,1,QTY,1) + IF (.NOT.CQY) GO TO 70 + +C COMPUTE QY. + + DO 60 JJ = 1, JU + J = JU - JJ + 1 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 50 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + T = -DDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,QY(J),1) + X(J,J) = TEMP + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IF (.NOT.CQTY) GO TO 100 + +C COMPUTE TRANS(Q)*Y. + + DO 90 J = 1, JU + IF (QRAUX(J) .EQ. 0.0D0) GO TO 80 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + T = -DDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,QTY(J),1) + X(J,J) = TEMP + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + +C SET UP TO COMPUTE B, RSD, OR XB. + + IF (CB) CALL DCOPY(K,QTY,1,B,1) + KP1 = K + 1 + IF (CXB) CALL DCOPY(K,QTY,1,XB,1) + IF (CR .AND. K .LT. N) CALL DCOPY(N-K,QTY(KP1),1,RSD(KP1),1) + IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 + DO 110 I = KP1, N + XB(I) = 0.0D0 + 110 CONTINUE + 120 CONTINUE + IF (.NOT.CR) GO TO 140 + DO 130 I = 1, K + RSD(I) = 0.0D0 + 130 CONTINUE + 140 CONTINUE + IF (.NOT.CB) GO TO 190 + +C COMPUTE B. + + DO 170 JJ = 1, K + J = K - JJ + 1 + IF (X(J,J) .NE. 0.0D0) GO TO 150 + INFO = J +C ......EXIT + GO TO 180 + 150 CONTINUE + B(J) = B(J)/X(J,J) + IF (J .EQ. 1) GO TO 160 + T = -B(J) + CALL DAXPY(J-1,T,X(1,J),1,B,1) + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 + +C COMPUTE RSD OR XB AS REQUIRED. + + DO 230 JJ = 1, JU + J = JU - JJ + 1 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 220 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + IF (.NOT.CR) GO TO 200 + T = -DDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,RSD(J),1) + 200 CONTINUE + IF (.NOT.CXB) GO TO 210 + T = -DDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) + CALL DAXPY(N-J+1,T,X(J,J),1,XB(J),1) + 210 CONTINUE + X(J,J) = TEMP + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN + END +*DROT + SUBROUTINE DROT(N,DX,INCX,DY,INCY,DC,DS) +C***BEGIN PROLOGUE DROT +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A8 +C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE APPLY D.P. GIVENS ROTATION +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C DC D.P. ELEMENT OF ROTATION MATRIX +C DS D.P. ELEMENT OF ROTATION MATRIX +C --OUTPUT-- +C DX ROTATED VECTOR (UNCHANGED IF N .LE. 0) +C DY ROTATED VECTOR (UNCHANGED IF N .LE. 0) +C MULTIPLY THE 2 X 2 MATRIX ( DC DS) TIMES THE 2 X N MATRIX (DX**T) +C (-DS DC) (DY**T) +C WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN +C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE +C LX = (-INCX)*N, AND SIMILARLY FOR DY USING LY AND INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DROT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DC,DS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,W,Z,ZERO + INTEGER + + I,KX,KY,NSTEPS + +C...DATA STATEMENTS + DATA + + ZERO,ONE/0.D0,1.D0/ + + +C***FIRST EXECUTABLE STATEMENT DROT + + + IF(N .LE. 0 .OR. (DS .EQ. ZERO .AND. DC .EQ. ONE)) GO TO 40 + IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 + + NSTEPS=INCX*N + DO 10 I=1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=DC*W+DS*Z + DY(I)=-DS*W+DC*Z + 10 CONTINUE + GO TO 40 + + 20 CONTINUE + KX=1 + KY=1 + + IF(INCX .LT. 0) KX=1-(N-1)*INCX + IF(INCY .LT. 0) KY=1-(N-1)*INCY + + DO 30 I=1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=DC*W+DS*Z + DY(KY)=-DS*W+DC*Z + KX=KX+INCX + KY=KY+INCY + 30 CONTINUE + 40 CONTINUE + + RETURN + END +*DROTG + SUBROUTINE DROTG(DA,DB,DC,DS) +C***BEGIN PROLOGUE DROTG +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1B10 +C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE CONSTRUCT D.P. PLANE GIVENS ROTATION +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C DA DOUBLE PRECISION SCALAR +C DB DOUBLE PRECISION SCALAR +C --OUTPUT-- +C DA DOUBLE PRECISION RESULT R +C DB DOUBLE PRECISION RESULT Z +C DC DOUBLE PRECISION RESULT +C DS DOUBLE PRECISION RESULT +C DESIGNED BY C. L. LAWSON, JPL, 1977 SEPT 08 +C CONSTRUCT THE GIVENS TRANSFORMATION +C ( DC DS ) +C G = ( ) , DC**2 + DS**2 = 1 , +C (-DS DC ) +C WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (DA,DB)**T . +C THE QUANTITY R = (+/-)DSQRT(DA**2 + DB**2) OVERWRITES DA IN +C STORAGE. THE VALUE OF DB IS OVERWRITTEN BY A VALUE Z WHICH +C ALLOWS DC AND DS TO BE RECOVERED BY THE FOLLOWING ALGORITHM. +C IF Z=1 SET DC=0.D0 AND DS=1.D0 +C IF DABS(Z) .LT. 1 SET DC=DSQRT(1-Z**2) AND DS=Z +C IF DABS(Z) .GT. 1 SET DC=1/Z AND DS=DSQRT(1-DC**2) +C NORMALLY, THE SUBPROGRAM DROT(N,DX,INCX,DY,INCY,DC,DS) WILL +C NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DROTG + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA,DB,DC,DS + +C...LOCAL SCALARS + DOUBLE PRECISION + + R,U,V + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DSQRT + + +C***FIRST EXECUTABLE STATEMENT DROTG + + + IF (DABS(DA) .LE. DABS(DB)) GO TO 10 + +C *** HERE DABS(DA) .GT. DABS(DB) *** + + U = DA + DA + V = DB / U + +C NOTE THAT U AND R HAVE THE SIGN OF DA + + R = DSQRT(.25D0 + V**2) * U + +C NOTE THAT DC IS POSITIVE + + DC = DA / R + DS = V * (DC + DC) + DB = DS + DA = R + RETURN + +C *** HERE DABS(DA) .LE. DABS(DB) *** + + 10 IF (DB .EQ. 0.D0) GO TO 20 + U = DB + DB + V = DA / U + +C NOTE THAT U AND R HAVE THE SIGN OF DB +C (R IS IMMEDIATELY STORED IN DA) + + DA = DSQRT(.25D0 + V**2) * U + +C NOTE THAT DS IS POSITIVE + + DS = DB / DA + DC = V * (DS + DS) + IF (DC .EQ. 0.D0) GO TO 15 + DB = 1.D0 / DC + RETURN + 15 DB = 1.D0 + RETURN + +C *** HERE DA = DB = 0.D0 *** + + 20 DC = 1.D0 + DS = 0.D0 + RETURN + + END +*DSCAL + SUBROUTINE DSCAL(N,DA,DX,INCX) +C***BEGIN PROLOGUE DSCAL +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A6 +C***KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. VECTOR SCALE X = A*X +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DA DOUBLE PRECISION SCALE FACTOR +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DX DOUBLE PRECISION RESULT (UNCHANGED IF N.LE.0) +C REPLACE DOUBLE PRECISION DX BY DOUBLE PRECISION DA*DX. +C FOR I = 0 TO N-1, REPLACE DX(1+I*INCX) WITH DA * DX(1+I*INCX) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DSCAL + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + INTEGER + + I,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DSCAL + + + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + NS = N*INCX + DO 10 I = 1,NS,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. + + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I + 1) = DA*DX(I + 1) + DX(I + 2) = DA*DX(I + 2) + DX(I + 3) = DA*DX(I + 3) + DX(I + 4) = DA*DX(I + 4) + 50 CONTINUE + RETURN + END +*DSWAP + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DSWAP +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A5 +C***KEYWORDS BLAS,DOUBLE PRECISION,INTERCHANGE,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE INTERCHANGE D.P. VECTORS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DX INPUT VECTOR DY (UNCHANGED IF N .LE. 0) +C DY INPUT VECTOR DX (UNCHANGED IF N .LE. 0) +C INTERCHANGE DOUBLE PRECISION DX AND DOUBLE PRECISION DY. +C FOR I = 0 TO N-1, INTERCHANGE DX(LX+I*INCX) AND DY(LY+I*INCY), +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DSWAP + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + DTEMP1,DTEMP2,DTEMP3 + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DSWAP + + + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP1 = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP1 + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. + + 20 M = MOD(N,3) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 30 CONTINUE + IF( N .LT. 3 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP1 = DX(I) + DTEMP2 = DX(I+1) + DTEMP3 = DX(I+2) + DX(I) = DY(I) + DX(I+1) = DY(I+1) + DX(I+2) = DY(I+2) + DY(I) = DTEMP1 + DY(I+1) = DTEMP2 + DY(I+2) = DTEMP3 + 50 CONTINUE + RETURN + 60 CONTINUE + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + NS = N*INCX + DO 70 I=1,NS,INCX + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 70 CONTINUE + RETURN + END +*DTRCO + SUBROUTINE DTRCO(T,LDT,N,RCOND,Z,JOB) +C***BEGIN PROLOGUE DTRCO +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A3 +C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, +C MATRIX,TRIANGULAR +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR +C MATRIX. +C***DESCRIPTION +C DTRCO ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR +C MATRIX. +C ON ENTRY +C T DOUBLE PRECISION(LDT,N) +C T CONTAINS THE TRIANGULAR MATRIX. THE ZERO +C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND +C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE +C USED TO STORE OTHER INFORMATION. +C LDT INTEGER +C LDT IS THE LEADING DIMENSION OF THE ARRAY T. +C N INTEGER +C N IS THE ORDER OF THE SYSTEM. +C JOB INTEGER +C = 0 T IS LOWER TRIANGULAR. +C = NONZERO T IS UPPER TRIANGULAR. +C ON RETURN +C RCOND DOUBLE PRECISION +C AN ESTIMATE OF THE RECIPROCAL CONDITION OF T . +C FOR THE SYSTEM T*X = B , RELATIVE PERTURBATIONS +C IN T 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 T MAY BE SINGULAR TO WORKING +C PRECISION. IN PARTICULAR, RCOND IS ZERO IF +C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE +C UNDERFLOWS. +C Z DOUBLE PRECISION(N) +C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. +C IF T 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 LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DASUM,DAXPY,DSCAL +C***END PROLOGUE DTRCO + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + RCOND + INTEGER + + JOB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,*),Z(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + EK,S,SM,TNORM,W,WK,WKM,YNORM + INTEGER + + I1,J,J1,J2,K,KK,L + LOGICAL + + LOWER + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DASUM + EXTERNAL + + DASUM + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY,DSCAL + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DMAX1,DSIGN + + +C***FIRST EXECUTABLE STATEMENT DTRCO + + + LOWER = JOB .EQ. 0 + +C COMPUTE 1-NORM OF T + + TNORM = 0.0D0 + DO 10 J = 1, N + L = J + IF (LOWER) L = N + 1 - J + I1 = 1 + IF (LOWER) I1 = J + TNORM = DMAX1(TNORM,DASUM(L,T(I1,J),1)) + 10 CONTINUE + +C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . +C TRANS(T) IS THE TRANSPOSE OF T . +C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL +C GROWTH IN THE ELEMENTS OF Y . +C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. + +C SOLVE TRANS(T)*Y = E + + EK = 1.0D0 + DO 20 J = 1, N + Z(J) = 0.0D0 + 20 CONTINUE + DO 100 KK = 1, N + K = KK + IF (LOWER) K = N + 1 - KK + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) + IF (DABS(EK-Z(K)) .LE. DABS(T(K,K))) GO TO 30 + S = DABS(T(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 (T(K,K) .EQ. 0.0D0) GO TO 40 + WK = WK/T(K,K) + WKM = WKM/T(K,K) + GO TO 50 + 40 CONTINUE + WK = 1.0D0 + WKM = 1.0D0 + 50 CONTINUE + IF (KK .EQ. N) GO TO 90 + J1 = K + 1 + IF (LOWER) J1 = 1 + J2 = N + IF (LOWER) J2 = K - 1 + DO 60 J = J1, J2 + SM = SM + DABS(Z(J)+WKM*T(K,J)) + Z(J) = Z(J) + WK*T(K,J) + S = S + DABS(Z(J)) + 60 CONTINUE + IF (S .GE. SM) GO TO 80 + W = WKM - WK + WK = WKM + DO 70 J = J1, J2 + Z(J) = Z(J) + W*T(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) + + YNORM = 1.0D0 + +C SOLVE T*Z = Y + + DO 130 KK = 1, N + K = N + 1 - KK + IF (LOWER) K = KK + IF (DABS(Z(K)) .LE. DABS(T(K,K))) GO TO 110 + S = DABS(T(K,K))/DABS(Z(K)) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + 110 CONTINUE + IF (T(K,K) .NE. 0.0D0) Z(K) = Z(K)/T(K,K) + IF (T(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + I1 = 1 + IF (LOWER) I1 = K + 1 + IF (KK .GE. N) GO TO 120 + W = -Z(K) + CALL DAXPY(N-KK,W,T(I1,K),1,Z(I1),1) + 120 CONTINUE + 130 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL(N,S,Z,1) + YNORM = S*YNORM + + IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM + IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END +*DTRSL + SUBROUTINE DTRSL(T,LDT,N,B,JOB,INFO) +C***BEGIN PROLOGUE DTRSL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A3 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, +C TRIANGULAR +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE SOLVES SYSTEMS OF THE FORM T*X=B OR TRANS(T)*X=B WHERE T +C IS A TRIANGULAR MATRIX OF ORDER N. +C***DESCRIPTION +C DTRSL SOLVES SYSTEMS OF THE FORM +C T * X = B +C OR +C TRANS(T) * X = B +C WHERE T IS A TRIANGULAR MATRIX OF ORDER N. HERE TRANS(T) +C DENOTES THE TRANSPOSE OF THE MATRIX T. +C ON ENTRY +C T DOUBLE PRECISION(LDT,N) +C T CONTAINS THE MATRIX OF THE SYSTEM. THE ZERO +C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND +C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE +C USED TO STORE OTHER INFORMATION. +C LDT INTEGER +C LDT IS THE LEADING DIMENSION OF THE ARRAY T. +C N INTEGER +C N IS THE ORDER OF THE SYSTEM. +C B DOUBLE PRECISION(N). +C B CONTAINS THE RIGHT HAND SIDE OF THE SYSTEM. +C JOB INTEGER +C JOB SPECIFIES WHAT KIND OF SYSTEM IS TO BE SOLVED. +C IF JOB IS +C 00 SOLVE T*X=B, T LOWER TRIANGULAR, +C 01 SOLVE T*X=B, T UPPER TRIANGULAR, +C 10 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, +C 11 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. +C ON RETURN +C B B CONTAINS THE SOLUTION, IF INFO .EQ. 0. +C OTHERWISE B IS UNALTERED. +C INFO INTEGER +C INFO CONTAINS ZERO IF THE SYSTEM IS NONSINGULAR. +C OTHERWISE INFO CONTAINS THE INDEX OF +C THE FIRST ZERO DIAGONAL ELEMENT OF T. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY,DDOT +C***END PROLOGUE DTRSL + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(*),T(LDT,*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP + INTEGER + + CASE,J,JJ + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT + EXTERNAL + + DDOT + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DTRSL + + +C BEGIN BLOCK PERMITTING ...EXITS TO 150 + +C CHECK FOR ZERO DIAGONAL ELEMENTS. + + DO 10 INFO = 1, N +C ......EXIT + IF (T(INFO,INFO) .EQ. 0.0D0) GO TO 150 + 10 CONTINUE + INFO = 0 + +C DETERMINE THE TASK AND GO TO IT. + + CASE = 1 + IF (MOD(JOB,10) .NE. 0) CASE = 2 + IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 + GO TO (20,50,80,110), CASE + +C SOLVE T*X=B FOR T LOWER TRIANGULAR + + 20 CONTINUE + B(1) = B(1)/T(1,1) + IF (N .LT. 2) GO TO 40 + DO 30 J = 2, N + TEMP = -B(J-1) + CALL DAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) + B(J) = B(J)/T(J,J) + 30 CONTINUE + 40 CONTINUE + GO TO 140 + +C SOLVE T*X=B FOR T UPPER TRIANGULAR. + + 50 CONTINUE + B(N) = B(N)/T(N,N) + IF (N .LT. 2) GO TO 70 + DO 60 JJ = 2, N + J = N - JJ + 1 + TEMP = -B(J+1) + CALL DAXPY(J,TEMP,T(1,J+1),1,B(1),1) + B(J) = B(J)/T(J,J) + 60 CONTINUE + 70 CONTINUE + GO TO 140 + +C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. + + 80 CONTINUE + B(N) = B(N)/T(N,N) + IF (N .LT. 2) GO TO 100 + DO 90 JJ = 2, N + J = N - JJ + 1 + B(J) = B(J) - DDOT(JJ-1,T(J+1,J),1,B(J+1),1) + B(J) = B(J)/T(J,J) + 90 CONTINUE + 100 CONTINUE + GO TO 140 + +C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. + + 110 CONTINUE + B(1) = B(1)/T(1,1) + IF (N .LT. 2) GO TO 130 + DO 120 J = 2, N + B(J) = B(J) - DDOT(J-1,T(1,J),1,B(1),1) + B(J) = B(J)/T(J,J) + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + RETURN + END +*IDAMAX + INTEGER FUNCTION IDAMAX(N,DX,INCX) +C***BEGIN PROLOGUE IDAMAX +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A2 +C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT, +C VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE FIND LARGEST COMPONENT OF D.P. VECTOR +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C IDAMAX SMALLEST INDEX (ZERO IF N .LE. 0) +C FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF DOUBLE PRECISION DX. +C IDAMAX = FIRST I, I = 1 TO N, TO MINIMIZE ABS(DX(1-INCX+I*INCX) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE IDAMAX + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + DMAX,XMAG + INTEGER + + I,II,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS + + +C***FIRST EXECUTABLE STATEMENT IDAMAX + + + IDAMAX = 0 + IF(N.LE.0) RETURN + IDAMAX = 1 + IF(N.LE.1)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + DMAX = DABS(DX(1)) + NS = N*INCX + II = 1 + DO 10 I = 1,NS,INCX + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 5 + IDAMAX = II + DMAX = XMAG + 5 II = II + 1 + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 30 + IDAMAX = I + DMAX = XMAG + 30 CONTINUE + RETURN + END + +*DODR + SUBROUTINE DODR + + (FCN, + + N,M,NP,NQ, + + BETA, + + Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + JOB, + + IPRINT,LUNERR,LUNRPT, + + WORK,LWORK,IWORK,LIWORK, + + INFO) +C***BEGIN PROLOGUE DODR +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***CATEGORY NO. G2E,I1B1 +C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, +C NONLINEAR LEAST SQUARES, +C MEASUREMENT ERROR MODELS, +C ERRORS IN VARIABLES +C***AUTHOR BOGGS, PAUL T. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C GAITHERSBURG, MD 20899 +C BYRD, RICHARD H. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C ROGERS, JANET E. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C SCHNABEL, ROBERT B. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C AND +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION (SHORT CALL STATEMENT) +C***DESCRIPTION +C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. +C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND +C R. B. SCHNABEL (1989), +C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED +C ORTHOGONAL DISTANCE REGRESSION," +C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. +C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND +C R. B. SCHNABEL (1992), +C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, +C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C INTERNAL REPORT NUMBER 92-4834. +C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), +C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR +C ORTHOGONAL DISTANCE REGRESSION," +C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. +C***ROUTINES CALLED DODCNT +C***END PROLOGUE DODR + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,LIWORK,LWORK, + + M,N,NDIGIT,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + NEGONE,PARTOL,SSTOL,TAUFAC,ZERO + INTEGER + + IPRINT,LDIFX,LDSCLD,LDSTPD,LUNERR,LUNRPT,MAXIT + LOGICAL + + SHORT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + SCLB(1),SCLD(1,1),STPB(1),STPD(1,1),WD1(1,1,1) + INTEGER + + IFIXB(1),IFIXX(1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODCNT + +C...DATA STATEMENTS + DATA + + NEGONE,ZERO + + /-1.0D0,0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C N: THE NUMBER OF OBSERVATIONS. +C NEGONE: THE VALUE -1.0D0. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C WD: THE DELTA WEIGHTS. +C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODR + + +C INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES + + IFIXB(1) = -1 + IFIXX(1,1) = -1 + LDIFX = 1 + NDIGIT = -1 + TAUFAC = NEGONE + SSTOL = NEGONE + PARTOL = NEGONE + MAXIT = -1 + STPB(1) = NEGONE + STPD(1,1) = NEGONE + LDSTPD = 1 + SCLB(1) = NEGONE + SCLD(1,1) = NEGONE + LDSCLD = 1 + + SHORT = .TRUE. + + IF (WD(1,1,1).NE.ZERO) THEN + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + ELSE + WD1(1,1,1) = NEGONE + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + END IF + + RETURN + + END +*DODRC + SUBROUTINE DODRC + + (FCN, + + N,M,NP,NQ, + + BETA, + + Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, + + SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, + + SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) +C***BEGIN PROLOGUE DODRC +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***CATEGORY NO. G2E,I1B1 +C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, +C NONLINEAR LEAST SQUARES, +C MEASUREMENT ERROR MODELS, +C ERRORS IN VARIABLES +C***AUTHOR BOGGS, PAUL T. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C GAITHERSBURG, MD 20899 +C BYRD, RICHARD H. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C ROGERS, JANET E. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C SCHNABEL, ROBERT B. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C AND +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION (LONG CALL STATEMENT) +C***DESCRIPTION +C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. +C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND +C R. B. SCHNABEL (1989), +C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED +C ORTHOGONAL DISTANCE REGRESSION," +C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. +C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND +C R. B. SCHNABEL (1992), +C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, +C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C INTERNAL REPORT NUMBER 92-4834. +C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), +C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR +C ORTHOGONAL DISTANCE REGRESSION," +C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. +C***ROUTINES CALLED DODCNT +C***END PROLOGUE DODRC + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + NEGONE,ZERO + LOGICAL + + SHORT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + WD1(1,1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODCNT + +C...DATA STATEMENTS + DATA + + NEGONE,ZERO + + /-1.0D0,0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C WD: THE DELTA WEIGHTS. +C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODRC + + + SHORT = .FALSE. + + IF (WD(1,1,1).NE.ZERO) THEN + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + ELSE + WD1(1,1,1) = NEGONE + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + END IF + + RETURN + + END +*DACCES + SUBROUTINE DACCES + + (N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) +C***BEGIN PROLOGUE DACCES +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DIWINF,DWINF +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE ACCESS OR STORE VALUES IN THE WORK ARRAYS +C***END PROLOGUE DACESS + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRS,ALPHA,ETA,OLMAVG,PARTOL,PNORM,PRERS,RCOND, + + RNORMS,RVAR,SSTOL,TAU,TAUFAC + INTEGER + + IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOP,ISTOPI,JOB,JPVT, + + LDWE,LD2WE,LIWORK,LUNRPT,LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV, + + NNZW,NP,NPP,NQ,OMEGA,QRAUX,SD,U,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 + LOGICAL + + ACCESS,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + WORK(LWORK),WSS(3) + INTEGER + + IWORK(LIWORK) + +C...LOCAL SCALARS + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I, + + DELTAI,DELTNI,DELTSI,DIFFI,EPSI, + + EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT, + + IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI, + + MSGB,MSGD,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI, + + NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + WSSI,WSSDEI,WSSEPI,XPLUSI +C...EXTERNAL SUBROUTINES + EXTERNAL + + DIWINF,DWINF + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE +C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN +C THEM (ACCESS=FALSE). +C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IDFI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS. +C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. +C IPR1: THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE INITIAL SUMMARY REPORT. +C IPR2: THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE ITERATION REPORTS. +C IPR2F: THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. +C IPR3: THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FINAL SUMMARY REPORT. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS TO BE +C FOUND BY ODR (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C JPVT: THE PIVOT VECTOR. +C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE JPVT. +C LDTTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITER: THE NUMBER OF ITERATIONS TAKEN. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS ACTUALLY ESTIMATED. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. +C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER +C ITERATION. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGA: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERS: THE SAVED PREDICTED RELATIVE REDUCTION IN THE +C SUM-OF-SQUARES. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORMS: THE NORM OF THE SAVED WEIGHTED EPSILONS AND DELTAS. +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVAR: THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SCLB: THE SCALING VALUES USED FOR BETA. +C SCLD: THE SCALING VALUES USED FOR DELTA. +C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG- +C CALL (SHORT=FALSE). +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSS: THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. +C WSSI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(1). +C WSSDEI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(2). +C WSSEPI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(3). +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. + + +C***FIRST EXECUTABLE STATEMENT DACCES + + +C FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE + + CALL DIWINF(M,NP,NQ, + + MSGB,MSGD,JPVTI,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) + +C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE + + CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) + + IF (ACCESS) THEN + +C SET STARTING LOCATIONS FOR WORK VECTORS + + JPVT = JPVTI + OMEGA = OMEGAI + QRAUX = QRAUXI + SD = SDI + VCV = VCVI + U = UI + WRK1 = WRK1I + WRK2 = WRK2I + WRK3 = WRK3I + WRK4 = WRK4I + WRK5 = WRK5I + WRK6 = WRK6I + +C ACCESS VALUES FROM THE WORK VECTORS + + ACTRS = WORK(ACTRSI) + ALPHA = WORK(ALPHAI) + ETA = WORK(ETAI) + OLMAVG = WORK(OLMAVI) + PARTOL = WORK(PARTLI) + PNORM = WORK(PNORMI) + PRERS = WORK(PRERSI) + RCOND = WORK(RCONDI) + WSS(1) = WORK(WSSI) + WSS(2) = WORK(WSSDEI) + WSS(3) = WORK(WSSEPI) + RVAR = WORK(RVARI) + RNORMS = WORK(RNORSI) + SSTOL = WORK(SSTOLI) + TAU = WORK(TAUI) + TAUFAC = WORK(TAUFCI) + + NETA = IWORK(NETAI) + IRANK = IWORK(IRANKI) + JOB = IWORK(JOBI) + LUNRPT = IWORK(LUNRPI) + MAXIT = IWORK(MAXITI) + NFEV = IWORK(NFEVI) + NITER = IWORK(NITERI) + NJEV = IWORK(NJEVI) + NNZW = IWORK(NNZWI) + NPP = IWORK(NPPI) + IDF = IWORK(IDFI) + INT2 = IWORK(INT2I) + +C SET UP PRINT CONTROL VARIABLES + + IPRINT = IWORK(IPRINI) + + IPR1 = MOD(IPRINT,10000)/1000 + IPR2 = MOD(IPRINT,1000)/100 + IPR2F = MOD(IPRINT,100)/10 + IPR3 = MOD(IPRINT,10) + + ELSE + +C STORE VALUES INTO THE WORK VECTORS + + WORK(ACTRSI) = ACTRS + WORK(ALPHAI) = ALPHA + WORK(OLMAVI) = OLMAVG + WORK(PARTLI) = PARTOL + WORK(PNORMI) = PNORM + WORK(PRERSI) = PRERS + WORK(RCONDI) = RCOND + WORK(WSSI) = WSS(1) + WORK(WSSDEI) = WSS(2) + WORK(WSSEPI) = WSS(3) + WORK(RVARI) = RVAR + WORK(RNORSI) = RNORMS + WORK(SSTOLI) = SSTOL + WORK(TAUI) = TAU + + IWORK(IRANKI) = IRANK + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IWORK(NITERI) = NITER + IWORK(NJEVI) = NJEV + IWORK(IDFI) = IDF + IWORK(INT2I) = INT2 + END IF + + RETURN + END +*DESUBI + SUBROUTINE DESUBI + + (N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,E) +C***BEGIN PROLOGUE DESUBI +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE E = WD + ALPHA*TT**2 +C***END PROLOGUE DESUBI + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA + INTEGER + + LDTT,LDWD,LD2WD,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + E(M,M),TT(LDTT,M),WD(LDWD,LD2WD,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J,J1,J2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C E: THE VALUE OF THE ARRAY E = WD + ALPHA*TT**2 +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C J1: AN INDEXING VARIABLE. +C J2: AN INDEXING VARIABLE. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF RESPONSES PER OBSERVATION. +C TT: THE SCALING VALUES USED FOR DELTA. +C WD: THE SQUARED DELTA WEIGHTS, D**2. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DESUBI + + +C N.B. THE LOCATIONS OF WD AND TT ACCESSED DEPEND ON THE VALUE +C OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSIONS +C OF THE MULTIPLY SUBSCRIPTED ARRAYS. + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (WD(1,1,1).GE.ZERO) THEN + IF (LDWD.GE.N) THEN +C THE ELEMENTS OF WD HAVE BEEN INDIVIDUALLY SPECIFIED + + IF (LD2WD.EQ.1) THEN +C THE ARRAYS STORED IN WD ARE DIAGONAL + CALL DZERO(M,M,E,M) + DO 10 J=1,M + E(J,J) = WD(I,1,J) + 10 CONTINUE + ELSE +C THE ARRAYS STORED IN WD ARE FULL POSITIVE SEMIDEFINITE MATRICES + DO 30 J1=1,M + DO 20 J2=1,M + E(J1,J2) = WD(I,J1,J2) + 20 CONTINUE + 30 CONTINUE + END IF + + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 110 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 + 110 CONTINUE + ELSE + DO 120 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 + 120 CONTINUE + END IF + ELSE + DO 130 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 + 130 CONTINUE + END IF + ELSE +C WD IS AN M BY M MATRIX + + IF (LD2WD.EQ.1) THEN +C THE ARRAY STORED IN WD IS DIAGONAL + CALL DZERO(M,M,E,M) + DO 140 J=1,M + E(J,J) = WD(1,1,J) + 140 CONTINUE + ELSE +C THE ARRAY STORED IN WD IS A FULL POSITIVE SEMIDEFINITE MATRICES + DO 160 J1=1,M + DO 150 J2=1,M + E(J1,J2) = WD(1,J1,J2) + 150 CONTINUE + 160 CONTINUE + END IF + + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 210 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 + 210 CONTINUE + ELSE + DO 220 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 + 220 CONTINUE + END IF + ELSE + DO 230 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 + 230 CONTINUE + END IF + END IF + ELSE +C WD IS A DIAGONAL MATRIX WITH ELEMENTS ABS(WD(1,1,1)) + CALL DZERO(M,M,E,M) + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 310 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(I,J)**2 + 310 CONTINUE + ELSE + DO 320 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,J)**2 + 320 CONTINUE + END IF + ELSE + DO 330 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,1)**2 + 330 CONTINUE + END IF + END IF + + RETURN + END +*DETAF + SUBROUTINE DETAF + + (FCN, + + N,M,NP,NQ, + + XPLUSD,BETA,EPSMAC,NROW, + + PARTMP,PV0, + + IFIXB,IFIXX,LDIFX, + + ISTOP,NFEV,ETA,NETA, + + WRK1,WRK2,WRK6,WRK7) +C***BEGIN PROLOGUE DETAF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS +C (ADAPTED FROM STARPAC SUBROUTINE ETAFUN) +C***END PROLOGUE DETAF + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSMAC,ETA + INTEGER + + ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),PARTMP(NP),PV0(N,NQ), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),WRK7(-2:2,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + A,B,FAC,HUNDRD,ONE,P1,P2,P5,STP,TWO,ZERO + INTEGER + + J,K,L + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,INT,LOG10,MAX,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P1,P2,P5,ONE,TWO,HUNDRD + + /0.0D0,0.1D0,0.2D0,0.5D0,1.0D0,2.0D0,1.0D2/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: PARAMETERS OF THE LOCAL FIT. +C B: PARAMETERS OF THE LOCAL FIT. +C BETA: THE FUNCTION PARAMETERS. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE NOISE IN THE MODEL RESULTS. +C FAC: A FACTOR USED IN THE COMPUTATIONS. +C HUNDRD: THE VALUE 1.0D2. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEX VARIABLE. +C K: AN INDEX VARIABLE. +C L: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C P1: THE VALUE 0.1D0. +C P2: THE VALUE 0.2D0. +C P5: THE VALUE 0.5D0. +C PARTMP: THE MODEL PARAMETERS. +C PV0: THE ORIGINAL PREDICTED VALUES. +C STP: A SMALL VALUE USED TO PERTURB THE PARAMETERS. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C WRK7: A WORK ARRAY OF (5 BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DETAF + + + STP = HUNDRD*EPSMAC + ETA = EPSMAC + + DO 40 J=-2,2 + IF (J.EQ.0) THEN + DO 10 L=1,NQ + WRK7(J,L) = PV0(NROW,L) + 10 CONTINUE + ELSE + DO 20 K=1,NP + IF (IFIXB(1).LT.0) THEN + PARTMP(K) = BETA(K) + J*STP*BETA(K) + ELSE IF (IFIXB(K).NE.0) THEN + PARTMP(K) = BETA(K) + J*STP*BETA(K) + ELSE + PARTMP(K) = BETA(K) + END IF + 20 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + PARTMP,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1,ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + DO 30 L=1,NQ + WRK7(J,L) = WRK2(NROW,L) + 30 CONTINUE + END IF + 40 CONTINUE + + DO 100 L=1,NQ + A = ZERO + B = ZERO + DO 50 J=-2,2 + A = A + WRK7(J,L) + B = B + J*WRK7(J,L) + 50 CONTINUE + A = P2*A + B = P1*B + IF ((WRK7(0,L).NE.ZERO) .AND. + + (ABS(WRK7(1,L)+WRK7(-1,L)).GT.HUNDRD*EPSMAC)) THEN + FAC = ONE/ABS(WRK7(0,L)) + ELSE + FAC = ONE + END IF + DO 60 J=-2,2 + WRK7(J,L) = ABS((WRK7(J,L)-(A+J*B))*FAC) + ETA = MAX(WRK7(J,L),ETA) + 60 CONTINUE + 100 CONTINUE + NETA = MAX(TWO,P5-LOG10(ETA)) + + RETURN + END +*DEVJAC + SUBROUTINE DEVJAC + + (FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN, + + STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) +C***BEGIN PROLOGUE DEVJAC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DDOT,DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA +C***END PROLOGUE DEVJAC + +C...SCALAR ARGUMENTS + INTEGER + + INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDWE,LDX,LD2WE, + + M,N,NETA,NFEV,NJEV,NP,NQ + LOGICAL + + ANAJAC,CDJAC,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),BETAC(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + FN(N,NQ),SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WE1(LDWE,LD2WE,NQ),WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP), + + WRK6(N,NP,NQ),X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + INTEGER + + IDEVAL,J,K,K1,L + DOUBLE PRECISION + + ZERO + LOGICAL + + ERROR + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT + EXTERNAL + + DDOT + +C...DATA STATEMENTS + DATA ZERO + + /0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C DELTA: THE ESTIMATED VALUES OF DELTA. +C ERROR: THE VARIABLE DESIGNATING WHETHER ODRPACK DETECTED NONZERO +C VALUES IN ARRAY DELTA IN THE OLS CASE, AND THUS WHETHER +C THE USER MAY HAVE OVERWRITTEN IMPORTANT INFORMATION +C BY COMPUTING FJACD IN THE OLS CASE. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT POINT. +C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE +C PERFORMED BY USER-SUPPLIED SUBROUTINE FCN. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF DELTA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISTOP: THE VARIABLE DESIGNATING THAT THE USER WISHES THE +C COMPUTATIONS STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C K1: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWE: THE LEADING DIMENSION OF ARRAYS WE AND WE1. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LD2WE: THE SECOND DIMENSION OF ARRAYS WE AND WE1. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C SSF: THE SCALE USED FOR THE BETA'S. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C WE1: THE SQUARE ROOTS OF THE EPSILON WEIGHTS IN ARRAY WE. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C X: THE INDEPENDENT VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DEVJAC + + +C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA + + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + +C COMPUTE XPLUSD = X + DELTA + + CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) + +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND +C THE JACOBIAN WRT DELTA (FJACD) + + ISTOP = 0 + IF (ISODR) THEN + IDEVAL = 110 + ELSE + IDEVAL = 010 + END IF + IF (ANAJAC) THEN + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,WRK2,FJACB,FJACD, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV+1 + END IF +C MAKE SURE FIXED ELEMENTS OF FJACD ARE ZERO + IF (ISODR) THEN + DO 10 L=1,NQ + CALL DIFIX(N,M,IFIXX,LDIFX,FJACD(1,1,L),N,FJACD(1,1,L),N) + 10 CONTINUE + END IF + ELSE IF (CDJAC) THEN + CALL DJACCD(FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) + ELSE + CALL DJACFD(FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) + END IF + IF (ISTOP.LT.0) THEN + RETURN + ELSE IF (.NOT.ISODR) THEN +C TRY TO DETECT WHETHER THE USER HAS COMPUTED JFACD +C WITHIN FCN IN THE OLS CASE + ERROR = DDOT(N*M,DELTA,1,DELTA,1).NE.ZERO + IF (ERROR) THEN + INFO = 50300 + RETURN + END IF + END IF + +C WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS + + IF (IFIXB(1).LT.0) THEN + DO 20 K=1,NP + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACB(1,K,1),N*NP,FJACB(1,K,1),N*NP) + 20 CONTINUE + ELSE + K1 = 0 + DO 30 K=1,NP + IF (IFIXB(K).GE.1) THEN + K1 = K1 + 1 + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACB(1,K,1),N*NP,FJACB(1,K1,1),N*NP) + END IF + 30 CONTINUE + END IF + +C WEIGHT THE JACOBIAN'S WRT DELTA AS APPROPRIATE + + IF (ISODR) THEN + DO 40 J=1,M + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACD(1,J,1),N*M,FJACD(1,J,1),N*M) + 40 CONTINUE + END IF + + RETURN + END +*DFCTR + SUBROUTINE DFCTR(OKSEMI,A,LDA,N,INFO) +C***BEGIN PROLOGUE DFCTR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DDOT +C***DATE WRITTEN 910706 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE FACTOR THE POSITIVE (SEMI)DEFINITE MATRIX A USING A +C MODIFIED CHOLESKY FACTORIZATION +C (ADAPTED FROM LINPACK SUBROUTINE DPOFA) +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***END PROLOGUE DFCTR + +C...SCALAR ARGUMENTS + INTEGER INFO,LDA,N + LOGICAL OKSEMI + +C...ARRAY ARGUMENTS + DOUBLE PRECISION A(LDA,N) + +C...LOCAL SCALARS + DOUBLE PRECISION XI,S,T,TEN,ZERO + INTEGER J,K + +C...EXTERNAL FUNCTIONS + EXTERNAL DMPREC,DDOT + DOUBLE PRECISION DMPREC,DDOT + +C...INTRINSIC FUNCTIONS + INTRINSIC SQRT + +C...DATA STATEMENTS + DATA + + ZERO,TEN + + /0.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: THE ARRAY TO BE FACTORED. UPON RETURN, A CONTAINS THE +C UPPER TRIANGULAR MATRIX R SO THAT A = TRANS(R)*R +C WHERE THE STRICT LOWER TRIANGLE IS SET TO ZERO +C IF INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE. +C I: AN INDEXING VARIABLE. +C INFO: AN IDICATOR VARIABLE, WHERE IF +C INFO = 0 THEN FACTORIZATION WAS COMPLETED +C INFO = K SIGNALS AN ERROR CONDITION. THE LEADING MINOR +C OF ORDER K IS NOT POSITIVE (SEMI)DEFINITE. +C J: AN INDEXING VARIABLE. +C LDA: THE LEADING DIMENSION OF ARRAY A. +C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY A. +C OKSEMI: THE INDICATING WHETHER THE FACTORED ARRAY CAN BE POSITIVE +C SEMIDEFINITE (OKSEMI=TRUE) OR WHETHER IT MUST BE FOUND TO +C BE POSITIVE DEFINITE (OKSEMI=FALSE). +C TEN: THE VALUE 10.0D0. +C XI: A VALUE USED TO TEST FOR NON POSITIVE SEMIDEFINITENESS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DFCTR + + +C SET RELATIVE TOLERANCE FOR DETECTING NON POSITIVE SEMIDEFINITENESS. + XI = -TEN*DMPREC() + +C COMPUTE FACTORIZATION, STORING IN UPPER TRIANGULAR PORTION OF A + DO 20 J=1,N + INFO = J + S = ZERO + DO 10 K=1,J-1 + IF (A(K,K).EQ.ZERO) THEN + T = ZERO + ELSE + T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1) + T = T/A(K,K) + END IF + A(K,J) = T + S = S + T*T + 10 CONTINUE + S = A(J,J) - S +C ......EXIT + IF (A(J,J).LT.ZERO .OR. S.LT.XI*ABS(A(J,J))) THEN + RETURN + ELSE IF (.NOT.OKSEMI .AND. S.LE.ZERO) THEN + RETURN + ELSE IF (S.LE.ZERO) THEN + A(J,J) = ZERO + ELSE + A(J,J) = SQRT(S) + END IF + 20 CONTINUE + INFO = 0 + +C ZERO OUT LOWER PORTION OF A + DO 40 J=2,N + DO 30 K=1,J-1 + A(J,K) = ZERO + 30 CONTINUE + 40 CONTINUE + + RETURN + END +*DFCTRW + SUBROUTINE DFCTRW + + (N,M,NQ,NPP, + + ISODR, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + WRK0,WRK4, + + WE1,NNZW,INFO) +C***BEGIN PROLOGUE DFCTRW +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFCTR +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING +C NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE +C ODRPACK REFERENCE GUIDE +C***END PROLOGUE DFCTRW + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDWD,LDWE,LD2WD,LD2WE, + + M,N,NNZW,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M), + + WRK0(NQ,NQ),WRK4(M,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,INF,J,J1,J2,L,L1,L2 + LOGICAL + + NOTZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DFCTR + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C J1: AN INDEXING VARIABLE. +C J2: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C L1: AN INDEXING VARIABLE. +C L2: AN INDEXING VARIABLE. +C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NOTZRO: THE VARIABLE DESIGNATING WHETHER A GIVEN COMPONENT OF THE +C WEIGHT ARRAY WE CONTAINS A NONZERO ELEMENT (NOTZRO=FALSE) +C OR NOT (NOTZRO=TRUE). +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. +C WE: THE (SQUARED) EPSILON WEIGHTS. +C WE1: THE FACTORED EPSILON WEIGHTS, S.T. TRANS(WE1)*WE1 = WE. +C WD: THE (SQUARED) DELTA WEIGHTS. +C WRK0: A WORK ARRAY OF (NQ BY NQ) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DFCTRW + + +C CHECK EPSILON WEIGHTS, AND STORE FACTORIZATION IN WE1 + + IF (WE(1,1,1).LT.ZERO) THEN +C WE CONTAINS A SCALAR + WE1(1,1,1) = -SQRT(ABS(WE(1,1,1))) + NNZW = N + + ELSE + NNZW = 0 + + IF (LDWE.EQ.1) THEN + + IF (LD2WE.EQ.1) THEN +C WE CONTAINS A DIAGONAL MATRIX + DO 110 L=1,NQ + IF (WE(1,1,L).GT.ZERO) THEN + NNZW = N + WE1(1,1,L) = SQRT(WE(1,1,L)) + ELSE IF (WE(1,1,L).LT.ZERO) THEN + INFO = 30010 + GO TO 300 + END IF + 110 CONTINUE + ELSE + +C WE CONTAINS A FULL NQ BY NQ SEMIDEFINITE MATRIX + DO 130 L1=1,NQ + DO 120 L2=L1,NQ + WRK0(L1,L2) = WE(1,L1,L2) + 120 CONTINUE + 130 CONTINUE + CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) + IF (INF.NE.0) THEN + INFO = 30010 + GO TO 300 + ELSE + DO 150 L1=1,NQ + DO 140 L2=1,NQ + WE1(1,L1,L2) = WRK0(L1,L2) + 140 CONTINUE + IF (WE1(1,L1,L1).NE.ZERO) THEN + NNZW = N + END IF + 150 CONTINUE + END IF + END IF + + ELSE + + IF (LD2WE.EQ.1) THEN +C WE CONTAINS AN ARRAY OF DIAGONAL MATRIX + DO 220 I=1,N + NOTZRO = .FALSE. + DO 210 L=1,NQ + IF (WE(I,1,L).GT.ZERO) THEN + NOTZRO = .TRUE. + WE1(I,1,L) = SQRT(WE(I,1,L)) + ELSE IF (WE(I,1,L).LT.ZERO) THEN + INFO = 30010 + GO TO 300 + END IF + 210 CONTINUE + IF (NOTZRO) THEN + NNZW = NNZW + 1 + END IF + 220 CONTINUE + ELSE + +C WE CONTAINS AN ARRAY OF FULL NQ BY NQ SEMIDEFINITE MATRICES + DO 270 I=1,N + DO 240 L1=1,NQ + DO 230 L2=L1,NQ + WRK0(L1,L2) = WE(I,L1,L2) + 230 CONTINUE + 240 CONTINUE + CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) + IF (INF.NE.0) THEN + INFO = 30010 + GO TO 300 + ELSE + NOTZRO = .FALSE. + DO 260 L1=1,NQ + DO 250 L2=1,NQ + WE1(I,L1,L2) = WRK0(L1,L2) + 250 CONTINUE + IF (WE1(I,L1,L1).NE.ZERO) THEN + NOTZRO = .TRUE. + END IF + 260 CONTINUE + END IF + IF (NOTZRO) THEN + NNZW = NNZW + 1 + END IF + 270 CONTINUE + END IF + END IF + END IF + +C CHECK FOR A SUFFICIENT NUMBER OF NONZERO EPSILON WEIGHTS + + IF (NNZW.LT.NPP) THEN + INFO = 30020 + END IF + + +C CHECK DELTA WEIGHTS + + 300 CONTINUE + IF (.NOT.ISODR .OR. WD(1,1,1).LT.ZERO) THEN +C PROBLEM IS NOT ODR, OR WD CONTAINS A SCALAR + RETURN + + ELSE + + IF (LDWD.EQ.1) THEN + + IF (LD2WD.EQ.1) THEN +C WD CONTAINS A DIAGONAL MATRIX + DO 310 J=1,M + IF (WD(1,1,J).LE.ZERO) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 310 CONTINUE + ELSE + +C WD CONTAINS A FULL M BY M POSITIVE DEFINITE MATRIX + DO 330 J1=1,M + DO 320 J2=J1,M + WRK4(J1,J2) = WD(1,J1,J2) + 320 CONTINUE + 330 CONTINUE + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + END IF + + ELSE + + IF (LD2WD.EQ.1) THEN +C WD CONTAINS AN ARRAY OF DIAGONAL MATRICES + DO 420 I=1,N + DO 410 J=1,M + IF (WD(I,1,J).LE.ZERO) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 410 CONTINUE + 420 CONTINUE + ELSE + +C WD CONTAINS AN ARRAY OF FULL M BY M POSITIVE DEFINITE MATRICES + DO 470 I=1,N + DO 440 J1=1,M + DO 430 J2=J1,M + WRK4(J1,J2) = WD(I,J1,J2) + 430 CONTINUE + 440 CONTINUE + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 470 CONTINUE + END IF + END IF + END IF + + RETURN + END +*DFLAGS + SUBROUTINE DFLAGS + + (JOB,RESTRT,INITD,DOVCV,REDOJ,ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) +C***BEGIN PROLOGUE DFLAGS +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB +C***END PROLOGUE DFLAGS + +C...SCALAR ARGUMENTS + INTEGER + + JOB + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...LOCAL SCALARS + INTEGER + + J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE FIRST N BY M ELEMENTS OF +C ARRAY WORK (INITD=FALSE). +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: THE VALUE OF A SPECIFIC DIGIT OF JOB. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). + + +C***FIRST EXECUTABLE STATEMENT DFLAGS + + + IF (JOB.GE.0) THEN + + RESTRT= JOB.GE.10000 + + INITD = MOD(JOB,10000)/1000.EQ.0 + + J = MOD(JOB,1000)/100 + IF (J.EQ.0) THEN + DOVCV = .TRUE. + REDOJ = .TRUE. + ELSE IF (J.EQ.1) THEN + DOVCV = .TRUE. + REDOJ = .FALSE. + ELSE + DOVCV = .FALSE. + REDOJ = .FALSE. + END IF + + J = MOD(JOB,100)/10 + IF (J.EQ.0) THEN + ANAJAC = .FALSE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + ELSE IF (J.EQ.1) THEN + ANAJAC = .FALSE. + CDJAC = .TRUE. + CHKJAC = .FALSE. + ELSE IF (J.EQ.2) THEN + ANAJAC = .TRUE. + CDJAC = .FALSE. + CHKJAC = .TRUE. + ELSE + ANAJAC = .TRUE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + END IF + + J = MOD(JOB,10) + IF (J.EQ.0) THEN + ISODR = .TRUE. + IMPLCT = .FALSE. + ELSE IF (J.EQ.1) THEN + ISODR = .TRUE. + IMPLCT = .TRUE. + ELSE + ISODR = .FALSE. + IMPLCT = .FALSE. + END IF + + ELSE + + RESTRT = .FALSE. + INITD = .TRUE. + DOVCV = .TRUE. + REDOJ = .TRUE. + ANAJAC = .FALSE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + ISODR = .TRUE. + IMPLCT = .FALSE. + + END IF + + RETURN + END +*DHSTEP + DOUBLE PRECISION FUNCTION DHSTEP + + (ITYPE,NETA,I,J,STP,LDSTP) +C***BEGIN PROLOGUE DHSTEP +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET RELATIVE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES +C***END PROLOGUE DHSTEP + +C...SCALAR ARGUMENTS + INTEGER + + I,ITYPE,J,LDSTP,NETA + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + STP(LDSTP,J) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEN,THREE,TWO,ZERO + +C...DATA STATEMENTS + DATA + + ZERO,TWO,THREE,TEN + + /0.0D0,2.0D0,3.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. +C ITYPE: THE FINITE DIFFERENCE METHOD BEING USED, WHERE +C ITYPE = 0 INDICATES FORWARD FINITE DIFFERENCES, AND +C ITYPE = 1 INDICATES CENTRAL FINITE DIFFERENCES. +C J: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. +C LDSTP: THE LEADING DIMENSION OF ARRAY STP. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TEN: THE VALUE 10.0D0. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C ZERO: THE VALUE 0.0D0. + + + +C***FIRST EXECUTABLE STATEMENT DHSTEP + + +C SET DHSTEP TO RELATIVE FINITE DIFFERENCE STEP SIZE + + IF (STP(1,1).LE.ZERO) THEN + + IF (ITYPE.EQ.0) THEN +C USE DEFAULT FORWARD FINITE DIFFERENCE STEP SIZE + DHSTEP = TEN**(-ABS(NETA)/TWO - TWO) + + ELSE +C USE DEFAULT CENTRAL FINITE DIFFERENCE STEP SIZE + DHSTEP = TEN**(-ABS(NETA)/THREE) + END IF + + ELSE IF (LDSTP.EQ.1) THEN + DHSTEP = STP(1,J) + + ELSE + DHSTEP = STP(I,J) + END IF + + RETURN + END +*DIFIX + SUBROUTINE DIFIX + + (N,M,IFIX,LDIFIX,T,LDT,TFIX,LDTFIX) +C***BEGIN PROLOGUE DIFIX +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 910612 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET ELEMENTS OF T TO ZERO ACCORDING TO IFIX +C***END PROLOGUE DIFIX + +C...SCALAR ARGUMENTS + INTEGER + + LDIFIX,LDT,LDTFIX,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),TFIX(LDTFIX,M) + INTEGER + + IFIX(LDIFIX,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE ARRAY DESIGNATING WHETHER AN ELEMENT OF T IS TO BE +C SET TO ZERO. +C J: AN INDEXING VARIABLE. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C LDIFIX: THE LEADING DIMENSION OF ARRAY IFIX. +C LDTFIX: THE LEADING DIMENSION OF ARRAY TFIX. +C M: THE NUMBER OF COLUMNS OF DATA IN THE ARRAY. +C N: THE NUMBER OF ROWS OF DATA IN THE ARRAY. +C T: THE ARRAY BEING SET TO ZERO ACCORDING TO THE ELEMENTS +C OF IFIX. +C TFIX: THE RESULTING ARRAY. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DIFIX + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (IFIX(1,1).GE.ZERO) THEN + IF (LDIFIX.GE.N) THEN + DO 20 J=1,M + DO 10 I=1,N + IF (IFIX(I,J).EQ.0) THEN + TFIX(I,J) = ZERO + ELSE + TFIX(I,J) = T(I,J) + END IF + 10 CONTINUE + 20 CONTINUE + ELSE + DO 100 J=1,M + IF (IFIX(1,J).EQ.0) THEN + DO 30 I=1,N + TFIX(I,J) = ZERO + 30 CONTINUE + ELSE + DO 90 I=1,N + TFIX(I,J) = T(I,J) + 90 CONTINUE + END IF + 100 CONTINUE + END IF + END IF + + RETURN + END +*DINIWK + SUBROUTINE DINIWK + + (N,M,NP,WORK,LWORK,IWORK,LIWORK, + + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + + BETA,SCLB, + + SSTOL,PARTOL,MAXIT,TAUFAC, + + JOB,IPRINT,LUNERR,LUNRPT, + + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + SSFI,TTI,LDTTI,DELTAI) +C***BEGIN PROLOGUE DINIWK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFLAGS,DMPREC,DSCLB,DSCLD,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE INITIALIZE WORK VECTORS AS NECESSARY +C***END PROLOGUE DINIWK + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX, + + LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M, + + MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M) + INTEGER + + IFIXX(LDIFX,M),IWORK(LIWORK) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,THREE,TWO,ZERO + INTEGER + + I,J + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DMPREC + EXTERNAL + + DMPREC + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY,DFLAGS,DSCLB,DSCLD,DZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TWO,THREE + + /0.0D0,1.0D0,2.0D0,3.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C I: AN INDEXING VARIABLE. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED +C AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C IWORK: THE INTEGER WORK SPACE. +C J: AN INDEXING VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDTTI: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING CRITERIA. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C THREE: THE VALUE 3.0D0. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF THE ARRAY TT. +C TWO: THE VALUE 2.0D0. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE INDEPENDENT VARIABLE. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DINIWK + + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + +C STORE VALUE OF MACHINE PRECISION IN WORK VECTOR + + WORK(EPSMAI) = DMPREC() + +C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE +C PARAMETERS (SEE ALSO SUBPROGRAM DODCNT) + + IF (PARTOL.LT.ZERO) THEN + WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE) + ELSE + WORK(PARTLI) = MIN(PARTOL, ONE) + END IF + +C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE +C SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS + + IF (SSTOL.LT.ZERO) THEN + WORK(SSTOLI) = SQRT(WORK(EPSMAI)) + ELSE + WORK(SSTOLI) = MIN(SSTOL, ONE) + END IF + +C SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION + + IF (TAUFAC.LE.ZERO) THEN + WORK(TAUFCI) = ONE + ELSE + WORK(TAUFCI) = MIN(TAUFAC, ONE) + END IF + +C SET MAXIMUM NUMBER OF ITERATIONS + + IF (MAXIT.LT.0) THEN + IWORK(MAXITI) = 50 + ELSE + IWORK(MAXITI) = MAXIT + END IF + +C STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL +C VARIABLE + + IF (JOB.LE.0) THEN + IWORK(JOBI) = 0 + ELSE + IWORK(JOBI) = JOB + END IF + +C SET PRINT CONTROL + + IF (IPRINT.LT.0) THEN + IWORK(IPRINI) = 2001 + ELSE + IWORK(IPRINI) = IPRINT + END IF + +C SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES + + IF (LUNERR.LT.0) THEN + IWORK(LUNERI) = 6 + ELSE + IWORK(LUNERI) = LUNERR + END IF + +C SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS + + IF (LUNRPT.LT.0) THEN + IWORK(LUNRPI) = 6 + ELSE + IWORK(LUNRPI) = LUNRPT + END IF + +C COMPUTE SCALING FOR BETA'S AND DELTA'S + + IF (SCLB(1).LE.ZERO) THEN + CALL DSCLB(NP,BETA,WORK(SSFI)) + ELSE + CALL DCOPY(NP,SCLB,1,WORK(SSFI),1) + END IF + IF (ISODR) THEN + IF (SCLD(1,1).LE.ZERO) THEN + IWORK(LDTTI) = N + CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI)) + ELSE + IF (LDSCLD.EQ.1) THEN + IWORK(LDTTI) = 1 + CALL DCOPY(M,SCLD(1,1),1,WORK(TTI),1) + ELSE + IWORK(LDTTI) = N + DO 10 J=1,M + CALL DCOPY(N,SCLD(1,J),1, + + WORK(TTI+(J-1)*IWORK(LDTTI)),1) + 10 CONTINUE + END IF + END IF + END IF + +C INITIALIZE DELTA'S AS NECESSARY + + IF (ISODR) THEN + IF (INITD) THEN + CALL DZERO(N,M,WORK(DELTAI),N) + ELSE + IF (IFIXX(1,1).GE.0) THEN + IF (LDIFX.EQ.1) THEN + DO 20 J=1,M + IF (IFIXX(1,J).EQ.0) THEN + CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N) + END IF + 20 CONTINUE + ELSE + DO 40 J=1,M + DO 30 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + WORK(DELTAI-1+I+(J-1)*N) = ZERO + END IF + 30 CONTINUE + 40 CONTINUE + END IF + END IF + END IF + ELSE + CALL DZERO(N,M,WORK(DELTAI),N) + END IF + + RETURN + END +*DIWINF + SUBROUTINE DIWINF + + (M,NP,NQ, + + MSGBI,MSGDI,IFIX2I,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) +C***BEGIN PROLOGUE DIWINF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE +C***END PROLOGUE DIWINF + +C...SCALAR ARGUMENTS + INTEGER + + IDFI,INT2I,IPRINI,IRANKI,ISTOPI,JOBI,IFIX2I,LDTTI,LIWKMN, + + LUNERI,LUNRPI,M,MAXITI,MSGBI,MSGDI,NETAI,NFEVI,NITERI,NJEVI, + + NNZWI,NP,NPPI,NQ,NROWI,NTOLI + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C IFIX2I: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY IFIX2. +C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGBI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGDI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABEL NITER. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. + + +C***FIRST EXECUTABLE STATEMENT DIWINF + + + IF (NP.GE.1 .AND. M.GE.1) THEN + MSGBI = 1 + MSGDI = MSGBI + NQ*NP+1 + IFIX2I = MSGDI + NQ*M+1 + ISTOPI = IFIX2I + NP + NNZWI = ISTOPI + 1 + NPPI = NNZWI + 1 + IDFI = NPPI + 1 + JOBI = IDFI + 1 + IPRINI = JOBI + 1 + LUNERI = IPRINI + 1 + LUNRPI = LUNERI + 1 + NROWI = LUNRPI + 1 + NTOLI = NROWI + 1 + NETAI = NTOLI + 1 + MAXITI = NETAI + 1 + NITERI = MAXITI + 1 + NFEVI = NITERI + 1 + NJEVI = NFEVI + 1 + INT2I = NJEVI + 1 + IRANKI = INT2I + 1 + LDTTI = IRANKI + 1 + LIWKMN = LDTTI + ELSE + MSGBI = 1 + MSGDI = 1 + IFIX2I = 1 + ISTOPI = 1 + NNZWI = 1 + NPPI = 1 + IDFI = 1 + JOBI = 1 + IPRINI = 1 + LUNERI = 1 + LUNRPI = 1 + NROWI = 1 + NTOLI = 1 + NETAI = 1 + MAXITI = 1 + NITERI = 1 + NFEVI = 1 + NJEVI = 1 + INT2I = 1 + IRANKI = 1 + LDTTI = 1 + LIWKMN = 1 + END IF + + RETURN + END +*DJACCD + SUBROUTINE DJACCD + + (FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) +C***BEGIN PROLOGUE DJACCD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE CENTRAL DIFFERENCE APPROXIMATIONS TO THE +C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS +C***END PROLOGUE DJACCD + +C...SCALAR ARGUMENTS + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + + X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAK,ONE,TYPJ,ZERO + INTEGER + + I,J,K,L + LOGICAL + + DOIT,SETZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAK: THE K-TH FUNCTION PARAMETER. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A GIVEN +C BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT +C (DOIT=FALSE). +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED +C AT THEIR INPUT VALUES OR NOT. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME +C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT +C (SETZRO=FALSE). +C SSF: THE SCALING VALUES USED FOR BETA. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJACCD + + +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS + + DO 60 K=1,NP + IF (IFIXB(1).GE.0) THEN + IF (IFIXB(K).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + ELSE + DOIT = .TRUE. + END IF + IF (.NOT.DOIT) THEN + DO 10 L=1,NQ + CALL DZERO(N,1,FJACB(1,K,L),N) + 10 CONTINUE + ELSE + BETAK = BETA(K) + IF (BETAK.EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(K) + END IF + ELSE + TYPJ = ABS(BETAK) + END IF + WRK3(K) = BETAK + + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(1,NETA,1,K,STPB,1) + WRK3(K) = WRK3(K) - BETAK + + BETA(K) = BETAK + WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 30 L=1,NQ + DO 20 I=1,N + FJACB(I,K,L) = WRK2(I,L) + 20 CONTINUE + 30 CONTINUE + END IF + + BETA(K) = BETAK - WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + + DO 50 L=1,NQ + DO 40 I=1,N + FJACB(I,K,L) = (FJACB(I,K,L)-WRK2(I,L))/(2*WRK3(K)) + 40 CONTINUE + 50 CONTINUE + BETA(K) = BETAK + END IF + 60 CONTINUE + +C COMPUTE THE JACOBIAN WRT THE X'S + + IF (ISODR) THEN + DO 220 J=1,M + IF (IFIXX(1,1).LT.0) THEN + DOIT = .TRUE. + SETZRO = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + SETZRO = .FALSE. + ELSE + DOIT = .FALSE. + SETZRO = .FALSE. + DO 100 I=1,N + IF (IFIXX(I,J).NE.0) THEN + DOIT = .TRUE. + ELSE + SETZRO = .TRUE. + END IF + 100 CONTINUE + END IF + IF (.NOT.DOIT) THEN + DO 110 L=1,NQ + CALL DZERO(N,1,FJACD(1,J,L),N) + 110 CONTINUE + ELSE + DO 120 I=1,N + IF (XPLUSD(I,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(I,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(I,J)) + END IF + STP(I) = XPLUSD(I,J) + + + SIGN(ONE,XPLUSD(I,J)) + + *TYPJ*DHSTEP(1,NETA,I,J,STPD,LDSTPD) + STP(I) = STP(I) - XPLUSD(I,J) + XPLUSD(I,J) = XPLUSD(I,J) + STP(I) + 120 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 140 L=1,NQ + DO 130 I=1,N + FJACD(I,J,L) = WRK2(I,L) + 130 CONTINUE + 140 CONTINUE + END IF + + DO 150 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) - STP(I) + 150 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + + IF (SETZRO) THEN + DO 180 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + DO 160 L=1,NQ + FJACD(I,J,L) = ZERO + 160 CONTINUE + ELSE + DO 170 L=1,NQ + FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + + (2*STP(I)) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE + DO 200 L=1,NQ + DO 190 I=1,N + FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + + (2*STP(I)) + 190 CONTINUE + 200 CONTINUE + END IF + DO 210 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) + 210 CONTINUE + END IF + 220 CONTINUE + END IF + + RETURN + END +*DJACFD + SUBROUTINE DJACFD + + (FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) +C***BEGIN PROLOGUE DJACFD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE FORWARD DIFFERENCE APPROXIMATIONS TO THE +C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS +C***END PROLOGUE DJACFD + +C...SCALAR ARGUMENTS + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ), + + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + + X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAK,ONE,TYPJ,ZERO + INTEGER + + I,J,K,L + LOGICAL + + DOIT,SETZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAK: THE K-TH FUNCTION PARAMETER. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A +C GIVEN BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) +C OR NOT (DOIT=FALSE). +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME +C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT +C (SETZRO=FALSE). +C SSF: THE SCALE USED FOR THE BETA'S. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJACFD + + +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS + + DO 40 K=1,NP + IF (IFIXB(1).GE.0) THEN + IF (IFIXB(K).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + ELSE + DOIT = .TRUE. + END IF + IF (.NOT.DOIT) THEN + DO 10 L=1,NQ + CALL DZERO(N,1,FJACB(1,K,L),N) + 10 CONTINUE + ELSE + BETAK = BETA(K) + IF (BETAK.EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(K) + END IF + ELSE + TYPJ = ABS(BETAK) + END IF + WRK3(K) = BETAK + + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(0,NETA,1,K,STPB,1) + WRK3(K) = WRK3(K) - BETAK + BETA(K) = BETAK + WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + DO 30 L=1,NQ + DO 20 I=1,N + FJACB(I,K,L) = (WRK2(I,L)-FN(I,L))/WRK3(K) + 20 CONTINUE + 30 CONTINUE + BETA(K) = BETAK + END IF + 40 CONTINUE + +C COMPUTE THE JACOBIAN WRT THE X'S + + IF (ISODR) THEN + DO 220 J=1,M + IF (IFIXX(1,1).LT.0) THEN + DOIT = .TRUE. + SETZRO = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + SETZRO = .FALSE. + ELSE + DOIT = .FALSE. + SETZRO = .FALSE. + DO 100 I=1,N + IF (IFIXX(I,J).NE.0) THEN + DOIT = .TRUE. + ELSE + SETZRO = .TRUE. + END IF + 100 CONTINUE + END IF + IF (.NOT.DOIT) THEN + DO 110 L=1,NQ + CALL DZERO(N,1,FJACD(1,J,L),N) + 110 CONTINUE + ELSE + DO 120 I=1,N + IF (XPLUSD(I,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(I,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(I,J)) + END IF + + STP(I) = XPLUSD(I,J) + + + SIGN(ONE,XPLUSD(I,J)) + + *TYPJ*DHSTEP(0,NETA,I,J,STPD,LDSTPD) + STP(I) = STP(I) - XPLUSD(I,J) + XPLUSD(I,J) = XPLUSD(I,J) + STP(I) + 120 CONTINUE + + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 140 L=1,NQ + DO 130 I=1,N + FJACD(I,J,L) = WRK2(I,L) + 130 CONTINUE + 140 CONTINUE + + END IF + + IF (SETZRO) THEN + DO 180 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + DO 160 L=1,NQ + FJACD(I,J,L) = ZERO + 160 CONTINUE + ELSE + DO 170 L=1,NQ + FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE + DO 200 L=1,NQ + DO 190 I=1,N + FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) + 190 CONTINUE + 200 CONTINUE + END IF + DO 210 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) + 210 CONTINUE + END IF + 220 CONTINUE + END IF + + RETURN + END +*DJCK + SUBROUTINE DJCK + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + + SSF,TT,LDTT, + + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + + PV0,FJACB,FJACD, + + MSGB,MSGD,DIFF,ISTOP,NFEV,NJEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DJCKM +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS +C (ADAPTED FROM STARPAC SUBROUTINE DCKCNT) +C***END PROLOGUE DJCK + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSMAC,ETA + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT, + + M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + PV0(N,NQ),SSF(NP),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(1+NQ*NP),MSGD(1+NQ*M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO + INTEGER + + IDEVAL,J,LQ,MSGB1,MSGD1 + LOGICAL + + ISFIXD,ISWRTB + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKM + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,INT,LOG10 + +C...DATA STATEMENTS + DATA + + ZERO,P5,ONE + + /0.0D0,0.5D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE +C PERFORMED BY USER SUPPLIED SUBROUTINE FCN. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISFIXD: THE VARIABLE DESIGNATING WHETHER THE PARAMETER IS FIXED +C (ISFIXD=TRUE) OR NOT (ISFIXD=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA (ISWRTB=FALSE) ARE BEING CHECKED. +C J: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER +C SET BY THE USER OR COMPUTED BY DETAF. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. +C ONE: THE VALUE 1.0D0. +C P5: THE VALUE 0.5D0. +C PV: THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR +C ROW NROW IS STORED. +C PV0: THE PREDICTED VALUES USING THE CURRENT PARAMETER ESTIMATES. +C SSF: THE SCALING VALUES USED FOR BETA. +C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. +C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. +C TOL: THE AGREEMENT TOLERANCE. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCK + + +C SET TOLERANCE FOR CHECKING DERIVATIVES + + TOL = ETA**(0.25D0) + NTOL = MAX(ONE,P5-LOG10(TOL)) + + +C COMPUTE USER SUPPLIED DERIVATIVE VALUES + + ISTOP = 0 + IF (ISODR) THEN + IDEVAL = 110 + ELSE + IDEVAL = 010 + END IF + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,WRK2,FJACB,FJACD, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV + 1 + END IF + +C CHECK DERIVATIVES WRT BETA FOR EACH RESPONSE OF OBSERVATION NROW + + MSGB1 = 0 + MSGD1 = 0 + + DO 30 LQ=1,NQ + +C SET PREDICTED VALUE OF MODEL AT CURRENT PARAMETER ESTIMATES + PV = PV0(NROW,LQ) + + ISWRTB = .TRUE. + DO 10 J=1,NP + + IF (IFIXB(1).LT.0) THEN + ISFIXD = .FALSE. + ELSE IF (IFIXB(J).EQ.0) THEN + ISFIXD = .TRUE. + ELSE + ISFIXD = .FALSE. + END IF + + IF (ISFIXD) THEN + MSGB(1+LQ+(J-1)*NQ) = -1 + ELSE + IF (BETA(J).EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(J) + END IF + ELSE + TYPJ = ABS(BETA(J)) + END IF + + H0 = DHSTEP(0,NETA,1,J,STPB,1) + HC0 = H0 + +C CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW + + CALL DJCKM(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,FJACB(NROW,J,LQ), + + DIFFJ,MSGB1,MSGB(2),ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + MSGB(1) = -1 + RETURN + ELSE + DIFF(LQ,J) = DIFFJ + END IF + END IF + + 10 CONTINUE + +C CHECK DERIVATIVES WRT X FOR EACH RESPONSE OF OBSERVATION NROW + + IF (ISODR) THEN + ISWRTB = .FALSE. + DO 20 J=1,M + + IF (IFIXX(1,1).LT.0) THEN + ISFIXD = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + ISFIXD = .TRUE. + ELSE + ISFIXD = .FALSE. + END IF + ELSE + ISFIXD = .FALSE. + END IF + + IF (ISFIXD) THEN + MSGD(1+LQ+(J-1)*NQ) = -1 + ELSE + + IF (XPLUSD(NROW,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(NROW,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(NROW,J)) + END IF + + H0 = DHSTEP(0,NETA,NROW,J,STPD,LDSTPD) + HC0 = DHSTEP(1,NETA,NROW,J,STPD,LDSTPD) + +C CHECK DERIVATIVE WRT THE J-TH COLUMN OF DELTA AT ROW NROW + + CALL DJCKM(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,FJACD(NROW,J,LQ), + + DIFFJ,MSGD1,MSGD(2),ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + MSGD(1) = -1 + RETURN + ELSE + DIFF(LQ,NP+J) = DIFFJ + END IF + END IF + + 20 CONTINUE + END IF + 30 CONTINUE + MSGB(1) = MSGB1 + MSGD(1) = MSGD1 + + RETURN + END +*DJCKC + SUBROUTINE DJCKC + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + + FD,TYPJ,PVPSTP,STP0, + + PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DJCKF,DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE +C DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKCRV) +C***END PROLOGUE DJCKC + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,ETA,FD,HC,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKF,DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SIGN + +C...DATA STATEMENTS + DATA + + P01,ONE,TWO,TEN + + /0.01D0,1.0D0,2.0D0,10.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE MODEL +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C HC: THE RELATIVE STEP SIZE FOR CENTRAL FINITE DIFFERENCES. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE OF THE MODEL FOR ROW NROW . +C PVMCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV. +C PVPCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV. +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P01: THE VALUE 0.01D0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C STP: A STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C STPCRV: THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL. +C TEN: THE VALUE 10.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TWO: THE VALUE 2.0D0. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DJCKC + + + IF (ISWRTB) THEN + +C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT BETA + + STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STPCRV, + + ISTOP,NFEV,PVPCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STPCRV, + + ISTOP,NFEV,PVMCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + ELSE + +C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT DELTA + + STPCRV = (HC*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STPCRV, + + ISTOP,NFEV,PVPCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STPCRV, + + ISTOP,NFEV,PVMCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + END IF + +C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL + + CURVE = ABS((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV) + CURVE = CURVE + + + ETA*(ABS(PVPCRV)+ABS(PVMCRV)+TWO*ABS(PV)) / (STPCRV**2) + + +C CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT. + CALL DJCKF(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,J,LQ,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + IF (MSG(LQ,J).EQ.0) THEN + RETURN + END IF + +C CHECK IF HIGH CURVATURE COULD BE THE PROBLEM. + + STP = TWO*MAX(TOL*ABS(D)/CURVE,EPSMAC) + IF (STP.LT.ABS(TEN*STP0)) THEN + STP = MIN(STP,P01*ABS(STP0)) + END IF + + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + STP = (STP*SIGN(ONE,BETA(J)) + BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + END IF + +C COMPUTE THE NEW NUMERICAL DERIVATIVE + + FD = (PVPSTP-PV)/STP + DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) + +C CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK + IF (ABS(FD-D).LE.TOL*ABS(D)) THEN + MSG(LQ,J) = 0 + +C CHECK IF FINITE PRECISION MAY BE THE CULPRIT (FUDGE FACTOR = 2) + ELSE IF (ABS(STP*(FD-D)).LT.TWO*ETA*(ABS(PV)+ABS(PVPSTP)) + + + CURVE*(EPSMAC*TYPJ)**2) THEN + MSG(LQ,J) = 5 + END IF + + RETURN + END +*DJCKF + SUBROUTINE DJCKF + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,J,LQ,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE +C CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKFPA) +C***END PROLOGUE DJCKF + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + CURVE,D,DIFFJ,ETA,FD,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + HUNDRD,ONE,P1,STP,TWO + LOGICAL + + LARGE + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SIGN + +C...DATA STATEMENTS + DATA + + P1,ONE,TWO,HUNDRD + + /0.1D0,1.0D0,2.0D0,100.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C ETA: THE RELATIVE NOISE IN THE MODEL +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C HUNDRD: THE VALUE 100.0D0. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LARGE: THE VALUE DESIGNATING WHETHER THE RECOMMENDED INCREASE IN +C THE STEP SIZE WOULD BE GREATER THAN TYPJ. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FOR ROW NROW . +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P1: THE VALUE 0.1D0. +C STP0: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TOL: THE AGREEMENT TOLERANCE. +C TWO: THE VALUE 2.0D0. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DJCKF + + +C FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM. +C TRY A LARGER STEP SIZE BASED ON ESTIMATE OF CONDITION ERROR + + STP = ETA*(ABS(PV)+ABS(PVPSTP))/(TOL*ABS(D)) + IF (STP.GT.ABS(P1*STP0)) THEN + STP = MAX(STP,HUNDRD*ABS(STP0)) + END IF + IF (STP.GT.TYPJ) THEN + STP = TYPJ + LARGE = .TRUE. + ELSE + LARGE = .FALSE. + END IF + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + STP = (STP*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + FD = (PVPSTP-PV)/STP + DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) + +C CHECK FOR AGREEMENT + + IF ((ABS(FD-D)).LE.TOL*ABS(D)) THEN +C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE. + MSG(LQ,J) = 0 + + ELSE IF ((ABS(FD-D).LE.ABS(TWO*CURVE*STP)) .OR. LARGE) THEN +C CURVATURE MAY BE THE CULPRIT (FUDGE FACTOR = 2) + IF (LARGE) THEN + MSG(LQ,J) = 4 + ELSE + MSG(LQ,J) = 5 + END IF + END IF + + RETURN + END +*DJCKM + SUBROUTINE DJCKM + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,D, + + DIFFJ,MSG1,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKM +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DJCKC,DJCKZ,DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK USER SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL +C DERIVATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKMN) +C***END PROLOGUE DJCKM + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,ETA,H0,HC0,PV,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,MSG1,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0, + + TEN,THREE,TOL2,TWO,ZERO + INTEGER + + I + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKC,DJCKZ,DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD + + /0.0D0,0.01D0,0.1D0,1.0D0,2.0D0,3.0D0,1.0D1,1.0D2/ + DATA + + BIG,TOL2 + + /1.0D19,5.0D-2/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BIG: A BIG VALUE, USED TO INITIALIZE DIFFJ. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C H: THE RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C H1: THE DEFAULT RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C HC: THE RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HC1: THE DEFAULT RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HUNDRD: THE VALUE 100.0D0. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTAS (ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C MSG1: THE ERROR CHECKING RESULTS SUMMARY. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE JTH +C PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P01: THE VALUE 0.01D0. +C P1: THE VALUE 0.1D0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TEN: THE VALUE 10.0D0. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TOL2: A MINIMUM AGREEMENT TOLERANCE. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCKM + + +C CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE +C QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES + + H1 = SQRT(ETA) + HC1 = ETA**(ONE/THREE) + + MSG(LQ,J) = 7 + DIFFJ = BIG + + DO 10 I=1,3 + + IF (I.EQ.1) THEN +C TRY INITIAL RELATIVE STEP SIZE + H = H0 + HC = HC0 + + ELSE IF (I.EQ.2) THEN +C TRY LARGER RELATIVE STEP SIZE + H = MAX(TEN*H1, MIN(HUNDRD*H0, ONE)) + HC = MAX(TEN*HC1,MIN(HUNDRD*HC0,ONE)) + + ELSE IF (I.EQ.3) THEN +C TRY SMALLER RELATIVE STEP SIZE + H = MIN(P1*H1, MAX(P01*H,TWO*EPSMAC)) + HC = MIN(P1*HC1,MAX(P01*HC,TWO*EPSMAC)) + END IF + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + + STP0 = (H*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP0, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + + STP0 = (H*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) + + - XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP0, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + FD = (PVPSTP-PV)/STP0 + +C CHECK FOR AGREEMENT + + IF (ABS(FD-D).LE.TOL*ABS(D)) THEN +C NUMERICAL AND ANALYTIC DERIVATIVES AGREE + +C SET RELATIVE DIFFERENCE FOR DERIVATIVE CHECKING REPORT + IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN + DIFFJ = ABS(FD-D) + ELSE + DIFFJ = ABS(FD-D)/ABS(D) + END IF + +C SET MSG FLAG. + IF (D.EQ.ZERO) THEN + +C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH ZERO. + MSG(LQ,J) = 1 + + ELSE +C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH NONZERO. + MSG(LQ,J) = 0 + END IF + + ELSE + +C NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE. CHECK WHY + IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN + CALL DJCKZ(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,EPSMAC,J,LQ,ISWRTB, + + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + ELSE + CALL DJCKC(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + END IF + IF (MSG(LQ,J).LE.2) THEN + GO TO 20 + END IF + END IF + 10 CONTINUE + +C SET SUMMARY FLAG TO INDICATE QUESTIONABLE RESULTS + 20 CONTINUE + IF ((MSG(LQ,J).GE.7) .AND. (DIFFJ.LE.TOL2)) MSG(LQ,J) = 6 + IF ((MSG(LQ,J).GE.1) .AND. (MSG(LQ,J).LE.6)) THEN + MSG1 = MAX(MSG1,1) + ELSE IF (MSG(LQ,J).GE.7) THEN + MSG1 = 2 + END IF + + RETURN + END +*DJCKZ + SUBROUTINE DJCKZ + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,EPSMAC,J,LQ,ISWRTB, + + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKZ +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE +C DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC +C DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO +C (ADAPTED FROM STARPAC SUBROUTINE DCKZRO) +C***END PROLOGUE DJCKZ + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,FD,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CD,ONE,PVMSTP,THREE,TWO,ZERO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TWO,THREE + + /0.0D0,1.0D0,2.0D0,3.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CD: THE CENTRAL DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . +C PVMSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) - STP0. +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCKZ + + +C RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP +C SIZE OF 2*STP0 + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STP0, + + ISTOP,NFEV,PVMSTP, + + WRK1,WRK2,WRK6) + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STP0, + + ISTOP,NFEV,PVMSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + CD = (PVPSTP-PVMSTP)/(TWO*STP0) + DIFFJ = MIN(ABS(CD-D),ABS(FD-D)) + +C CHECK FOR AGREEMENT + + IF (DIFFJ.LE.TOL*ABS(D)) THEN + +C FINITE DIFFERENCE AND ANALYTIC DERIVATIVES NOW AGREE. + IF (D.EQ.ZERO) THEN + MSG(LQ,J) = 1 + ELSE + MSG(LQ,J) = 0 + END IF + + ELSE IF (DIFFJ*TYPJ.LE.ABS(PV*EPSMAC**(ONE/THREE))) THEN +C DERIVATIVES ARE BOTH CLOSE TO ZERO + MSG(LQ,J) = 2 + + ELSE +C DERIVATIVES ARE NOT BOTH CLOSE TO ZERO + MSG(LQ,J) = 3 + END IF + + RETURN + END +*DODCHK + SUBROUTINE DODCHK + + (N,M,NP,NQ, + + ISODR,ANAJAC,IMPLCT, + + IFIXB, + + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LDY, + + LWORK,LWKMN,LIWORK,LIWKMN, + + SCLB,SCLD,STPB,STPD, + + INFO) +C***BEGIN PROLOGUE DODCHK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING +C NONZERO VALUES OF ARGUMENT INFO +C***END PROLOGUE DODCHK + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWKMN,LIWORK,LWKMN,LWORK,M,N,NP,NQ + LOGICAL + + ANAJAC,IMPLCT,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M) + INTEGER + + IFIXB(NP) + +C...LOCAL SCALARS + INTEGER + + I,J,K,LAST,NPP + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY X. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUE FOR DELTA. +C STPB: THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT BETA. +C STPD: THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODCHK + + +C FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED + + IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN + NPP = NP + ELSE + NPP = 0 + DO 10 K=1,NP + IF (IFIXB(K).NE.0) THEN + NPP = NPP + 1 + END IF + 10 CONTINUE + END IF + +C CHECK PROBLEM SPECIFICATION PARAMETERS + + IF (N.LE.0 .OR. + + M.LE.0 .OR. + + (NPP.LE.0 .OR. NPP.GT.N) .OR. + + (NQ.LE.0)) THEN + + INFO = 10000 + IF (N.LE.0) THEN + INFO = INFO + 1000 + END IF + IF (M.LE.0) THEN + INFO = INFO + 100 + END IF + IF (NPP.LE.0 .OR. NPP.GT.N) THEN + INFO = INFO + 10 + END IF + IF (NQ.LE.0) THEN + INFO = INFO + 1 + END IF + + RETURN + + END IF + +C CHECK DIMENSION SPECIFICATION PARAMETERS + + IF ((.NOT.IMPLCT .AND. LDY.LT.N) .OR. + + (LDX.LT.N) .OR. + + (LDWE.NE.1 .AND. LDWE.LT.N) .OR. + + (LD2WE.NE.1 .AND. LD2WE.LT.NQ) .OR. + + (ISODR .AND. (LDWD.NE.1 .AND. LDWD.LT.N)) .OR. + + (ISODR .AND. (LD2WD.NE.1 .AND. LD2WD.LT.M)) .OR. + + (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) .OR. + + (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) .OR. + + (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) .OR. + + (LWORK.LT.LWKMN) .OR. + + (LIWORK.LT.LIWKMN)) THEN + + INFO = 20000 + IF (.NOT.IMPLCT .AND. LDY.LT.N) THEN + INFO = INFO + 1000 + END IF + IF (LDX.LT.N) THEN + INFO = INFO + 2000 + END IF + + IF ((LDWE.NE.1 .AND. LDWE.LT.N) .OR. + + (LD2WE.NE.1 .AND. LD2WE.LT.NQ)) THEN + INFO = INFO + 100 + END IF + IF (ISODR .AND. ((LDWD.NE.1 .AND. LDWD.LT.N) .OR. + + (LD2WD.NE.1 .AND. LD2WD.LT.M))) THEN + INFO = INFO + 200 + END IF + + IF (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) THEN + INFO = INFO + 10 + END IF + IF (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) THEN + INFO = INFO + 20 + END IF + IF (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) THEN + INFO = INFO + 40 + END IF + + IF (LWORK.LT.LWKMN) THEN + INFO = INFO + 1 + END IF + IF (LIWORK.LT.LIWKMN) THEN + INFO = INFO + 2 + END IF + RETURN + + END IF + +C CHECK DELTA SCALING + + IF (ISODR .AND. SCLD(1,1).GT.0) THEN + IF (LDSCLD.GE.N) THEN + LAST = N + ELSE + LAST = 1 + END IF + DO 120 J=1,M + DO 110 I=1,LAST + IF (SCLD(I,J).LE.0) THEN + INFO = 30200 + GO TO 130 + END IF + 110 CONTINUE + 120 CONTINUE + END IF + 130 CONTINUE + +C CHECK BETA SCALING + + IF (SCLB(1).GT.0) THEN + DO 210 K=1,NP + IF (SCLB(K).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 30100 + ELSE + INFO = INFO + 100 + END IF + GO TO 220 + END IF + 210 CONTINUE + END IF + 220 CONTINUE + +C CHECK DELTA FINITE DIFFERENCE STEP SIZES + + IF (ANAJAC .AND. ISODR .AND. STPD(1,1).GT.0) THEN + IF (LDSTPD.GE.N) THEN + LAST = N + ELSE + LAST = 1 + END IF + DO 320 J=1,M + DO 310 I=1,LAST + IF (STPD(I,J).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 32000 + ELSE + INFO = INFO + 2000 + END IF + GO TO 330 + END IF + 310 CONTINUE + 320 CONTINUE + END IF + 330 CONTINUE + +C CHECK BETA FINITE DIFFERENCE STEP SIZES + + IF (ANAJAC .AND. STPB(1).GT.0) THEN + DO 410 K=1,NP + IF (STPB(K).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 31000 + ELSE + INFO = INFO + 1000 + END IF + GO TO 420 + END IF + 410 CONTINUE + END IF + 420 CONTINUE + + RETURN + END +*DODCNT + SUBROUTINE DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) +C***BEGIN PROLOGUE DODCNT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DODDRV +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION +C***END PROLOGUE DODCNT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ + LOGICAL + + SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CNVTOL,ONE,PCHECK,PFAC,PSTART,THREE,TSTIMP,ZERO + INTEGER + + IPRNTI,IPR1,IPR2,IPR2F,IPR3,JOBI,JOB1,JOB2,JOB3,JOB4,JOB5, + + MAXITI,MAXIT1 + LOGICAL + + DONE,FSTITR,HEAD,IMPLCT,PRTPEN + +C...LOCAL ARRAYS + DOUBLE PRECISION + + PNLTY(1,1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODDRV + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DMPREC + EXTERNAL + + DMPREC + +C...DATA STATEMENTS + DATA + + PCHECK,PSTART,PFAC,ZERO,ONE,THREE + + /1.0D3,1.0D1,1.0D1,0.0D0,1.0D0,3.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CNVTOL: THE CONVERGENCE TOLERANCE FOR IMPLICIT MODELS. +C DONE: THE VARIABLE DESIGNATING WHETHER THE INPLICIT SOLUTION HAS +C BEEN FOUND (DONE=TRUE) OR NOT (DONE=FALSE). +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLES. +C IPRNTI: THE PRINT CONTROL VARIABLES. +C IPR1: THE 1ST DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR2: THE 2ND DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR3: THE 3RD DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR4: THE 4TH DIGIT OF THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOB1: THE 1ST DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB2: THE 2ND DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB3: THE 3RD DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB4: THE 4TH DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB5: THE 5TH DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR +C THE CURRENT PENALTY PARAMETER VALUE. +C MAXIT1: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR +C THE NEXT PENALTY PARAMETER VALUE. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C ONE: THE VALUE 1.0D0. +C PARTOL: THE USER SUPPLIED PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PCHECK: THE VALUE DESIGNATING THE MINIMUM PENALTY PARAMETER ALLOWED +C BEFORE THE IMPLICIT PROBLEM CAN BE CONSIDERED SOLVED. +C PFAC: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO BE +C PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C PSTART: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C THREE: THE VALUE 3.0D0. +C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL +C VALUES AND THE SOLUTION. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE INDEPENDENT VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODCNT + + + IMPLCT = MOD(JOB,10).EQ.1 + FSTITR = .TRUE. + HEAD = .TRUE. + PRTPEN = .FALSE. + + IF (IMPLCT) THEN + +C SET UP FOR IMPLICIT PROBLEM + + IF (IPRINT.GE.0) THEN + IPR1 = MOD(IPRINT,10000)/1000 + IPR2 = MOD(IPRINT,1000)/100 + IPR2F = MOD(IPRINT,100)/10 + IPR3 = MOD(IPRINT,10) + ELSE + IPR1 = 2 + IPR2 = 0 + IPR2F = 0 + IPR3 = 1 + END IF + IPRNTI = IPR1*1000 + IPR2*100 + IPR2F*10 + + JOB5 = MOD(JOB,100000)/10000 + JOB4 = MOD(JOB,10000)/1000 + JOB3 = MOD(JOB,1000)/100 + JOB2 = MOD(JOB,100)/10 + JOB1 = MOD(JOB,10) + JOBI = JOB5*10000 + JOB4*1000 + JOB3*100 + JOB2*10 + JOB1 + + IF (WE(1,1,1).LE.ZERO) THEN + PNLTY(1,1,1) = -PSTART + ELSE + PNLTY(1,1,1) = -WE(1,1,1) + END IF + + IF (PARTOL.LT.ZERO) THEN + CNVTOL = DMPREC()**(ONE/THREE) + ELSE + CNVTOL = MIN(PARTOL,ONE) + END IF + + IF (MAXIT.GE.1) THEN + MAXITI = MAXIT + ELSE + MAXITI = 100 + END IF + + DONE = MAXITI.EQ.0 + PRTPEN = .TRUE. + + 10 CONTINUE + CALL DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + PNLTY,1,1,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOBI,NDIGIT,TAUFAC, SSTOL,CNVTOL,MAXITI, + + IPRNTI,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + MAXIT1,TSTIMP, INFO) + + IF (DONE) THEN + RETURN + ELSE + DONE = MAXIT1.LE.0 .OR. + + (ABS(PNLTY(1,1,1)).GE.PCHECK .AND. + + TSTIMP.LE.CNVTOL) + END IF + + IF (DONE) THEN + IF (TSTIMP.LE.CNVTOL) THEN + INFO = (INFO/10)*10 + 2 + ELSE + INFO = (INFO/10)*10 + 4 + END IF + JOBI = 10000 + 1000 + JOB3*100 + JOB2*10 + JOB1 + MAXITI = 0 + IPRNTI = IPR3 + ELSE + PRTPEN = .TRUE. + PNLTY(1,1,1) = PFAC*PNLTY(1,1,1) + JOBI = 10000 + 1000 + 000 + JOB2*10 + JOB1 + MAXITI = MAXIT1 + IPRNTI = 0000 + IPR2*100 + IPR2F*10 + END IF + GO TO 10 + ELSE + CALL DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + MAXIT1,TSTIMP, INFO) + END IF + + RETURN + + END +*DODDRV + SUBROUTINE DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + MAXIT1,TSTIMP, INFO) +C***BEGIN PROLOGUE DODDRV +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DCOPY,DDOT,DETAF,DFCTRW,DFLAGS, +C DINIWK,DIWINF,DJCK,DNRM2,DODCHK,DODMN, +C DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN +C PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION +C (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) +C***END PROLOGUE DODDRV + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC,TSTIMP + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,MAXIT1, + + N,NDIGIT,NP,NQ + LOGICAL + + FSTITR,HEAD,PRTPEN,SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WE(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + EPSMAC,ETA,P5,ONE,TEN,ZERO + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + + DIFFI,EPSMAI,ETAI,FI,FJACBI,FJACDI,FNI,FSI,I,IDFI,INT2I,IPRINI, + + IRANKI,ISTOP,ISTOPI,JOBI,JPVTI,K,LDTT,LDTTI,LIWKMN, + + LUNERI,LUNRPI,LWKMN,LWRK,MAXITI,MSGB,MSGD,NETA,NETAI, + + NFEV,NFEVI,NITERI,NJEV,NJEVI,NNZW,NNZWI,NPP,NPPI,NROW,NROWI, + + NTOL,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,WRK, + + WSSI,WSSDEI,WSSEPI,XPLUSI + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT,DNRM2 + EXTERNAL + + DDOT,DNRM2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY,DETAF,DFCTRW,DFLAGS,DINIWK,DIWINF,DJCK,DODCHK, + + DODMN,DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY + +C...DATA STATEMENTS + DATA + + ZERO,P5,ONE,TEN + + /0.0D0,0.5D0,1.0D0,10.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY F. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C I: AN INDEX VARIABLE. +C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C INT2I: THE IN ARRAY IWORK OF VARIABLE INT2. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY JPVT. +C K: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXIT1: FOR IMPLICIT MODELS, THE ITERATIONS ALLOWED FOR THE NEXT +C PENALTY PARAMETER VALUE. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, +C SET BY DJCK. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C ONE: THE VALUE 1.0D0. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C P5: THE VALUE 0.5D0. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-CALL +C (SHORT=FALSE). +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. +C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TEN: THE VALUE 10.0D0. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL +C VALUES AND THE SOLUTION. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WRK: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. +C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. +C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. +C X: THE EXPLANATORY VARIABLE. +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODDRV + + +C INITIALIZE NECESSARY VARIABLES + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + +C SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE +C (INVALID VALUES OF M, NP AND/OR NQ ARE HANDLED REASONABLY BY DIWINF) + + CALL DIWINF(M,NP,NQ, + + MSGB,MSGD,JPVTI,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) + +C SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE +C (INVALID VALUES OF N, M, NP, NQ, LDWE AND/OR LD2WE +C ARE HANDLED REASONABLY BY DWINF) + + CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,FI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) + IF (ISODR) THEN + WRK = WRK1I + LWRK = N*M*NQ + N*NQ + ELSE + WRK = WRK2I + LWRK = N*NQ + END IF + +C UPDATE THE PENALTY PARAMETERS +C (WE(1,1,1) IS NOT A USER SUPPLIED ARRAY IN THIS CASE) + IF (RESTRT .AND. IMPLCT) THEN + WE(1,1,1) = MAX(WORK(WE1I)**2,ABS(WE(1,1,1))) + WORK(WE1I) = -SQRT(ABS(WE(1,1,1))) + END IF + + IF (RESTRT) THEN + +C RESET MAXIMUM NUMBER OF ITERATIONS + + IF (MAXIT.GE.0) THEN + IWORK(MAXITI) = IWORK(NITERI) + MAXIT + ELSE + IWORK(MAXITI) = IWORK(NITERI) + 10 + END IF + + IF (IWORK(NITERI).LT.IWORK(MAXITI)) THEN + INFO = 0 + END IF + + IF (JOB.GE.0) IWORK(JOBI) = JOB + IF (IPRINT.GE.0) IWORK(IPRINI) = IPRINT + IF (PARTOL.GE.ZERO .AND. PARTOL.LT.ONE) WORK(PARTLI) = PARTOL + IF (SSTOL.GE.ZERO .AND. SSTOL.LT.ONE) WORK(SSTOLI) = SSTOL + + WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI) + + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) + ELSE + CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) + END IF + CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) + WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) + WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) + + ELSE + +C PERFORM ERROR CHECKING + + INFO = 0 + + CALL DODCHK(N,M,NP,NQ, + + ISODR,ANAJAC,IMPLCT, + + IFIXB, + + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LDY, + + LWORK,LWKMN,LIWORK,LIWKMN, + + SCLB,SCLD,STPB,STPD, + + INFO) + IF (INFO.GT.0) THEN + GO TO 50 + END IF + +C INITIALIZE WORK VECTORS AS NECESSARY + + DO 10 I=N*M+N*NQ+1,LWORK + WORK(I) = ZERO + 10 CONTINUE + DO 20 I=1,LIWORK + IWORK(I) = 0 + 20 CONTINUE + + CALL DINIWK(N,M,NP, + + WORK,LWORK,IWORK,LIWORK, + + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + + BETA,SCLB, + + SSTOL,PARTOL,MAXIT,TAUFAC, + + JOB,IPRINT,LUNERR,LUNRPT, + + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + SSFI,TTI,LDTTI,DELTAI) + + IWORK(MSGB) = -1 + IWORK(MSGD) = -1 + WORK(TAUI) = -WORK(TAUFCI) + +C SET UP FOR PARAMETER ESTIMATION - +C PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES +C AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY + + CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB) + CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB) + NPP = IWORK(NPPI) + +C CHECK THAT WD IS POSITIVE DEFINITE AND WE IS POSITIVE SEMIDEFINITE, +C SAVING FACTORIZATION OF WE, AND COUNTING NUMBER OF NONZERO WEIGHTS + + CALL DFCTRW(N,M,NQ,NPP, + + ISODR, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + WORK(WRK2I),WORK(WRK4I), + + WORK(WE1I),NNZW,INFO) + IWORK(NNZWI) = NNZW + + IF (INFO.NE.0) THEN + GO TO 50 + END IF + +C EVALUATE THE PREDICTED VALUES AND +C WEIGHTED EPSILONS AT THE STARTING POINT + + CALL DUNPAC(NP,WORK(BETACI),BETA,IFIXB) + CALL DXPY(N,M,X,LDX,WORK(DELTAI),N,WORK(XPLUSI),N) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,WORK(XPLUSI), + + IFIXB,IFIXX,LDIFX, + + 002,WORK(FNI),WORK(WRK6I),WORK(WRK1I), + + ISTOP) + IWORK(ISTOPI) = ISTOP + IF (ISTOP.EQ.0) THEN + IWORK(NFEVI) = IWORK(NFEVI) + 1 + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) + ELSE + CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) + END IF + CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) + ELSE + INFO = 52000 + GO TO 50 + END IF + +C COMPUTE NORM OF THE INITIAL ESTIMATES + + CALL DWGHT(NPP,1,WORK(SSI),NPP,1,WORK(BETACI),NPP, + + WORK(WRK),NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,WORK(TTI),IWORK(LDTTI),1,WORK(DELTAI),N, + + WORK(WRK+NPP),N) + WORK(PNORMI) = DNRM2(NPP+N*M,WORK(WRK),1) + ELSE + WORK(PNORMI) = DNRM2(NPP,WORK(WRK),1) + END IF + +C COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS + + WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,WORK(DELTAI),N,WORK(WRK),N) + WORK(WSSDEI) = DDOT(N*M,WORK(DELTAI),1,WORK(WRK),1) + ELSE + WORK(WSSDEI) = ZERO + END IF + WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) + +C SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS + + NROW = -1 + CALL DSETN(N,M,WORK(XPLUSI),N,NROW) + IWORK(NROWI) = NROW + +C SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS + + EPSMAC = WORK(EPSMAI) + IF (NDIGIT.LT.2) THEN + IWORK(NETAI) = -1 + NFEV = IWORK(NFEVI) + CALL DETAF(FCN, + + N,M,NP,NQ, + + WORK(XPLUSI),BETA,EPSMAC,NROW, + + WORK(BETANI),WORK(FNI), + + IFIXB,IFIXX,LDIFX, + + ISTOP,NFEV,ETA,NETA, + + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I),WORK(WRK7I)) + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IF (ISTOP.NE.0) THEN + INFO = 53000 + IWORK(NETAI) = 0 + WORK(ETAI) = ZERO + GO TO 50 + ELSE + IWORK(NETAI) = -NETA + WORK(ETAI) = ETA + END IF + ELSE + IWORK(NETAI) = MIN(NDIGIT,INT(P5-LOG10(EPSMAC))) + WORK(ETAI) = MAX(EPSMAC,TEN**(-NDIGIT)) + END IF + +C CHECK DERIVATIVES IF NECESSARY + + IF (CHKJAC .AND. ANAJAC) THEN + NTOL = -1 + NFEV = IWORK(NFEVI) + NJEV = IWORK(NJEVI) + NETA = IWORK(NETAI) + LDTT = IWORK(LDTTI) + ETA = WORK(ETAI) + EPSMAC = WORK(EPSMAI) + CALL DJCK(FCN, + + N,M,NP,NQ, + + BETA,WORK(XPLUSI), + + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + + WORK(SSFI),WORK(TTI),LDTT, + + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + + WORK(FNI),WORK(FJACBI),WORK(FJACDI), + + IWORK(MSGB),IWORK(MSGD),WORK(DIFFI), + + ISTOP,NFEV,NJEV, + + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I)) + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IWORK(NJEVI) = NJEV + IWORK(NTOLI) = NTOL + IF (ISTOP.NE.0) THEN + INFO = 54000 + ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGD).NE.0) THEN + INFO = 40000 + END IF + ELSE + +C INDICATE USER SUPPLIED DERIVATIVES WERE NOT CHECKED + IWORK(MSGB) = -1 + IWORK(MSGD) = -1 + END IF + +C PRINT APPROPRIATE ERROR MESSAGES + + 50 IF ((INFO.NE.0) .OR. (IWORK(MSGB).NE.-1)) THEN + IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN + CALL DODPER + + (INFO,LUNERR,SHORT, + + N,M,NP,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN, + + WORK(FJACBI),WORK(FJACDI), + + WORK(DIFFI),IWORK(MSGB),ISODR,IWORK(MSGD), + + WORK(XPLUSI),IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI)) + END IF + +C SET INFO TO REFLECT ERRORS IN THE USER SUPPLIED JACOBIANS + + IF (INFO.EQ.40000) THEN + IF (IWORK(MSGB).EQ.2 .OR. IWORK(MSGD).EQ.2) THEN + IF (IWORK(MSGB).EQ.2) THEN + INFO = INFO + 1000 + END IF + IF (IWORK(MSGD).EQ.2) THEN + INFO = INFO + 100 + END IF + ELSE + INFO = 0 + END IF + END IF + IF (INFO.NE.0) THEN + RETURN + END IF + END IF + END IF + +C SAVE THE INITIAL VALUES OF BETA + CALL DCOPY(NP,BETA,1,WORK(BETA0I),1) + +C FIND LEAST SQUARES SOLUTION + + CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FSI),1) + LDTT = IWORK(LDTTI) + CALL DODMN(HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + + WE,WORK(WE1I),LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + WORK(BETACI),WORK(BETANI),WORK(BETASI),WORK(SI), + + WORK(DELTAI),WORK(DELTNI),WORK(DELTSI), + + WORK(TI),WORK(FI),WORK(FNI),WORK(FSI), + + WORK(FJACBI),IWORK(MSGB),WORK(FJACDI),IWORK(MSGD), + + WORK(SSFI),WORK(SSI),WORK(TTI),LDTT, + + STPB,STPD,LDSTPD, + + WORK(XPLUSI),WORK(WRK),LWRK, + + WORK,LWORK,IWORK,LIWORK,INFO) + MAXIT1 = IWORK(MAXITI) - IWORK(NITERI) + TSTIMP = ZERO + DO 100 K=1,NP + IF (BETA(K).EQ.ZERO) THEN + TSTIMP = MAX(TSTIMP, + + ABS(BETA(K)-WORK(BETA0I-1+K))/WORK(SSFI-1+K)) + ELSE + TSTIMP = MAX(TSTIMP, + + ABS(BETA(K)-WORK(BETA0I-1+K))/ABS(BETA(K))) + END IF + 100 CONTINUE + + RETURN + + END +*DODLM + SUBROUTINE DODLM + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA2,TAU,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,NLMS,RCOND,IRANK, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODLM +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DDOT,DNRM2,DODSTP,DSCALE,DWGHT +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T +C USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT +C ALGORITHM +C***END PROLOGUE DODLM + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA2,EPSFCN,RCOND,TAU + INTEGER + + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + + WRK(LWRK),WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M) + INTEGER + + JPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO + INTEGER + + I,IWRK,J,K,L + LOGICAL + + FORVCV + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT,DNRM2 + EXTERNAL + + DDOT,DNRM2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODSTP,DSCALE,DWGHT + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P001,P1 + + /0.0D0,0.001D0,0.1D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHAN: THE NEW LEVENBERG-MARQUARDT PARAMETER. +C ALPHA1: THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER. +C ALPHA2: THE CURRENT LEVENBERG-MARQUARDT PARAMETER. +C BOT: THE LOWER LIMIT FOR SETTING ALPHA. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO SOME NUMERICAL ERROR DETECTED WITHIN +C SUBROUTINE DODSTP. +C IWRK: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C JPVT: THE PIVOT VECTOR. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OMEGA: THE ARRAY (I-FJACD*INV(P)*TRANS(FJACD))**(-1/2) WHERE +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C P001: THE VALUE 0.001D0 +C P1: THE VALUE 0.1D0 +C PHI1: THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C PHI2: THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. +C S: THE STEP FOR BETA. +C SA: THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2). +C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. +C T: THE STEP FOR DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TFJACB: THE ARRAY OMEGA*FJACB. +C TOP: THE UPPER LIMIT FOR SETTING ALPHA. +C TT: THE SCALE USED FOR THE DELTA'S. +C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. +C WD: THE DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODLM + + FORVCV = .FALSE. + ISTOPC = 0 + +C COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0) + + ALPHA1 = ZERO + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA1,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,PHI1,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + +C INITIALIZE TAU IF NECESSARY + + IF (TAU.LT.ZERO) THEN + TAU = ABS(TAU)*PHI1 + END IF + +C CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL + + IF ((PHI1-TAU).LE.P1*TAU) THEN + NLMS = 1 + ALPHA2 = ZERO + RETURN + END IF + +C FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION - +C FIND LOCALLY CONSTRAINED OPTIMAL STEP + + PHI1 = PHI1 - TAU + +C INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA + + BOT = ZERO + + DO 30 K=1,NPP + DO 20 L=1,NQ + DO 10 I=1,N + TFJACB(I,L,K) = FJACB(I,K,L) + 10 CONTINUE + 20 CONTINUE + WRK(K) = DDOT(N*NQ,TFJACB(1,1,K),1,F(1,1),1) + 30 CONTINUE + CALL DSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP) + + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(NPP+1),N) + IWRK = NPP + DO 50 J=1,M + DO 40 I=1,N + IWRK = IWRK + 1 + WRK(IWRK) = WRK(IWRK) + + + DDOT(NQ,FJACD(I,J,1),N*M,F(I,1),N) + 40 CONTINUE + 50 CONTINUE + CALL DSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N) + TOP = DNRM2(NPP+N*M,WRK,1)/TAU + ELSE + TOP = DNRM2(NPP,WRK,1)/TAU + END IF + + IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN + ALPHA2 = P001*TOP + END IF + +C MAIN LOOP + + DO 60 I=1,10 + +C COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR +C CURRENT VALUE OF ALPHA + + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA2,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,PHI2,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + PHI2 = PHI2-TAU + +C CHECK WHETHER CURRENT STEP IS OPTIMAL + + IF (ABS(PHI2).LE.P1*TAU .OR. + + (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN + NLMS = I+1 + RETURN + END IF + +C CURRENT STEP IS NOT OPTIMAL + +C UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA + + IF (PHI1-PHI2.EQ.ZERO) THEN + NLMS = 12 + RETURN + END IF + SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2) + IF (PHI2.LT.ZERO) THEN + TOP = MIN(TOP,ALPHA2) + ELSE + BOT = MAX(BOT,ALPHA2) + END IF + IF (PHI1*PHI2.GT.ZERO) THEN + BOT = MAX(BOT,ALPHA2-SA) + ELSE + TOP = MIN(TOP,ALPHA2-SA) + END IF + + ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU + IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN + ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT)) + END IF + +C GET READY FOR NEXT ITERATION + + ALPHA1 = ALPHA2 + ALPHA2 = ALPHAN + PHI1 = PHI2 + 60 CONTINUE + +C SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS + + NLMS = 12 + + RETURN + END +*DODMN + SUBROUTINE DODMN + + (HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + + WE,WE1,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + BETAC,BETAN,BETAS,S,DELTA,DELTAN,DELTAS, + + T,F,FN,FS,FJACB,MSGB,FJACD,MSGD, + + SSF,SS,TT,LDTT,STPB,STPD,LDSTPD, + + XPLUSD,WRK,LWRK,WORK,LWORK,IWORK,LIWORK,INFO) +C***BEGIN PROLOGUE DODMN +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DACCES,DCOPY,DDOT,DEVJAC,DFLAGS,DNRM2,DODLM, +C DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE ITERATIVELY COMPUTE LEAST SQUARES SOLUTION +C***END PROLOGUE DODMN + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWORK,LWORK,LWRK,M,N,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP), + + DELTA(N,M),DELTAN(N,M),DELTAS(N,M), + + F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),FS(N,NQ), + + S(NP),SS(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M), + + T(N,M),TT(LDTT,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ), + + WORK(LWORK),X(LDX,M),XPLUSD(N,M),WRK(LWRK),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK), + + MSGB(NQ*NP+1),MSGD(NQ*M+1) + LOGICAL + + FSTITR,HEAD,PRTPEN + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + ACTRED,ACTRS,ALPHA,DIRDER,ETA,OLMAVG,ONE, + + P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS, + + RATIO,RCOND,RNORM,RNORMN,RNORMS,RSS,RVAR,SSTOL,TAU,TAUFAC, + + TEMP,TEMP1,TEMP2,TSNORM,ZERO + INTEGER + + I,IDF,IFLAG,INT2,IPR,IPR1,IPR2,IPR2F,IPR3,IRANK, + + ISTOP,ISTOPC,IWRK,J,JPVT,L,LOOPED,LUDFLT,LUNR,LUNRPT, + + MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW,NPP,NPR,OMEGA,QRAUX, + + SD,U,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 + LOGICAL + + ACCESS,ANAJAC,CDJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV, + + IMPLCT,INITD,INTDBL,ISODR,LSTEP,REDOJ,RESTRT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + WSS(3) + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT,DNRM2 + EXTERNAL + + DDOT,DNRM2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DACCES,DCOPY,DEVJAC,DFLAGS, + + DODLM,DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN,MOD,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P0001,P1,P25,P5,P75,ONE + + /0.0D0,0.00010D0,0.10D0,0.250D0, + + 0.50D0,0.750D0,1.0D0/ + DATA + + LUDFLT + + /6/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE +C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN +C THEM (ACCESS=FALSE). +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. +C BETAN: THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. +C BETAS: THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C CNVPAR: THE VARIABLE DESIGNATING WHETHER PARAMETER CONVERGENCE WAS +C ATTAINED (CNVPAR=TRUE) OR NOT (CNVPAR=FALSE). +C CNVSS: THE VARIABLE DESIGNATING WHETHER SUM-OF-SQUARES CONVERGENCE +C WAS ATTAINED (CNVSS=TRUE) OR NOT (CNVSS=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DELTAN: THE NEW ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DELTAS: THE SAVED ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DIRDER: THE DIRECTIONAL DERIVATIVE. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX +C SHOULD TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. +C FS: THE SAVED PREDICTED VALUES FROM THE FUNCTION. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFLAG: THE VARIABLE DESIGNATING WHICH REPORT IS TO BE PRINTED. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN. +C INTDBL: THE VARIABLE DESIGNATING WHETHER INTERNAL DOUBLING IS TO BE +C USED (INTDBL=TRUE) OR NOT (INTDBL=FALSE). +C IPR: THE VALUES DESIGNATING THE LENGTH OF THE PRINTED REPORT. +C IPR1: THE VALUE OF THE 4TH DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE INITIAL SUMMARY REPORT. +C IPR2: THE VALUE OF THE 3RD DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE ITERATION REPORT. +C IPR2F: THE VALUE OF THE 2ND DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. +C IPR3: THE VALUE OF THE 1ST DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FINAL SUMMARY REPORT. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO SOME NUMERICAL ERROR WITHIN ROUTINE DODSTP. +C IWORK: THE INTEGER WORK SPACE. +C IWRK: AN INDEX VARIABLE. +C J: AN INDEX VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JPVT: THE STARTING LOCATION IN IWORK OF ARRAY JPVT. +C L: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE AND WE1. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE AND WE1. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LOOPED: A COUNTER USED TO DETERMINE HOW MANY TIMES THE SUBLOOP +C HAS BEEN EXECUTED, WHERE IF THE COUNT BECOMES LARGE +C ENOUGH THE COMPUTATIONS WILL BE STOPPED. +C LSTEP: THE VARIABLE DESIGNATING WHETHER A SUCCESSFUL STEP HAS +C BEEN FOUND (LSTEP=TRUE) OR NOT (LSTEP=FALSE). +C LUDFLT: THE DEFAULT LOGICAL UNIT NUMBER, USED FOR COMPUTATION +C REPORTS TO THE SCREEN. +C LUNR: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS TAKEN. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NPR: THE NUMBER OF TIMES THE REPORT IS TO BE WRITTEN. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER +C ITERATION. +C OMEGA: THE STARTING LOCATION IN WORK OF ARRAY OMEGA. +C ONE: THE VALUE 1.0D0. +C P0001: THE VALUE 0.0001D0. +C P1: THE VALUE 0.1D0. +C P25: THE VALUE 0.25D0. +C P5: THE VALUE 0.5D0. +C P75: THE VALUE 0.75D0. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRERS: THE OLD PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO +C BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RATIO: THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED +C RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORM: THE NORM OF THE WEIGHTED ERRORS. +C RNORMN: THE NEW NORM OF THE WEIGHTED ERRORS. +C RNORMS: THE SAVED NORM OF THE WEIGHTED ERRORS. +C RSS: THE RESIDUAL SUM OF SQUARES. +C RVAR: THE RESIDUAL VARIANCE. +C S: THE STEP FOR BETA. +C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. +C SSF: THE SCALING VALUES USED FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C T: THE STEP FOR DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TEMP: A TEMPORARY STORAGE LOCATION. +C TEMP1: A TEMPORARY STORAGE LOCATION. +C TEMP2: A TEMPORARY STORAGE LOCATION. +C TSNORM: THE NORM OF THE SCALED STEP. +C TT: THE SCALING VALUES USED FOR DELTA. +C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE: THE EPSILON WEIGHTS. +C WE1: THE SQUARE ROOT OF THE EPSILON WEIGHTS. +C WD: THE DELTA WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C WRK: A WORK ARRAY, EQUIVALENCED TO WRK1 AND WRK2 +C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODMN + + +C INITIALIZE NECESSARY VARIABLES + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + ACCESS = .TRUE. + CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) + RNORM = SQRT(WSS(1)) + + DIDVCV = .FALSE. + INTDBL = .FALSE. + LSTEP = .TRUE. + +C PRINT INITIAL SUMMARY IF DESIRED + + IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN + IFLAG = 1 + IF (IPR1.GE.3 .AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR1.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR1,2) + END IF + LUNR = LUNRPT + DO 10 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR1.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 10 CONTINUE + + END IF + +C STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION + + IF (RNORM.EQ.ZERO) THEN + INFO = 1 + OLMAVG = ZERO + ISTOP = 0 + GO TO 150 + END IF + +C STOP IF NUMBER OF ITERATIONS ALREADY EQUALS MAXIMUM PERMITTED + + IF (RESTRT .AND. (NITER.GE.MAXIT)) THEN + ISTOP = 0 + GO TO 150 + ELSE IF (NITER.GE.MAXIT) THEN + INFO = 4 + ISTOP = 0 + GO TO 150 + END IF + +C MAIN LOOP + + 100 CONTINUE + + NITER = NITER + 1 + RNORMS = RNORM + LOOPED = 0 + +C EVALUATE JACOBIAN USING BEST ESTIMATE OF FUNCTION (FS) + + IF ((NITER.EQ.1) .AND. (ANAJAC.AND.CHKJAC)) THEN + ISTOP = 0 + ELSE + CALL DEVJAC(FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FS, + + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) + END IF + IF (ISTOP.NE.0) THEN + INFO = 51000 + GO TO 200 + ELSE IF (INFO.EQ.50300) THEN + GO TO 200 + END IF + +C SUB LOOP FOR +C INTERNAL DOUBLING OR +C COMPUTING NEW STEP WHEN OLD FAILED + + 110 CONTINUE + +C COMPUTE STEPS S AND T + + IF (LOOPED.GT.100) THEN + INFO = 60000 + GO TO 200 + ELSE + LOOPED = LOOPED + 1 + CALL DODLM(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA,TAU,ETA,ISODR, + + WORK(WRK6),WORK(OMEGA), + + WORK(U),WORK(QRAUX),IWORK(JPVT), + + S,T,NLMS,RCOND,IRANK, + + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + + WORK(WRK5),WRK,LWRK,ISTOPC) + END IF + IF (ISTOPC.NE.0) THEN + INFO = ISTOPC + GO TO 200 + END IF + OLMAVG = OLMAVG+NLMS + +C COMPUTE BETAN = BETAC + S +C DELTAN = DELTA + T + + CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP) + IF (ISODR) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N) + +C COMPUTE NORM OF SCALED STEPS S AND T (TSNORM) + + CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) + TSNORM = DNRM2(NPP+N*M,WRK,1) + ELSE + TSNORM = DNRM2(NPP,WRK,1) + END IF + +C COMPUTE SCALED PREDICTED REDUCTION + + IWRK = 0 + DO 130 L=1,NQ + DO 120 I=1,N + IWRK = IWRK + 1 + WRK(IWRK) = DDOT(NPP,FJACB(I,1,L),N,S,1) + IF (ISODR) WRK(IWRK) = WRK(IWRK) + + + DDOT(M,FJACD(I,1,L),N,T(I,1),N) + 120 CONTINUE + 130 CONTINUE + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,T,N,WRK(N*NQ+1),N) + TEMP1 = DDOT(N*NQ,WRK,1,WRK,1) + DDOT(N*M,T,1,WRK(N*NQ+1),1) + TEMP1 = SQRT(TEMP1)/RNORM + ELSE + TEMP1 = DNRM2(N*NQ,WRK,1)/RNORM + END IF + TEMP2 = SQRT(ALPHA)*TSNORM/RNORM + PRERED = TEMP1**2+TEMP2**2/P5 + + DIRDER = -(TEMP1**2+TEMP2**2) + +C EVALUATE PREDICTED VALUES AT NEW POINT + + CALL DUNPAC(NP,BETAN,BETA,IFIXB) + CALL DXPY(N,M,X,LDX,DELTAN,N,XPLUSD,N) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 002,FN,WORK(WRK6),WORK(WRK1), + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + END IF + + IF (ISTOP.LT.0) THEN + +C SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FCN + + INFO = 51000 + GO TO 200 + ELSE IF (ISTOP.GT.0) THEN + +C SET NORM TO INDICATE STEP SHOULD BE REJECTED + + RNORMN = RNORM/(P1*P75) + ELSE + +C COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN) + + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,FN,1,WRK,1) + ELSE + CALL DXMY(N,NQ,FN,N,Y,LDY,WRK,N) + END IF + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,WRK,N,WRK,N) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTAN,N,WRK(N*NQ+1),N) + RNORMN = SQRT(DDOT(N*NQ,WRK,1,WRK,1) + + + DDOT(N*M,DELTAN,1,WRK(N*NQ+1),1)) + ELSE + RNORMN = DNRM2(N*NQ,WRK,1) + END IF + END IF + +C COMPUTE SCALED ACTUAL REDUCTION + + IF (P1*RNORMN.LT.RNORM) THEN + ACTRED = ONE - (RNORMN/RNORM)**2 + ELSE + ACTRED = -ONE + END IF + +C COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION + + IF(PRERED .EQ. ZERO) THEN + RATIO = ZERO + ELSE + RATIO = ACTRED/PRERED + END IF + +C CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE + + IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN + ISTOP = 0 + TAU = TAU*P5 + ALPHA = ALPHA/P5 + CALL DCOPY(NPP,BETAS,1,BETAN,1) + CALL DCOPY(N*M,DELTAS,1,DELTAN,1) + CALL DCOPY(N*NQ,FS,1,FN,1) + ACTRED = ACTRS + PRERED = PRERS + RNORMN = RNORMS + RATIO = P5 + END IF + +C UPDATE STEP BOUND + + INTDBL = .FALSE. + IF (RATIO.LT.P25) THEN + IF (ACTRED.GE.ZERO) THEN + TEMP = P5 + ELSE + TEMP = P5*DIRDER/(DIRDER+P5*ACTRED) + END IF + IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN + TEMP = P1 + END IF + TAU = TEMP*MIN(TAU,TSNORM/P1) + ALPHA = ALPHA/TEMP + + ELSE IF (ALPHA.EQ.ZERO) THEN + TAU = TSNORM/P5 + + ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN + +C STEP QUALIFIES FOR INTERNAL DOUBLING +C - UPDATE TAU AND ALPHA +C - SAVE INFORMATION FOR CURRENT POINT + + INTDBL = .TRUE. + + TAU = TSNORM/P5 + ALPHA = ALPHA*P5 + + CALL DCOPY(NPP,BETAN,1,BETAS,1) + CALL DCOPY(N*M,DELTAN,1,DELTAS,1) + CALL DCOPY(N*NQ,FN,1,FS,1) + ACTRS = ACTRED + PRERS = PRERED + RNORMS = RNORMN + END IF + +C IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS + + IF (INTDBL .AND. TAU.GT.ZERO) THEN + INT2 = INT2+1 + GO TO 110 + END IF + +C CHECK ACCEPTANCE + + IF (RATIO.GE.P0001) THEN + CALL DCOPY(N*NQ,FN,1,FS,1) + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,FS,1,F,1) + ELSE + CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) + END IF + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,F,N) + CALL DCOPY(NPP,BETAN,1,BETAC,1) + CALL DCOPY(N*M,DELTAN,1,DELTA,1) + RNORM = RNORMN + CALL DWGHT(NPP,1,SS,NPP,1,BETAC,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,DELTA,N,WRK(NPP+1),N) + PNORM = DNRM2(NPP+N*M,WRK,1) + ELSE + PNORM = DNRM2(NPP,WRK,1) + END IF + LSTEP = .TRUE. + ELSE + LSTEP = .FALSE. + END IF + +C TEST CONVERGENCE + + INFO = 0 + CNVSS = RNORM.EQ.ZERO + + .OR. + + (ABS(ACTRED).LE.SSTOL .AND. + + PRERED.LE.SSTOL .AND. + + P5*RATIO.LE.ONE) + CNVPAR = (TAU.LE.PARTOL*PNORM) .AND. (.NOT.IMPLCT) + IF (CNVSS) INFO = 1 + IF (CNVPAR) INFO = 2 + IF (CNVSS .AND. CNVPAR) INFO = 3 + +C PRINT ITERATION REPORT + + IF (INFO.NE.0 .OR. LSTEP) THEN + IF (IPR2.NE.0 .AND. IPR2F.NE.0 .AND. LUNRPT.NE.0) THEN + IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN + IFLAG = 2 + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + WSS(1) = RNORM*RNORM + IF (IPR2.GE.3. AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR2.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR2,2) + END IF + LUNR = LUNRPT + DO 140 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR2.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 140 CONTINUE + FSTITR = .FALSE. + PRTPEN = .FALSE. + END IF + END IF + END IF + +C CHECK IF FINISHED + + IF (INFO.EQ.0) THEN + IF (LSTEP) THEN + +C BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET + + IF (NITER.GE.MAXIT) THEN + INFO = 4 + ELSE + GO TO 100 + END IF + ELSE + +C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET + + GO TO 110 + END IF + END IF + + 150 CONTINUE + + IF (ISTOP.GT.0) INFO = INFO + 100 + +C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER + + IF (IMPLCT) THEN + CALL DCOPY(N*NQ,FS,1,F,1) + ELSE + CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) + END IF + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) + +C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS +C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED + + IF (DOVCV .AND. ISTOP.EQ.0) THEN + +C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED +C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED +C TO COMPUTE COVARIANCE MATRIX + + IF (REDOJ) THEN + CALL DEVJAC(FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FS, + + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) + + + IF (ISTOP.NE.0) THEN + INFO = 51000 + GO TO 200 + ELSE IF (INFO.EQ.50300) THEN + GO TO 200 + END IF + END IF + + IF (IMPLCT) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) + RSS = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) + ELSE + RSS = RNORM*RNORM + END IF + IF (REDOJ .OR. NITER.GE.1) THEN + CALL DODVCV(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + + ETA,ISODR, + + WORK(VCV),WORK(SD), + + WORK(WRK6),WORK(OMEGA), + + WORK(U),WORK(QRAUX),IWORK(JPVT), + + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + + WORK(WRK5),WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + INFO = ISTOPC + GO TO 200 + END IF + DIDVCV = .TRUE. + END IF + + END IF + +C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS + + 200 DO 210 I=0,NP-1 + WORK(WRK3+I) = IWORK(JPVT+I) + IWORK(JPVT+I) = -2 + 210 CONTINUE + IF (REDOJ .OR. NITER.GE.1) THEN + DO 220 I=0,NPP-1 + J = WORK(WRK3+I) - 1 + IF (I.LE.NPP-IRANK-1) THEN + IWORK(JPVT+J) = 1 + ELSE + IWORK(JPVT+J) = -1 + END IF + 220 CONTINUE + IF (NPP.LT.NP) THEN + J = NPP-1 + DO 230 I=NP-1,0,-1 + IF (IFIXB(I+1).EQ.0) THEN + IWORK(JPVT+I) = 0 + ELSE + IWORK(JPVT+I) = IWORK(JPVT+J) + J = J - 1 + END IF + 230 CONTINUE + END IF + END IF + +C STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER + + IF (NITER.GE.1) THEN + OLMAVG = OLMAVG/NITER + ELSE + OLMAVG = ZERO + END IF + +C COMPUTE WEIGHTED SUMS OF SQUARES FOR RETURN TO USER + + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,WRK,N) + WSS(3) = DDOT(N*NQ,WRK,1,WRK,1) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) + WSS(2) = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) + ELSE + WSS(2) = ZERO + END IF + WSS(1) = WSS(2) + WSS(3) + + ACCESS = .FALSE. + CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) + +C ENCODE EXISTANCE OF QUESTIONABLE RESULTS INTO INFO + + IF (INFO.LE.9 .OR. INFO.GE.60000) THEN + IF (MSGB(1).EQ.1 .OR. MSGD(1).EQ.1) THEN + INFO = INFO + 1000 + END IF + IF (ISTOP.NE.0) THEN + INFO = INFO + 100 + END IF + IF (IRANK.GE.1) THEN + IF (NPP.GT.IRANK) THEN + INFO = INFO + 10 + ELSE + INFO = INFO + 20 + END IF + END IF + END IF + +C PRINT FINAL SUMMARY + + IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN + IFLAG = 3 + + IF (IPR3.GE.3. AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR3.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR3,2) + END IF + LUNR = LUNRPT + DO 240 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IWORK(JPVT),IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR3.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 240 CONTINUE + END IF + + RETURN + + END +*DODPC1 + SUBROUTINE DODPC1 + + (IPR,LUNRPT, + + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + + MSGB1,MSGB,MSGD1,MSGD, + + N,M,NP,NQ,NPP,NNZW, + + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + + Y,LDY,WE,LDWE,LD2WE,PNLTY, + + BETA,IFIXB,SSF,STPB, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,WSSDEL,WSSEPS) +C***BEGIN PROLOGUE DODPC1 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DHSTEP +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE INITIAL SUMMARY REPORT +C***END PROLOGUE DODPC1 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,PNLTY,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS + INTEGER + + IPR,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LUNRPT,M,MAXIT,MSGB1,MSGD1,N,NETA,NNZW,NP,NPP,NQ + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),SSF(NP),STPB(NP),STPD(LDSTPD,M), + + TT(LDTT,M),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),X(LDX,M), + + Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ,NP),MSGD(NQ,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP1,TEMP2,TEMP3,ZERO + INTEGER + + I,ITEMP,J,JOB1,JOB2,JOB3,JOB4,JOB5,L + +C...LOCAL ARRAYS + CHARACTER TEMPC0*2,TEMPC1*5,TEMPC2*13 + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD DIFFERENCES +C (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ITEMP: A TEMPORARY INTEGER VALUE. +C J: AN INDEXING VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOB1: THE 1ST DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB2: THE 2ND DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB3: THE 3RD DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB4: THE 4TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB5: THE 5TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR THE COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C A NEGATIVE VALUE INDICATES THAT NETA WAS ESTIMATED BY +C ODRPACK. A POSITIVE VALUE INDICTES THE VALUE WAS SUPPLIED +C BY THE USER. +C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C SSF: THE SCALING VALUES FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TEMPC0: A TEMPORARY CHARACTER*2 VALUE. +C TEMPC1: A TEMPORARY CHARACTER*5 VALUE. +C TEMPC2: A TEMPORARY CHARACTER*13 VALUE. +C TEMP1: A TEMPORARY DOUBLE PRECISION VALUE. +C TEMP2: A TEMPORARY DOUBLE PRECISION VALUE. +C TEMP3: A TEMPORARY DOUBLE PRECISION VALUE. +C TT: THE SCALING VALUES FOR DELTA. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. +C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C X: THE EXPLANATORY VARIABLE. +C Y: THE RESPONSE VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODPC1 + + +C PRINT PROBLEM SIZE SPECIFICATION + + WRITE (LUNRPT,1000) N,NNZW,NQ,M,NP,NPP + + +C PRINT CONTROL VALUES + + JOB1 = JOB/10000 + JOB2 = MOD(JOB,10000)/1000 + JOB3 = MOD(JOB,1000)/100 + JOB4 = MOD(JOB,100)/10 + JOB5 = MOD(JOB,10) + WRITE (LUNRPT,1100) JOB + IF (RESTRT) THEN + WRITE (LUNRPT,1110) JOB1 + ELSE + WRITE (LUNRPT,1111) JOB1 + END IF + IF (ISODR) THEN + IF (INITD) THEN + WRITE (LUNRPT,1120) JOB2 + ELSE + WRITE (LUNRPT,1121) JOB2 + END IF + ELSE + WRITE (LUNRPT,1122) JOB2,JOB5 + END IF + IF (DOVCV) THEN + WRITE (LUNRPT,1130) JOB3 + IF (REDOJ) THEN + WRITE (LUNRPT,1131) + ELSE + WRITE (LUNRPT,1132) + END IF + ELSE + WRITE (LUNRPT,1133) JOB3 + END IF + IF (ANAJAC) THEN + WRITE (LUNRPT,1140) JOB4 + IF (CHKJAC) THEN + IF (MSGB1.GE.1 .OR. MSGD1.GE.1) THEN + WRITE (LUNRPT,1141) + ELSE + WRITE (LUNRPT,1142) + END IF + ELSE + WRITE (LUNRPT,1143) + END IF + ELSE IF (CDJAC) THEN + WRITE (LUNRPT,1144) JOB4 + ELSE + WRITE (LUNRPT,1145) JOB4 + END IF + IF (ISODR) THEN + IF (IMPLCT) THEN + WRITE (LUNRPT,1150) JOB5 + ELSE + WRITE (LUNRPT,1151) JOB5 + END IF + ELSE + WRITE (LUNRPT,1152) JOB5 + END IF + IF (NETA.LT.0) THEN + WRITE (LUNRPT,1200) -NETA + ELSE + WRITE (LUNRPT,1210) NETA + END IF + WRITE (LUNRPT,1300) TAUFAC + + +C PRINT STOPPING CRITERIA + + WRITE (LUNRPT,1400) SSTOL,PARTOL,MAXIT + + +C PRINT INITIAL SUM OF SQUARES + + IF (IMPLCT) THEN + WRITE (LUNRPT,1500) WSSDEL + IF (ISODR) THEN + WRITE (LUNRPT,1510) WSS,WSSEPS,PNLTY + END IF + ELSE + WRITE (LUNRPT,1600) WSS + IF (ISODR) THEN + WRITE (LUNRPT,1610) WSSDEL,WSSEPS + END IF + END IF + + + IF (IPR.GE.2) THEN + + +C PRINT FUNCTION PARAMETER DATA + + WRITE (LUNRPT,4000) + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + WRITE (LUNRPT,4110) + ELSE IF (ANAJAC) THEN + WRITE (LUNRPT,4120) + ELSE + WRITE (LUNRPT,4200) + END IF + DO 130 J=1,NP + IF (IFIXB(1).LT.0) THEN + TEMPC1 = ' NO' + ELSE + IF (IFIXB(J).NE.0) THEN + TEMPC1 = ' NO' + ELSE + TEMPC1 = ' YES' + END IF + END IF + IF (ANAJAC) THEN + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + ITEMP = -1 + DO 110 L=1,NQ + ITEMP = MAX(ITEMP,MSGB(L,J)) + 110 CONTINUE + IF (ITEMP.LE.-1) THEN + TEMPC2 = ' UNCHECKED' + ELSE IF (ITEMP.EQ.0) THEN + TEMPC2 = ' VERIFIED' + ELSE IF (ITEMP.GE.1) THEN + TEMPC2 = ' QUESTIONABLE' + END IF + ELSE + TEMPC2 = ' ' + END IF + ELSE + TEMPC2 = ' ' + END IF + IF (SSF(1).LT.ZERO) THEN + TEMP1 = ABS(SSF(1)) + ELSE + TEMP1 = SSF(J) + END IF + IF (ANAJAC) THEN + WRITE (LUNRPT,4310) J,BETA(J),TEMPC1,TEMP1,TEMPC2 + ELSE + IF (CDJAC) THEN + TEMP2 = DHSTEP(1,NETA,1,J,STPB,1) + ELSE + TEMP2 = DHSTEP(0,NETA,1,J,STPB,1) + END IF + WRITE (LUNRPT,4320) J,BETA(J),TEMPC1,TEMP1,TEMP2 + END IF + 130 CONTINUE + +C PRINT EXPLANATORY VARIABLE DATA + + IF (ISODR) THEN + WRITE (LUNRPT,2010) + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + WRITE (LUNRPT,2110) + ELSE IF (ANAJAC) THEN + WRITE (LUNRPT,2120) + ELSE + WRITE (LUNRPT,2130) + END IF + ELSE + WRITE (LUNRPT,2020) + WRITE (LUNRPT,2140) + END IF + IF (ISODR) THEN + DO 240 J = 1,M + TEMPC0 = '1,' + DO 230 I=1,N,N-1 + + IF (IFIXX(1,1).LT.0) THEN + TEMPC1 = ' NO' + ELSE + IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + TEMPC1 = ' YES' + ELSE + TEMPC1 = ' NO' + END IF + ELSE + IF (IFIXX(I,J).EQ.0) THEN + TEMPC1 = ' YES' + ELSE + TEMPC1 = ' NO' + END IF + END IF + END IF + + IF (TT(1,1).LT.ZERO) THEN + TEMP1 = ABS(TT(1,1)) + ELSE + IF (LDTT.EQ.1) THEN + TEMP1 = TT(1,J) + ELSE + TEMP1 = TT(I,J) + END IF + END IF + + IF (WD(1,1,1).LT.ZERO) THEN + TEMP2 = ABS(WD(1,1,1)) + ELSE + IF (LDWD.EQ.1) THEN + IF (LD2WD.EQ.1) THEN + TEMP2 = WD(1,1,J) + ELSE + TEMP2 = WD(1,J,J) + END IF + ELSE + IF (LD2WD.EQ.1) THEN + TEMP2 = WD(I,1,J) + ELSE + TEMP2 = WD(I,J,J) + END IF + END IF + END IF + + IF (ANAJAC) THEN + IF (CHKJAC .AND. + + (((MSGB1.GE.1) .OR. (MSGD1.GE.1)) .AND. + + (I.EQ.1))) THEN + ITEMP = -1 + DO 210 L=1,NQ + ITEMP = MAX(ITEMP,MSGD(L,J)) + 210 CONTINUE + IF (ITEMP.LE.-1) THEN + TEMPC2 = ' UNCHECKED' + ELSE IF (ITEMP.EQ.0) THEN + TEMPC2 = ' VERIFIED' + ELSE IF (ITEMP.GE.1) THEN + TEMPC2 = ' QUESTIONABLE' + END IF + ELSE + TEMPC2 = ' ' + END IF + IF (M.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 + END IF + ELSE + TEMPC2 = ' ' + IF (CDJAC) THEN + TEMP3 = DHSTEP(1,NETA,I,J,STPD,LDSTPD) + ELSE + TEMP3 = DHSTEP(0,NETA,I,J,STPD,LDSTPD) + END IF + IF (M.LE.9) THEN + WRITE (LUNRPT,5210) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 + ELSE + WRITE (LUNRPT,5220) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 + END IF + END IF + + TEMPC0 = 'N,' + + 230 CONTINUE + IF (J.LT.M) WRITE (LUNRPT,6000) + 240 CONTINUE + ELSE + + DO 260 J = 1,M + TEMPC0 = '1,' + DO 250 I=1,N,N-1 + IF (M.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,J,X(I,J) + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,J,X(I,J) + END IF + TEMPC0 = 'N,' + 250 CONTINUE + IF (J.LT.M) WRITE (LUNRPT,6000) + 260 CONTINUE + END IF + +C PRINT RESPONSE VARIABLE DATA AND OBSERVATION ERROR WEIGHTS + + IF (.NOT.IMPLCT) THEN + WRITE (LUNRPT,3000) + WRITE (LUNRPT,3100) + DO 310 L=1,NQ + TEMPC0 = '1,' + DO 300 I=1,N,N-1 + IF (WE(1,1,1).LT.ZERO) THEN + TEMP1 = ABS(WE(1,1,1)) + ELSE IF (LDWE.EQ.1) THEN + IF (LD2WE.EQ.1) THEN + TEMP1 = WE(1,1,L) + ELSE + TEMP1 = WE(1,L,L) + END IF + ELSE + IF (LD2WE.EQ.1) THEN + TEMP1 = WE(I,1,L) + ELSE + TEMP1 = WE(I,L,L) + END IF + END IF + IF (NQ.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,L,Y(I,L),TEMP1 + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,L,Y(I,L),TEMP1 + END IF + TEMPC0 = 'N,' + 300 CONTINUE + IF (L.LT.NQ) WRITE (LUNRPT,6000) + 310 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (/' --- PROBLEM SIZE:'/ + + ' N = ',I5, + + ' (NUMBER WITH NONZERO WEIGHT = ',I5,')'/ + + ' NQ = ',I5/ + + ' M = ',I5/ + + ' NP = ',I5, + + ' (NUMBER UNFIXED = ',I5,')') + 1100 FORMAT + + (/' --- CONTROL VALUES:'/ + + ' JOB = ',I5.5/ + + ' = ABCDE, WHERE') + 1110 FORMAT + + (' A=',I1,' ==> FIT IS A RESTART.') + 1111 FORMAT + + (' A=',I1,' ==> FIT IS NOT A RESTART.') + 1120 FORMAT + + (' B=',I1,' ==> DELTAS ARE INITIALIZED', + + ' TO ZERO.') + 1121 FORMAT + + (' B=',I1,' ==> DELTAS ARE INITIALIZED', + + ' BY USER.') + 1122 FORMAT + + (' B=',I1,' ==> DELTAS ARE FIXED AT', + + ' ZERO SINCE E=',I1,'.') + 1130 FORMAT + + (' C=',I1,' ==> COVARIANCE MATRIX WILL', + + ' BE COMPUTED USING') + 1131 FORMAT + + (' DERIVATIVES RE-', + + 'EVALUATED AT THE SOLUTION.') + 1132 FORMAT + + (' DERIVATIVES FROM THE', + + ' LAST ITERATION.') + 1133 FORMAT + + (' C=',I1,' ==> COVARIANCE MATRIX WILL', + + ' NOT BE COMPUTED.') + 1140 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' SUPPLIED BY USER.') + 1141 FORMAT + + (' DERIVATIVES WERE CHECKED.'/ + + ' RESULTS APPEAR QUESTIONABLE.') + 1142 FORMAT + + (' DERIVATIVES WERE CHECKED.'/ + + ' RESULTS APPEAR CORRECT.') + 1143 FORMAT + + (' DERIVATIVES WERE NOT', + + ' CHECKED.') + 1144 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' ESTIMATED BY CENTRAL', + + ' DIFFERENCES.') + 1145 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' ESTIMATED BY FORWARD', + + ' DIFFERENCES.') + 1150 FORMAT + + (' E=',I1,' ==> METHOD IS IMPLICIT ODR.') + 1151 FORMAT + + (' E=',I1,' ==> METHOD IS EXPLICIT ODR.') + 1152 FORMAT + + (' E=',I1,' ==> METHOD IS EXPLICIT OLS.') + 1200 FORMAT + + (' NDIGIT = ',I5,' (ESTIMATED BY ODRPACK)') + 1210 FORMAT + + (' NDIGIT = ',I5,' (SUPPLIED BY USER)') + 1300 FORMAT + + (' TAUFAC = ',1P,D12.2) + 1400 FORMAT + + (/' --- STOPPING CRITERIA:'/ + + ' SSTOL = ',1P,D12.2, + + ' (SUM OF SQUARES STOPPING TOLERANCE)'/ + + ' PARTOL = ',1P,D12.2, + + ' (PARAMETER STOPPING TOLERANCE)'/ + + ' MAXIT = ',I5, + + ' (MAXIMUM NUMBER OF ITERATIONS)') + 1500 FORMAT + + (/' --- INITIAL SUM OF SQUARED WEIGHTED DELTAS =', + + 17X,1P,D17.8) + 1510 FORMAT + + ( ' INITIAL PENALTY FUNCTION VALUE =',1P,D17.8/ + + ' PENALTY TERM =',1P,D17.8/ + + ' PENALTY PARAMETER =',1P,D10.1) + 1600 FORMAT + + (/' --- INITIAL WEIGHTED SUM OF SQUARES =', + + 17X,1P,D17.8) + 1610 FORMAT + + ( ' SUM OF SQUARED WEIGHTED DELTAS =',1P,D17.8/ + + ' SUM OF SQUARED WEIGHTED EPSILONS =',1P,D17.8) + 2010 FORMAT + + (/' --- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:') + 2020 FORMAT + + (/' --- EXPLANATORY VARIABLE SUMMARY:') + 2110 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT DERIVATIVE'/ + + ' ', + + ' ASSESSMENT'/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) '/) + 2120 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT '/ + + ' ', + + ' '/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) '/) + 2130 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT DERIVATIVE'/ + + ' ', + + ' STEP SIZE'/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) (STPD)'/) + 2140 FORMAT + + (/' INDEX X(I,J)'/ + + ' (I,J) '/) + 3000 FORMAT + + (/' --- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT', + + ' SUMMARY:') + 3100 FORMAT + + (/' INDEX Y(I,L) WEIGHT'/ + + ' (I,L) (WE)'/) + 4000 FORMAT + + (/' --- FUNCTION PARAMETER SUMMARY:') + 4110 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' DERIVATIVE'/ + + ' ', + + ' ASSESSMENT'/, + + ' (K) (IFIXB) (SCLB)', + + ' '/) + 4120 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' '/ + + ' ', + + ' '/, + + ' (K) (IFIXB) (SCLB)', + + ' '/) + 4200 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' DERIVATIVE'/ + + ' ', + + ' STEP SIZE'/, + + ' (K) (IFIXB) (SCLB)', + + ' (STPB)'/) + 4310 FORMAT + + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,A13) + 4320 FORMAT + + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,D13.5) + 5110 FORMAT + + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,A13) + 5120 FORMAT + + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,A13) + 5210 FORMAT + + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) + 5220 FORMAT + + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) + 6000 FORMAT + + (' ') + END +*DODPC2 + SUBROUTINE DODPC2 + + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + + PNLTY, + + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) +C***BEGIN PROLOGUE DODPC2 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE GENERATE ITERATION REPORTS +C***END PROLOGUE DODPC2 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRED,ALPHA,PNLTY,PNORM,PRERED,TAU,WSS + INTEGER + + IPR,LUNRPT,NFEV,NITER,NP + LOGICAL + + FSTITR,IMPLCT,PRTPEN + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + RATIO,ZERO + INTEGER + + J,K,L + CHARACTER GN*3 + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C BETA: THE FUNCTION PARAMETERS. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). +C GN: THE CHARACTER*3 VARIABLE INDICATING WHETHER A GAUSS-NEWTON +C STEP WAS TAKEN. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C RATIO: THE RATIO OF TAU TO PNORM. +C TAU: THE TRUST REGION DIAMETER. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODPC2 + + + IF (FSTITR) THEN + IF (IPR.EQ.1) THEN + IF (IMPLCT) THEN + WRITE (LUNRPT,1121) + ELSE + WRITE (LUNRPT,1122) + END IF + ELSE + IF (IMPLCT) THEN + WRITE (LUNRPT,1131) + ELSE + WRITE (LUNRPT,1132) + END IF + END IF + END IF + IF (PRTPEN) THEN + WRITE (LUNRPT,1133) PNLTY + END IF + + IF (ALPHA.EQ.ZERO) THEN + GN = 'YES' + ELSE + GN = ' NO' + END IF + IF (PNORM.NE.ZERO) THEN + RATIO = TAU/PNORM + ELSE + RATIO = ZERO + END IF + IF (IPR.EQ.1) THEN + WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN + ELSE + J = 1 + K = MIN(3,NP) + IF (J.EQ.K) THEN + WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN,J,BETA(J) + ELSE + WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN,J,K,(BETA(L),L=J,K) + END IF + IF (NP.GT.3) THEN + DO 10 J=4,NP,3 + K = MIN(J+2,NP) + IF (J.EQ.K) THEN + WRITE (LUNRPT,1151) J,BETA(J) + ELSE + WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K) + END IF + 10 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1121 FORMAT + + (// + + ' CUM. PENALTY ACT. REL. PRED. REL.'/ + + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', + + ' G-N'/ + + ' NUM. EVALS VALUE REDUCTION REDUCTION', + + ' TAU/PNORM STEP'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ----') + 1122 FORMAT + + (// + + ' CUM. ACT. REL. PRED. REL.'/ + + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + + ' G-N'/ + + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + + ' TAU/PNORM STEP'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ----'/) + 1131 FORMAT + + (// + + ' CUM. PENALTY ACT. REL. PRED. REL.'/ + + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', + + ' G-N BETA -------------->'/ + + ' NUM. EVALS VALUE REDUCTION REDUCTION', + + ' TAU/PNORM STEP INDEX VALUE'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ---- ----- -----') + 1132 FORMAT + + (// + + ' CUM. ACT. REL. PRED. REL.'/ + + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + + ' G-N BETA -------------->'/ + + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + + ' TAU/PNORM STEP INDEX VALUE'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ---- ----- -----'/) + 1133 FORMAT + + (/' PENALTY PARAMETER VALUE = ', 1P,E10.1) + 1141 FORMAT + + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8) + 1142 FORMAT + + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8) + 1151 FORMAT + + (76X,I3,1P,D16.8) + 1152 FORMAT + + (70X,I3,' TO',I3,1P,3D16.8) + END +*DODPC3 + SUBROUTINE DODPC3 + + (IPR,LUNRPT, + + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + + N,M,NP,NQ,NPP, + + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + + WSS,WSSDEL,WSSEPS,PNLTY,RVAR,IDF, + + BETA,SDBETA,IFIXB2,F,DELTA) +C***BEGIN PROLOGUE DODPC3 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPPT +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE FINAL SUMMARY REPORT +C***END PROLOGUE DODPC3 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PNLTY,RCOND,RVAR,WSS,WSSDEL,WSSEPS + INTEGER + + IDF,INFO,IPR,IRANK,ISTOP,LUNRPT,M, + + N,NFEV,NITER,NJEV,NP,NPP,NQ + LOGICAL + + ANAJAC,DIDVCV,DOVCV,IMPLCT,ISODR,REDOJ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP) + INTEGER + + IFIXB2(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TVAL + INTEGER + + D1,D2,D3,D4,D5,I,J,K,L,NPLM1 + CHARACTER FMT1*90 + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DPPT + EXTERNAL + + DPPT + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN,MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C D1: THE FIRST DIGIT OF INFO. +C D2: THE SECOND DIGIT OF INFO. +C D3: THE THIRD DIGIT OF INFO. +C D4: THE FOURTH DIGIT OF INFO. +C D5: THE FIFTH DIGIT OF INFO. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C F: THE ESTIMATED VALUES OF EPSILON. +C FMT1: A CHARACTER*90 VARIABLE USED FOR FORMATS. +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB2: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA WERE +C ESTIMATED, FIXED, OR DROPPED BECAUSE THEY CAUSED RANK +C DEFICIENCY, CORRESPONDING TO VALUES OF IFIXB2 EQUALING 1, +C 0, AND -1, RESPECTIVELY. IF IFIXB2 IS -2, THEN NO ATTEMPT +C WAS MADE TO ESTIMATE THE PARAMETERS BECAUSE MAXIT = 0. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPR: THE VARIABLE INDICATING WHAT IS TO BE PRINTED. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPLM1: THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS +C TO BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE +C MATRIX (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RVAR: THE RESIDUAL VARIANCE. +C SDBETA: THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS. +C TVAL: THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE +C T DISTRIBUTION. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. +C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. + + +C***FIRST EXECUTABLE STATEMENT DODPC3 + + + D1 = INFO/10000 + D2 = MOD(INFO,10000)/1000 + D3 = MOD(INFO,1000)/100 + D4 = MOD(INFO,100)/10 + D5 = MOD(INFO,10) + +C PRINT STOPPING CONDITIONS + + WRITE (LUNRPT,1000) + IF (INFO.LE.9) THEN + IF (INFO.EQ.1) THEN + WRITE (LUNRPT,1011) INFO + ELSE IF (INFO.EQ.2) THEN + WRITE (LUNRPT,1012) INFO + ELSE IF (INFO.EQ.3) THEN + WRITE (LUNRPT,1013) INFO + ELSE IF (INFO.EQ.4) THEN + WRITE (LUNRPT,1014) INFO + ELSE IF (INFO.LE.9) THEN + WRITE (LUNRPT,1015) INFO + END IF + ELSE IF (INFO.LE.9999) THEN + +C PRINT WARNING DIAGNOSTICS + + WRITE (LUNRPT,1020) INFO + IF (D2.EQ.1) WRITE (LUNRPT,1021) + IF (D3.EQ.1) WRITE (LUNRPT,1022) + IF (D4.EQ.1) WRITE (LUNRPT,1023) + IF (D4.EQ.2) WRITE (LUNRPT,1024) + IF (D5.EQ.1) THEN + WRITE (LUNRPT,1031) + ELSE IF (D5.EQ.2) THEN + WRITE (LUNRPT,1032) + ELSE IF (D5.EQ.3) THEN + WRITE (LUNRPT,1033) + ELSE IF (D5.EQ.4) THEN + WRITE (LUNRPT,1034) + ELSE IF (D5.LE.9) THEN + WRITE (LUNRPT,1035) D5 + END IF + ELSE + +C PRINT ERROR MESSAGES + + WRITE (LUNRPT,1040) INFO + IF (D1.EQ.5) THEN + WRITE (LUNRPT,1042) + IF (D2.NE.0) WRITE (LUNRPT,1043) D2 + IF (D3.EQ.3) THEN + WRITE (LUNRPT,1044) D3 + ELSE IF (D3.NE.0) THEN + WRITE (LUNRPT,1045) D3 + END IF + ELSE IF (D1.EQ.6) THEN + WRITE (LUNRPT,1050) + ELSE + WRITE (LUNRPT,1060) D1 + END IF + END IF + +C PRINT MISC. STOPPING INFO + + WRITE (LUNRPT,1300) NITER + WRITE (LUNRPT,1310) NFEV + IF (ANAJAC) WRITE (LUNRPT,1320) NJEV + WRITE (LUNRPT,1330) IRANK + WRITE (LUNRPT,1340) RCOND + WRITE (LUNRPT,1350) ISTOP + +C PRINT FINAL SUM OF SQUARES + + IF (IMPLCT) THEN + WRITE (LUNRPT,2000) WSSDEL + IF (ISODR) THEN + WRITE (LUNRPT,2010) WSS,WSSEPS,PNLTY + END IF + ELSE + WRITE (LUNRPT,2100) WSS + IF (ISODR) THEN + WRITE (LUNRPT,2110) WSSDEL,WSSEPS + END IF + END IF + IF (DIDVCV) THEN + WRITE (LUNRPT,2200) SQRT(RVAR),IDF + END IF + + NPLM1 = 3 + +C PRINT ESTIMATED BETA'S, AND, +C IF, FULL RANK, THEIR STANDARD ERRORS + + WRITE (LUNRPT,3000) + IF (DIDVCV) THEN + WRITE (LUNRPT,7300) + TVAL = DPPT(0.975D0,IDF) + DO 10 J=1,NP + IF (IFIXB2(J).GE.1) THEN + WRITE (LUNRPT,8400) J,BETA(J),SDBETA(J), + + BETA(J)-TVAL*SDBETA(J), + + BETA(J)+TVAL*SDBETA(J) + ELSE IF (IFIXB2(J).EQ.0) THEN + WRITE (LUNRPT,8600) J,BETA(J) + ELSE + WRITE (LUNRPT,8700) J,BETA(J) + END IF + 10 CONTINUE + IF (.NOT.REDOJ) WRITE (LUNRPT,7310) + ELSE + IF (DOVCV) THEN + IF (D1.LE.5) THEN + WRITE (LUNRPT,7410) + ELSE + WRITE (LUNRPT,7420) + END IF + END IF + + IF ((IRANK.EQ.0 .AND. NPP.EQ.NP) .OR. NITER.EQ.0) THEN + IF (NP.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 20 J=1,NP,NPLM1+1 + K = MIN(J+NPLM1,NP) + IF (K.EQ.J) THEN + WRITE (LUNRPT,8100) J,BETA(J) + ELSE + WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K) + END IF + 20 CONTINUE + IF (NITER.GE.1) THEN + WRITE (LUNRPT,8800) + ELSE + WRITE (LUNRPT,8900) + END IF + ELSE + WRITE (LUNRPT,7500) + DO 30 J=1,NP + IF (IFIXB2(J).GE.1) THEN + WRITE (LUNRPT,8500) J,BETA(J) + ELSE IF (IFIXB2(J).EQ.0) THEN + WRITE (LUNRPT,8600) J,BETA(J) + ELSE + WRITE (LUNRPT,8700) J,BETA(J) + END IF + 30 CONTINUE + END IF + END IF + + IF (IPR.EQ.1) RETURN + + +C PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF +C COLUMNS OF DATA IN EPSILON AND DELTA IS LESS THAN OR EQUAL TO THREE. + + IF (IMPLCT .AND. (M.LE.4)) THEN + WRITE (LUNRPT,4100) + WRITE (FMT1,9110) M + WRITE (LUNRPT,FMT1) (J,J=1,M) + DO 40 I=1,N + WRITE (LUNRPT,4130) I,(DELTA(I,J),J=1,M) + 40 CONTINUE + + ELSE IF (ISODR .AND. (NQ+M.LE.4)) THEN + WRITE (LUNRPT,4110) + WRITE (FMT1,9120) NQ,M + WRITE (LUNRPT,FMT1) (L,L=1,NQ),(J,J=1,M) + DO 50 I=1,N + WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ),(DELTA(I,J),J=1,M) + 50 CONTINUE + + ELSE IF (.NOT.ISODR .AND. ((NQ.GE.2) .AND. (NQ.LE.4))) THEN + WRITE (LUNRPT,4120) + WRITE (FMT1,9130) NQ + WRITE (LUNRPT,FMT1) (L,L=1,NQ) + DO 60 I=1,N + WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ) + 60 CONTINUE + ELSE + +C PRINT EPSILON'S AND DELTA'S SEPARATELY + + IF (.NOT.IMPLCT) THEN + +C PRINT EPSILON'S + + DO 80 J=1,NQ + WRITE (LUNRPT,4200) J + IF (N.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 70 I=1,N,NPLM1+1 + K = MIN(I+NPLM1,N) + IF (I.EQ.K) THEN + WRITE (LUNRPT,8100) I,F(I,J) + ELSE + WRITE (LUNRPT,8200) I,K,(F(L,J),L=I,K) + END IF + 70 CONTINUE + 80 CONTINUE + END IF + +C PRINT DELTA'S + + IF (ISODR) THEN + DO 100 J=1,M + WRITE (LUNRPT,4300) J + IF (N.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 90 I=1,N,NPLM1+1 + K = MIN(I+NPLM1,N) + IF (I.EQ.K) THEN + WRITE (LUNRPT,8100) I,DELTA(I,J) + ELSE + WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K) + END IF + 90 CONTINUE + 100 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (/' --- STOPPING CONDITIONS:') + 1011 FORMAT + + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE.') + 1012 FORMAT + + (' INFO = ',I5,' ==> PARAMETER CONVERGENCE.') + 1013 FORMAT + + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE AND', + + ' PARAMETER CONVERGENCE.') + 1014 FORMAT + + (' INFO = ',I5,' ==> ITERATION LIMIT REACHED.') + 1015 FORMAT + + (' INFO = ',I5,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1020 FORMAT + + (' INFO = ',I5.4/ + + ' = ABCD, WHERE A NONZERO VALUE FOR DIGIT A,', + + ' B, OR C INDICATES WHY'/ + + ' THE RESULTS MIGHT BE QUESTIONABLE,', + + ' AND DIGIT D INDICATES'/ + + ' THE ACTUAL STOPPING CONDITION.') + 1021 FORMAT + + (' A=1 ==> DERIVATIVES ARE', + + ' QUESTIONABLE.') + 1022 FORMAT + + (' B=1 ==> USER SET ISTOP TO', + + ' NONZERO VALUE DURING LAST'/ + + ' CALL TO SUBROUTINE FCN.') + 1023 FORMAT + + (' C=1 ==> DERIVATIVES ARE NOT', + + ' FULL RANK AT THE SOLUTION.') + 1024 FORMAT + + (' C=2 ==> DERIVATIVES ARE ZERO', + + ' RANK AT THE SOLUTION.') + 1031 FORMAT + + (' D=1 ==> SUM OF SQUARES CONVERGENCE.') + 1032 FORMAT + + (' D=2 ==> PARAMETER CONVERGENCE.') + 1033 FORMAT + + (' D=3 ==> SUM OF SQUARES CONVERGENCE', + + ' AND PARAMETER CONVERGENCE.') + 1034 FORMAT + + (' D=4 ==> ITERATION LIMIT REACHED.') + 1035 FORMAT + + (' D=',I1,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1040 FORMAT + + (' INFO = ',I5.5/ + + ' = ABCDE, WHERE A NONZERO VALUE FOR A GIVEN', + + ' DIGIT INDICATES AN'/ + + ' ABNORMAL STOPPING CONDITION.') + 1042 FORMAT + + (' A=5 ==> USER STOPPED COMPUTATIONS', + + ' IN SUBROUTINE FCN.') + 1043 FORMAT + + (' B=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED DURING THE'/ + + ' FUNCTION EVALUATION.') + 1044 FORMAT + + (' C=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED BECAUSE'/ + + ' DERIVATIVES WITH', + + ' RESPECT TO DELTA WERE'/ + + ' COMPUTED BY', + + ' SUBROUTINE FCN WHEN'/ + + ' FIT IS OLS.') + 1045 FORMAT + + (' C=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED DURING THE'/ + + ' JACOBIAN EVALUATION.') + 1050 FORMAT + + (' A=6 ==> NUMERICAL INSTABILITIES', + + ' HAVE BEEN DETECTED,'/ + + ' POSSIBLY INDICATING', + + ' A DISCONTINUITY IN THE'/ + + ' DERIVATIVES OR A POOR', + + ' POOR CHOICE OF PROBLEM'/ + + ' SCALE OR WEIGHTS.') + 1060 FORMAT + + (' A=',I1,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1300 FORMAT + + (' NITER = ',I5, + + ' (NUMBER OF ITERATIONS)') + 1310 FORMAT + + (' NFEV = ',I5, + + ' (NUMBER OF FUNCTION EVALUATIONS)') + 1320 FORMAT + + (' NJEV = ',I5, + + ' (NUMBER OF JACOBIAN EVALUATIONS)') + 1330 FORMAT + + (' IRANK = ',I5, + + ' (RANK DEFICIENCY)') + 1340 FORMAT + + (' RCOND = ',1P,D12.2, + + ' (INVERSE CONDITION NUMBER)') +*1341 FORMAT +* + (' ==> POSSIBLY FEWER THAN 2 SIGNIFICANT', +* + ' DIGITS IN RESULTS;'/ +* + ' SEE ODRPACK REFERENCE', +* + ' GUIDE, SECTION 4.C.') + 1350 FORMAT + + (' ISTOP = ',I5, + + ' (RETURNED BY USER FROM', + + ' SUBROUTINE FCN)') + 2000 FORMAT + + (/' --- FINAL SUM OF SQUARED WEIGHTED DELTAS = ', + + 17X,1P,D17.8) + 2010 FORMAT + + ( ' FINAL PENALTY FUNCTION VALUE = ',1P,D17.8/ + + ' PENALTY TERM = ',1P,D17.8/ + + ' PENALTY PARAMETER = ',1P,D10.1) + 2100 FORMAT + + (/' --- FINAL WEIGHTED SUMS OF SQUARES = ',17X,1P,D17.8) + 2110 FORMAT + + ( ' SUM OF SQUARED WEIGHTED DELTAS = ',1P,D17.8/ + + ' SUM OF SQUARED WEIGHTED EPSILONS = ',1P,D17.8) + 2200 FORMAT + + (/' --- RESIDUAL STANDARD DEVIATION = ', + + 17X,1P,D17.8/ + + ' DEGREES OF FREEDOM =',I5) + 3000 FORMAT + + (/' --- ESTIMATED BETA(J), J = 1, ..., NP:') + 4100 FORMAT + + (/' --- ESTIMATED DELTA(I,*), I = 1, ..., N:') + 4110 FORMAT + + (/' --- ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:') + 4120 FORMAT + + (/' --- ESTIMATED EPSILON(I), I = 1, ..., N:') + 4130 FORMAT(5X,I5,1P,5D16.8) + 4200 FORMAT + + (/' --- ESTIMATED EPSILON(I,',I3,'), I = 1, ..., N:') + 4300 FORMAT + + (/' --- ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:') + 7100 FORMAT + + (/' INDEX VALUE'/) + 7200 FORMAT + + (/' INDEX VALUE -------------->'/) + 7300 FORMAT + + (/' BETA S.D. BETA', + + ' ---- 95% CONFIDENCE INTERVAL ----'/) + 7310 FORMAT + + (/' N.B. STANDARD ERRORS AND CONFIDENCE INTERVALS ARE', + + ' COMPUTED USING'/ + + ' DERIVATIVES CALCULATED AT THE BEGINNING', + + ' OF THE LAST ITERATION,'/ + + ' AND NOT USING DERIVATIVES RE-EVALUATED AT THE', + + ' FINAL SOLUTION.') + 7410 FORMAT + + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', + + ' NOT COMPUTED BECAUSE'/ + + ' THE DERIVATIVES WERE NOT AVAILABLE. EITHER MAXIT', + + ' IS 0 AND THE THIRD'/ + + ' DIGIT OF JOB IS GREATER THAN 1, OR THE MOST', + + ' RECENTLY TRIED VALUES OF'/ + + ' BETA AND/OR X+DELTA WERE IDENTIFIED AS', + + ' UNACCEPTABLE BY USER SUPPLIED'/ + + ' SUBROUTINE FCN.') + 7420 FORMAT + + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', + + ' NOT COMPUTED.'/ + + ' (SEE INFO ABOVE.)') + 7500 FORMAT + + (/' BETA STATUS') + 8100 FORMAT + + (11X,I5,1P,D16.8) + 8200 FORMAT + + (3X,I5,' TO',I5,1P,7D16.8) + 8400 FORMAT + + (3X,I5,1X,1P,D16.8,3X,D12.4,3X,D16.8,1X,'TO',D16.8) + 8500 FORMAT + + (3X,I5,1X,1P,D16.8,6X,'ESTIMATED') + 8600 FORMAT + + (3X,I5,1X,1P,D16.8,6X,' FIXED') + 8700 FORMAT + + (3X,I5,1X,1P,D16.8,6X,' DROPPED') + 8800 FORMAT + + (/' N.B. NO PARAMETERS WERE FIXED BY THE USER OR', + + ' DROPPED AT THE LAST'/ + + ' ITERATION BECAUSE THEY CAUSED THE MODEL TO BE', + + ' RANK DEFICIENT.') + 8900 FORMAT + + (/' N.B. NO CHANGE WAS MADE TO THE USER SUPPLIED PARAMETER', + + ' VALUES BECAUSE'/ + + ' MAXIT=0.') + 9110 FORMAT + + ('(/'' I'',', + + I2,'('' DELTA(I,'',I1,'')'')/)') + 9120 FORMAT + + ('(/'' I'',', + + I2,'('' EPSILON(I,'',I1,'')''),', + + I2,'('' DELTA(I,'',I1,'')'')/)') + 9130 FORMAT + + ('(/'' I'',', + + I2,'('' EPSILON(I,'',I1,'')'')/)') + + END +*DODPCR + SUBROUTINE DODPCR + + (IPR,LUNRPT, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,SDBETA, + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) +C***BEGIN PROLOGUE DODPCR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE COMPUTATION REPORTS +C***END PROLOGUE DODPCR + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR, + + SSTOL,TAU,TAUFAC + INTEGER + + IDF,IFLAG,INFO,IPR,IRANK,ISTOP,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE, + + LDX,LDY,LD2WD,LD2WE,LUNRPT,M,MAXIT,N,NETA,NFEV, + + NITER,NJEV,NNZW,NP,NPP,NQ + LOGICAL + + DIDVCV,FSTITR,HEAD,PRTPEN + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP),SSF(NP), + + STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WSS(3),X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ*NP+1),MSGD(NQ*M+1) + +C...LOCAL SCALARS + DOUBLE PRECISION + + PNLTY + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + CHARACTER TYP*3 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFLAG: THE VARIABLE DESIGNATING WHAT IS TO BE PRINTED. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RVAR: THE RESIDUAL VARIANCE. +C SDBETA: THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S. +C SSF: THE SCALING VALUES FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TT: THE SCALING VALUES FOR DELTA. +C TYP: THE CHARACTER*3 STRING "ODR" OR "OLS". +C WE: THE EPSILON WEIGHTS. +C WD: THE DELTA WEIGHTS. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODPCR + + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + PNLTY = ABS(WE(1,1,1)) + + IF (HEAD) THEN + CALL DODPHD(HEAD,LUNRPT) + END IF + IF (ISODR) THEN + TYP = 'ODR' + ELSE + TYP = 'OLS' + END IF + +C PRINT INITIAL SUMMARY + + IF (IFLAG.EQ.1) THEN + WRITE (LUNRPT,1200) TYP + CALL DODPC1 + + (IPR,LUNRPT, + + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + + MSGB(1),MSGB(2),MSGD(1),MSGD(2), + + N,M,NP,NQ,NPP,NNZW, + + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + + Y,LDY,WE,LDWE,LD2WE,PNLTY, + + BETA,IFIXB,SSF,STPB, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS(1),WSS(2),WSS(3)) + +C PRINT ITERATION REPORTS + + ELSE IF (IFLAG.EQ.2) THEN + + IF (FSTITR) THEN + WRITE (LUNRPT,1300) TYP + END IF + CALL DODPC2 + + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + + PNLTY, + + NITER,NFEV,WSS(1),ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) + +C PRINT FINAL SUMMARY + + ELSE IF (IFLAG.EQ.3) THEN + + WRITE (LUNRPT,1400) TYP + CALL DODPC3 + + (IPR,LUNRPT, + + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + + N,M,NP,NQ,NPP, + + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + + WSS(1),WSS(2),WSS(3),PNLTY,RVAR,IDF, + + BETA,SDBETA,IFIXB,F,DELTA) + END IF + + RETURN + +C FORMAT STATEMENTS + + 1200 FORMAT + + (/' *** INITIAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') + 1300 FORMAT + + (/' *** ITERATION REPORTS FOR FIT BY METHOD OF ',A3, ' ***') + 1400 FORMAT + + (/' *** FINAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') + + END +*DODPE1 + SUBROUTINE DODPE1 + + (UNIT,D1,D2,D3,D4,D5, + + N,M,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN) +C***BEGIN PROLOGUE DODPE1 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ERROR REPORTS +C***END PROLOGUE DODPE1 + +C...SCALAR ARGUMENTS + INTEGER + + D1,D2,D3,D4,D5,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE, + + LIWKMN,LWKMN,M,N,NQ,UNIT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. +C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. + + +C***FIRST EXECUTABLE STATEMENT DODPE1 + + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION +C PARAMETERS + + IF (D1.EQ.1) THEN + IF (D2.NE.0) THEN + WRITE(UNIT,1100) + END IF + IF (D3.NE.0) THEN + WRITE(UNIT,1200) + END IF + IF (D4.NE.0) THEN + WRITE(UNIT,1300) + END IF + IF (D5.NE.0) THEN + WRITE(UNIT,1400) + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION +C PARAMETERS + + ELSE IF (D1.EQ.2) THEN + + IF (D2.NE.0) THEN + IF (D2.EQ.1 .OR. D2.EQ.3) THEN + WRITE(UNIT,2110) + END IF + IF (D2.EQ.2 .OR. D2.EQ.3) THEN + WRITE(UNIT,2120) + END IF + END IF + + IF (D3.NE.0) THEN + IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN + WRITE(UNIT,2210) + END IF + IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN + WRITE(UNIT,2220) + END IF + IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN + WRITE(UNIT,2230) + END IF + END IF + + IF (D4.NE.0) THEN + IF (D4.EQ.1 .OR. D4.EQ.3) THEN + WRITE(UNIT,2310) + END IF + IF (D4.EQ.2 .OR. D4.EQ.3) THEN + WRITE(UNIT,2320) + END IF + END IF + + IF (D5.NE.0) THEN + IF (D5.EQ.1 .OR. D5.EQ.3) THEN + WRITE(UNIT,2410) LWKMN + END IF + IF (D5.EQ.2 .OR. D5.EQ.3) THEN + WRITE(UNIT,2420) LIWKMN + END IF + END IF + + ELSE IF (D1.EQ.3) THEN + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN SCALE VALUES + + IF (D2.NE.0) THEN + IF (D2.EQ.1 .OR. D2.EQ.3) THEN + IF (LDSCLD.GE.N) THEN + WRITE(UNIT,3110) + ELSE + WRITE(UNIT,3120) + END IF + END IF + IF (D2.EQ.2 .OR. D2.EQ.3) THEN + WRITE(UNIT,3130) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DERIVATIVE STEP VALUES + + IF (D3.NE.0) THEN + IF (D3.EQ.1 .OR. D3.EQ.3) THEN + IF (LDSTPD.GE.N) THEN + WRITE(UNIT,3210) + ELSE + WRITE(UNIT,3220) + END IF + END IF + IF (D3.EQ.2 .OR. D3.EQ.3) THEN + WRITE(UNIT,3230) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS + + IF (D4.NE.0) THEN + IF (D4.EQ.1) THEN + IF (LDWE.GE.N) THEN + IF (LD2WE.GE.NQ) THEN + WRITE(UNIT,3310) + ELSE + WRITE(UNIT,3320) + END IF + ELSE + IF (LD2WE.GE.NQ) THEN + WRITE(UNIT,3410) + ELSE + WRITE(UNIT,3420) + END IF + END IF + END IF + IF (D4.EQ.2) THEN + WRITE(UNIT,3500) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS + + IF (D5.NE.0) THEN + IF (LDWD.GE.N) THEN + IF (LD2WD.GE.M) THEN + WRITE(UNIT,4310) + ELSE + WRITE(UNIT,4320) + END IF + ELSE + IF (LD2WD.GE.M) THEN + WRITE(UNIT,4410) + ELSE + WRITE(UNIT,4420) + END IF + END IF + END IF + + END IF + +C FORMAT STATEMENTS + + 1100 FORMAT + + (/' ERROR : N IS LESS THAN ONE.') + 1200 FORMAT + + (/' ERROR : M IS LESS THAN ONE.') + 1300 FORMAT + + (/' ERROR : NP IS LESS THAN ONE'/ + + ' OR NP IS GREATER THAN N.') + 1400 FORMAT + + (/' ERROR : NQ IS LESS THAN ONE.') + 2110 FORMAT + + (/' ERROR : LDX IS LESS THAN N.') + 2120 FORMAT + + (/' ERROR : LDY IS LESS THAN N.') + 2210 FORMAT + + (/' ERROR : LDIFX IS LESS THAN N'/ + + ' AND LDIFX IS NOT EQUAL TO ONE.') + 2220 FORMAT + + (/' ERROR : LDSCLD IS LESS THAN N'/ + + ' AND LDSCLD IS NOT EQUAL TO ONE.') + 2230 FORMAT + + (/' ERROR : LDSTPD IS LESS THAN N'/ + + ' AND LDSTPD IS NOT EQUAL TO ONE.') + 2310 FORMAT + + (/' ERROR : LDWE IS LESS THAN N'/ + + ' AND LDWE IS NOT EQUAL TO ONE OR'/ + + ' OR'/ + + ' LD2WE IS LESS THAN NQ'/ + + ' AND LD2WE IS NOT EQUAL TO ONE.') + 2320 FORMAT + + (/' ERROR : LDWD IS LESS THAN N'/ + + ' AND LDWD IS NOT EQUAL TO ONE.') + 2410 FORMAT + + (/' ERROR : LWORK IS LESS THAN ',I7, ','/ + + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.') + 2420 FORMAT + + (/' ERROR : LIWORK IS LESS THAN ',I7, ','/ + + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY', + + ' IWORK.') + 3110 FORMAT + + (/' ERROR : SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN'/ + + ' EACH OF THE N BY M ELEMENTS OF'/ + + ' SCLD MUST BE GREATER THAN ZERO.') + 3120 FORMAT + + (/' ERROR : SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME J = 1, ..., M.'// + + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSCLD IS EQUAL TO ONE THEN'/ + + ' EACH OF THE 1 BY M ELEMENTS OF'/ + + ' SCLD MUST BE GREATER THAN ZERO.') + 3130 FORMAT + + (/' ERROR : SCLB(K) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME K = 1, ..., NP.'// + + ' ALL NP ELEMENTS OF', + + ' SCLB MUST BE GREATER THAN ZERO.') + 3210 FORMAT + + (/' ERROR : STPD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSTPD IS GREATER THAN OR EQUAL TO N THEN'/ + + ' EACH OF THE N BY M ELEMENTS OF'/ + + ' STPD MUST BE GREATER THAN ZERO.') + 3220 FORMAT + + (/' ERROR : STPD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME J = 1, ..., M.'// + + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSTPD IS EQUAL TO ONE THEN'/ + + ' EACH OF THE 1 BY M ELEMENTS OF'/ + + ' STPD MUST BE GREATER THAN ZERO.') + 3230 FORMAT + + (/' ERROR : STPB(K) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME K = 1, ..., NP.'// + + ' ALL NP ELEMENTS OF', + + ' STPB MUST BE GREATER THAN ZERO.') + 3310 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (NQ BY NQ) ARRAYS STARTING'/ + + ' IN WE(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ + + ' SEMIDEFINITE. WHEN WE(1,1,1) IS GREATER THAN'/ + + ' OR EQUAL TO ZERO, AND LDWE IS GREATER THAN OR'/ + + ' EQUAL TO N, AND LD2WE IS GREATER THAN OR EQUAL'/ + + ' TO NQ, THEN EACH OF THE (NQ BY NQ) ARRAYS IN WE'/ + + ' MUST BE POSITIVE SEMIDEFINITE.') + 3320 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (1 BY NQ) ARRAYS STARTING'/ + + ' IN WE(I,1,1), I = 1, ..., N, HAS A NEGATIVE'/ + + ' ELEMENT. WHEN WE(1,1,1) IS GREATER THAN OR'/ + + ' EQUAL TO ZERO, AND LDWE IS GREATER THAN OR EQUAL'/ + + ' TO N, AND LD2WE IS EQUAL TO 1, THEN EACH OF THE'/ + + ' (1 BY NQ) ARRAYS IN WE MUST HAVE ONLY NON-'/ + + ' NEGATIVE ELEMENTS.') + 3410 FORMAT + + (/' ERROR : THE (NQ BY NQ) ARRAY STARTING IN WE(1,1,1) IS'/ + + ' NOT POSITIVE SEMIDEFINITE. WHEN WE(1,1,1) IS'/ + + ' GREATER THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL'/ + + ' TO 1, AND LD2WE IS GREATER THAN OR EQUAL TO NQ,'/ + + ' THEN THE (NQ BY NQ) ARRAY IN WE MUST BE POSITIVE'/ + + ' SEMIDEFINITE.') + 3420 FORMAT + + (/' ERROR : THE (1 BY NQ) ARRAY STARTING IN WE(1,1,1) HAS'/ + + ' A NEGATIVE ELEMENT. WHEN WE(1,1,1) IS GREATER'/ + + ' THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL TO 1,'/ + + ' AND LD2WE IS EQUAL TO 1, THEN THE (1 BY NQ)'/ + + ' ARRAY IN WE MUST HAVE ONLY NONNEGATIVE ELEMENTS.') + 3500 FORMAT + + (/' ERROR : THE NUMBER OF NONZERO ARRAYS IN ARRAY WE IS'/ + + ' LESS THAN NP.') + 4310 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (M BY M) ARRAYS STARTING'/ + + ' IN WD(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ + + ' DEFINITE. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ + + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ + + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN EACH'/ + + ' OF THE (M BY M) ARRAYS IN WD MUST BE POSITIVE'/ + + ' DEFINITE.') + 4320 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (1 BY M) ARRAYS STARTING'/ + + ' IN WD(I,1,1), I = 1, ..., N, HAS A NONPOSITIVE'/ + + ' ELEMENT. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ + + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ + + ' LD2WD IS EQUAL TO 1, THEN EACH OF THE (1 BY M)'/ + + ' ARRAYS IN WD MUST HAVE ONLY POSITIVE ELEMENTS.') + 4410 FORMAT + + (/' ERROR : THE (M BY M) ARRAY STARTING IN WD(1,1,1) IS'/ + + ' NOT POSITIVE DEFINITE. WHEN WD(1,1,1) IS'/ + + ' GREATER THAN ZERO, AND LDWD IS EQUAL TO 1, AND'/ + + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN THE'/ + + ' (M BY M) ARRAY IN WD MUST BE POSITIVE DEFINITE.') + 4420 FORMAT + + (/' ERROR : THE (1 BY M) ARRAY STARTING IN WD(1,1,1) HAS A'/ + + ' NONPOSITIVE ELEMENT. WHEN WD(1,1,1) IS GREATER'/ + + ' THAN ZERO, AND LDWD IS EQUAL TO 1, AND LD2WD IS'/ + + ' EQUAL TO 1, THEN THE (1 BY M) ARRAY IN WD MUST'/ + + ' HAVE ONLY POSITIVE ELEMENTS.') + END +*DODPE2 + SUBROUTINE DODPE2 + + (UNIT, + + N,M,NP,NQ, + + FJACB,FJACD, + + DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD, + + XPLUSD,NROW,NETA,NTOL) +C***BEGIN PROLOGUE DODPE2 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE THE DERIVATIVE CHECKING REPORT +C***END PROLOGUE DODPE2 + +C...SCALAR ARGUMENTS + INTEGER + + M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) + INTEGER + + MSGB(NQ,NP),MSGD(NQ,M) + +C...LOCAL SCALARS + INTEGER + + I,J,K,L + CHARACTER FLAG*1,TYP*3 + +C...LOCAL ARRAYS + LOGICAL + + FTNOTE(0:7) + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FLAG: THE CHARACTER STRING INDICATING HIGHLY QUESTIONABLE RESULTS. +C FTNOTE: THE ARRAY CONTROLING FOOTNOTES. +C I: AN INDEX VARIABLE. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C J: AN INDEX VARIABLE. +C K: AN INDEX VARIABLE. +C L: AN INDEX VARIABLE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. +C TYP: THE CHARACTER STRING INDICATING SOLUTION TYPE, ODR OR OLS. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODPE2 + + +C SET UP FOR FOOTNOTES + + DO 10 I=0,7 + FTNOTE(I) = .FALSE. + 10 CONTINUE + + DO 40 L=1,NQ + IF (MSGB1.GE.1) THEN + DO 20 I=1,NP + IF (MSGB(L,I).GE.1) THEN + FTNOTE(0) = .TRUE. + FTNOTE(MSGB(L,I)) = .TRUE. + END IF + 20 CONTINUE + END IF + + IF (MSGD1.GE.1) THEN + DO 30 I=1,M + IF (MSGD(L,I).GE.1) THEN + FTNOTE(0) = .TRUE. + FTNOTE(MSGD(L,I)) = .TRUE. + END IF + 30 CONTINUE + END IF + 40 CONTINUE + +C PRINT REPORT + + IF (ISODR) THEN + TYP = 'ODR' + ELSE + TYP = 'OLS' + END IF + WRITE (UNIT,1000) TYP + + DO 70 L=1,NQ + + WRITE (UNIT,2100) L,NROW + WRITE (UNIT,2200) + + DO 50 I=1,NP + K = MSGB(L,I) + IF (K.GE.7) THEN + FLAG = '*' + ELSE + FLAG = ' ' + END IF + IF (K.LE.-1) THEN + WRITE (UNIT,3100) I + ELSE IF (K.EQ.0) THEN + WRITE (UNIT,3200) I,FJACB(NROW,I,L),DIFF(L,I),FLAG + ELSE IF (K.GE.1) THEN + WRITE (UNIT,3300) I,FJACB(NROW,I,L),DIFF(L,I),FLAG,K + END IF + 50 CONTINUE + IF (ISODR) THEN + DO 60 I=1,M + K = MSGD(L,I) + IF (K.GE.7) THEN + FLAG = '*' + ELSE + FLAG = ' ' + END IF + IF (K.LE.-1) THEN + WRITE (UNIT,4100) NROW,I + ELSE IF (K.EQ.0) THEN + WRITE (UNIT,4200) NROW,I, + + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG + ELSE IF (K.GE.1) THEN + WRITE (UNIT,4300) NROW,I, + + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG,K + END IF + 60 CONTINUE + END IF + 70 CONTINUE + +C PRINT FOOTNOTES + + IF (FTNOTE(0)) THEN + + WRITE (UNIT,5000) + IF (FTNOTE(1)) WRITE (UNIT,5100) + IF (FTNOTE(2)) WRITE (UNIT,5200) + IF (FTNOTE(3)) WRITE (UNIT,5300) + IF (FTNOTE(4)) WRITE (UNIT,5400) + IF (FTNOTE(5)) WRITE (UNIT,5500) + IF (FTNOTE(6)) WRITE (UNIT,5600) + IF (FTNOTE(7)) WRITE (UNIT,5700) + END IF + + IF (NETA.LT.0) THEN + WRITE (UNIT,6000) -NETA + ELSE + WRITE (UNIT,6100) NETA + END IF + WRITE (UNIT,7000) NTOL + +C PRINT OUT ROW OF EXPLANATORY VARIABLE WHICH WAS CHECKED. + + WRITE (UNIT,8100) NROW + + DO 80 J=1,M + WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J) + 80 CONTINUE + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (//' *** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3, + + ' ***'/) + 2100 FORMAT (/' FOR RESPONSE ',I2,' OF OBSERVATION ', I5/) + 2200 FORMAT (' ',' USER', + + ' ',' '/ + + ' ',' SUPPLIED', + + ' RELATIVE',' DERIVATIVE '/ + + ' DERIVATIVE WRT',' VALUE', + + ' DIFFERENCE',' ASSESSMENT '/) + 3100 FORMAT (' BETA(',I3,')', ' --- ', + + ' --- ',' UNCHECKED') + 3200 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, + + 'VERIFIED') + 3300 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, + + 'QUESTIONABLE (SEE NOTE ',I1,')') + 4100 FORMAT (' DELTA(',I2,',',I2,')', ' --- ', + + ' --- ',' UNCHECKED') + 4200 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, + + 'VERIFIED') + 4300 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, + + 'QUESTIONABLE (SEE NOTE ',I1,')') + 5000 FORMAT + + (/' NOTES:') + 5100 FORMAT + + (/' (1) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' AGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE BOTH ARE ZERO.') + 5200 FORMAT + + (/' (2) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' AGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', + + ' IDENTICALLY ZERO'/ + + ' AND THE OTHER IS ONLY APPROXIMATELY ZERO.') + 5300 FORMAT + + (/' (3) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', + + ' IDENTICALLY ZERO'/ + + ' AND THE OTHER IS NOT.') + 5400 FORMAT + + (/' (4) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', + + ' BECAUSE EITHER'/ + + ' THE RATIO OF RELATIVE CURVATURE TO RELATIVE', + + ' SLOPE IS TOO HIGH'/ + + ' OR THE SCALE IS WRONG.') + 5500 FORMAT + + (/' (5) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', + + ' BECAUSE THE'/ + + ' RATIO OF RELATIVE CURVATURE TO RELATIVE SLOPE IS', + + ' TOO HIGH.') + 5600 FORMAT + + (/' (6) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' HAVE AT LEAST 2 DIGITS IN COMMON.') + 5700 FORMAT + + (/' (7) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, AND'/ + + ' HAVE FEWER THAN 2 DIGITS IN COMMON. DERIVATIVE', + + ' CHECKING MUST'/ + + ' BE TURNED OFF IN ORDER TO PROCEED.') + 6000 FORMAT + + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', + + I5/ + + ' (ESTIMATED BY ODRPACK)') + 6100 FORMAT + + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', + + I5/ + + ' (SUPPLIED BY USER)') + 7000 FORMAT + + (/' NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN '/ + + ' USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR '/ + + ' USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED ', + + I5) + 8100 FORMAT + + (/' ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED ', + + I5// + + ' -VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW'/) + 8110 FORMAT + + (10X,'X(',I2,',',I2,')',1X,1P,3D16.8) + END +*DODPE3 + SUBROUTINE DODPE3 + + (UNIT,D2,D3) +C***BEGIN PROLOGUE DODPE3 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ERROR REPORTS INDICATING THAT COMPUTATIONS WERE +C STOPPED IN USER SUPPLIED SUBROUTINES FCN +C***END PROLOGUE DODPE3 + +C...SCALAR ARGUMENTS + INTEGER + + D2,D3,UNIT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. + + +C***FIRST EXECUTABLE STATEMENT DODPE3 + + +C PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE +C STOPPED + + IF (D2.EQ.2) THEN + WRITE(UNIT,1100) + ELSE IF (D2.EQ.3) THEN + WRITE(UNIT,1200) + ELSE IF (D2.EQ.4) THEN + WRITE(UNIT,1300) + END IF + IF (D3.EQ.2) THEN + WRITE(UNIT,1400) + END IF + +C FORMAT STATEMENTS + + 1100 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED USING THE'/ + + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ + + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ + + ' PROPER EVALUATION OF SUBROUTINE FCN BEFORE THE '/ + + ' REGRESSION PROCEDURE CAN CONTINUE.') + 1200 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ + + ' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE '/ + + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, INDI-'/ + + ' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),'/ + + ' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION), '/ + + ' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE'/ + + ' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT '/ + + ' SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. THE '/ + + ' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ + + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') + 1300 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ + + ' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT '/ + + ' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS '/ + + ' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR '/ + + ' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS '/ + + ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA '/ + + ' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN '/ + + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, '/ + + ' PREVENT SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. '/ + + ' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ + + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') + 1400 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED FOR '/ + + ' DERIVATIVE EVALUATIONS USING THE INITIAL ESTIMATES OF '/ + + ' BETA AND DELTA SUPPLIED BY THE USER. THE INITIAL '/ + + ' ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER EVALUATION '/ + + ' OF SUBROUTINE FCN BEFORE THE REGRESSION PROCEDURE CAN '/ + + ' CONTINUE.') + END +*DODPER + SUBROUTINE DODPER + + (INFO,LUNERR,SHORT, + + N,M,NP,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN, + + FJACB,FJACD, + + DIFF,MSGB,ISODR,MSGD, + + XPLUSD,NROW,NETA,NTOL) +C***BEGIN PROLOGUE DODPER +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DODPE1,DODPE2,DODPE3,DODPHD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS +C***END PROLOGUE DODPER + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,LIWKMN,LUNERR,LWKMN, + + M,N,NETA,NP,NQ,NROW,NTOL + LOGICAL + + ISODR,SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) + INTEGER + + MSGB(NQ*NP+1),MSGD(NQ*M+1) + +C...LOCAL SCALARS + INTEGER + + D1,D2,D3,D4,D5,UNIT + LOGICAL + + HEAD + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODPE1,DODPE2,DODPE3,DODPHD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. +C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C UNIT: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C XPLUSD: THE VALUES X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODPER + + +C SET LOGICAL UNIT NUMBER FOR ERROR REPORT + + IF (LUNERR.EQ.0) THEN + RETURN + ELSE IF (LUNERR.LT.0) THEN + UNIT = 6 + ELSE + UNIT = LUNERR + END IF + +C PRINT HEADING + + HEAD = .TRUE. + CALL DODPHD(HEAD,UNIT) + +C EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO + + D1 = MOD(INFO,100000)/10000 + D2 = MOD(INFO,10000)/1000 + D3 = MOD(INFO,1000)/100 + D4 = MOD(INFO,100)/10 + D5 = MOD(INFO,10) + +C PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP + + IF (D1.GE.1 .AND. D1.LE.3) THEN + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN +C PROBLEM SPECIFICATION PARAMETERS +C DIMENSION SPECIFICATION PARAMETERS +C NUMBER OF GOOD DIGITS IN X +C WEIGHTS + + CALL DODPE1(UNIT,D1,D2,D3,D4,D5, + + N,M,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN) + + ELSE IF ((D1.EQ.4) .OR. (MSGB(1).GE.0)) THEN + +C PRINT APPROPRIATE MESSAGES FOR DERIVATIVE CHECKING + + CALL DODPE2(UNIT, + + N,M,NP,NQ, + + FJACB,FJACD, + + DIFF,MSGB(1),MSGB(2),ISODR,MSGD(1),MSGD(2), + + XPLUSD,NROW,NETA,NTOL) + + ELSE IF (D1.EQ.5) THEN + +C PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FCN + + CALL DODPE3(UNIT,D2,D3) + + END IF + +C PRINT CORRECT FORM OF CALL STATEMENT + + IF ((D1.GE.1 .AND. D1.LE.3) .OR. + + (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. + + (D1.EQ.5)) THEN + IF (SHORT) THEN + WRITE (UNIT,1100) + ELSE + WRITE (UNIT,1200) + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1100 FORMAT + + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + + ' CALL DODR'/ + + ' + (FCN,'/ + + ' + N,M,NP,NQ,'/ + + ' + BETA,'/ + + ' + Y,LDY,X,LDX,'/ + + ' + WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/ + + ' + JOB,'/ + + ' + IPRINT,LUNERR,LUNRPT,'/ + + ' + WORK,LWORK,IWORK,LIWORK,'/ + + ' + INFO)') + 1200 FORMAT + + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + + ' CALL DODRC'/ + + ' + (FCN,'/ + + ' + N,M,NP,NQ,'/ + + ' + BETA,'/ + + ' + Y,LDY,X,LDX,'/ + + ' + WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/ + + ' + IFIXB,IFIXX,LDIFX,'/ + + ' + JOB,NDIGIT,TAUFAC,'/ + + ' + SSTOL,PARTOL,MAXIT,'/ + + ' + IPRINT,LUNERR,LUNRPT,'/ + + ' + STPB,STPD,LDSTPD,'/ + + ' + SCLB,SCLD,LDSCLD,'/ + + ' + WORK,LWORK,IWORK,LIWORK,'/ + + ' + INFO)') + + END +*DODPHD + SUBROUTINE DODPHD + + (HEAD,UNIT) +C***BEGIN PROLOGUE DODPHD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ODRPACK HEADING +C***END PROLOGUE DODPHD + +C...SCALAR ARGUMENTS + INTEGER + + UNIT + LOGICAL + + HEAD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). +C UNIT: THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN. + + +C***FIRST EXECUTABLE STATEMENT DODPHD + + + IF (HEAD) THEN + WRITE(UNIT,1000) + HEAD = .FALSE. + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT ( + + ' ******************************************************* '/ + + ' * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * '/ + + ' ******************************************************* '/) + END +*DODSTP + SUBROUTINE DODSTP + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,KPVT, + + S,T,PHI,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODSTP +C***REFER TO DODR,DODRC +C***ROUTINES CALLED IDAMAX,DCHEX,DESUBI,DFCTR,DNRM2,DQRDC,DQRSL,DROT, +C DROTG,DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA) +C***END PROLOGUE DODSTP + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA,EPSFCN,PHI,RCOND + INTEGER + + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),WRK(LWRK) + INTEGER + + KPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + CO,ONE,SI,TEMP,ZERO + INTEGER + + I,IMAX,INF,IPVT,J,K,K1,K2,KP,L + LOGICAL + + ELIM,FORVCV + +C...LOCAL ARRAYS + DOUBLE PRECISION + + DUM(2) + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DNRM2 + INTEGER + + IDAMAX + EXTERNAL + + DNRM2,IDAMAX + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCHEX,DESUBI,DFCTR,DQRDC,DQRSL,DROT,DROTG, + + DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C CO: THE COSINE FROM THE PLANE ROTATION. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DUM: A DUMMY ARRAY. +C ELIM: THE VARIABLE DESIGNATING WHETHER COLUMNS OF THE JACOBIAN +C WRT BETA HAVE BEEN ELIMINATED (ELIM=TRUE) OR NOT +C (ELIM=FALSE). +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE +C VALUE. +C INF: THE RETURN CODE FROM LINPACK ROUTINES. +C IPVT: THE VARIABLE DESIGNATING WHETHER PIVOTING IS TO BE DONE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C K1: AN INDEXING VARIABLE. +C K2: AN INDEXING VARIABLE. +C KP: THE RANK OF THE JACOBIAN WRT BETA. +C KPVT: THE PIVOT VECTOR. +C L: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C OMEGA: THE ARRAY DEFINED S.T. +C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) +C = (I-FJACD*INV(P)*TRANS(FJACD)) +C WHERE E = D**2 + ALPHA*TT**2 +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C ONE: THE VALUE 1.0D0. +C PHI: THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. +C S: THE STEP FOR BETA. +C SI: THE SINE FROM THE PLANE ROTATION. +C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. +C T: THE STEP FOR DELTA. +C TEMP: A TEMPORARY STORAGE LOCATION. +C TFJACB: THE ARRAY OMEGA*FJACB. +C TT: THE SCALING VALUES FOR DELTA. +C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. +C WD: THE (SQUARED) DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODSTP + + +C COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE + +C SET UP KPVT IF ALPHA = 0 + + IF (ALPHA.EQ.ZERO) THEN + KP = NPP + DO 10 K=1,NP + KPVT(K) = K + 10 CONTINUE + ELSE + IF (NPP.GE.1) THEN + KP = NPP-IRANK + ELSE + KP = NPP + END IF + END IF + + IF (ISODR) THEN + +C T = WD * DELTA = D*G2 + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,T,N) + + DO 300 I=1,N + +C COMPUTE WRK4, SUCH THAT +C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) + CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE OMEGA, SUCH THAT +C TRANS(OMEGA)*OMEGA = I+FJACD*INV(E)*TRANS(FJACD) +C INV(TRANS(OMEGA)*OMEGA) = I-FJACD*INV(P)*TRANS(FJACD) + CALL DVEVTR(M,NQ,I, + + FJACD,N,M, WRK4,M, WRK1,N,NQ, OMEGA,NQ, WRK5) + DO 110 L=1,NQ + OMEGA(L,L) = ONE + OMEGA(L,L) + 110 CONTINUE + CALL DFCTR(.FALSE.,OMEGA,NQ,NQ,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) +C = TRANS(FJACD)*INV(TRANS(OMEGA)*OMEGA) + DO 130 J=1,M + DO 120 L=1,NQ + WRK1(I,L,J) = FJACD(I,J,L) + 120 CONTINUE + CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,4) + CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,2) + 130 CONTINUE + +C COMPUTE WRK5 = INV(E)*D*G2 + DO 140 J=1,M + WRK5(J) = T(I,J) + 140 CONTINUE + CALL DSOLVE(M,WRK4,M,WRK5,1,4) + CALL DSOLVE(M,WRK4,M,WRK5,1,2) + +C COMPUTE TFJACB = INV(TRANS(OMEGA))*FJACB + DO 170 K=1,KP + DO 150 L=1,NQ + TFJACB(I,L,K) = FJACB(I,KPVT(K),L) + 150 CONTINUE + CALL DSOLVE(NQ,OMEGA,NQ,TFJACB(I,1,K),N,4) + DO 160 L=1,NQ + IF (SS(1).GT.ZERO) THEN + TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) + ELSE + TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) + END IF + 160 CONTINUE + 170 CONTINUE + +C COMPUTE WRK2 = (V*INV(E)*D**2*G2 - G1) + DO 190 L=1,NQ + WRK2(I,L) = ZERO + DO 180 J=1,M + WRK2(I,L) = WRK2(I,L) + FJACD(I,J,L)*WRK5(J) + 180 CONTINUE + WRK2(I,L) = WRK2(I,L) - F(I,L) + 190 CONTINUE + +C COMPUTE WRK2 = INV(TRANS(OMEGA))*(V*INV(E)*D**2*G2 - G1) + CALL DSOLVE(NQ,OMEGA,NQ,WRK2(I,1),N,4) + 300 CONTINUE + + ELSE + DO 360 I=1,N + DO 350 L=1,NQ + DO 340 K=1,KP + TFJACB(I,L,K) = FJACB(I,KPVT(K),L) + IF (SS(1).GT.ZERO) THEN + TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) + ELSE + TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) + END IF + 340 CONTINUE + WRK2(I,L) = -F(I,L) + 350 CONTINUE + 360 CONTINUE + END IF + +C COMPUTE S + +C DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0) + + IF (ALPHA.EQ.ZERO) THEN + IPVT = 1 + DO 410 K=1,NP + KPVT(K) = 0 + 410 CONTINUE + ELSE + IPVT = 0 + END IF + + CALL DQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT) + CALL DQRSL(TFJACB,N*NQ,N*NQ,KP, + + QRAUX,WRK2,DUM,WRK2,DUM,DUM,DUM,1000,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C ELIMINATE ALPHA PART USING GIVENS ROTATIONS + + IF (ALPHA.NE.ZERO) THEN + CALL DZERO(NPP,1,S,NPP) + DO 430 K1=1,KP + CALL DZERO(KP,1,WRK3,KP) + WRK3(K1) = SQRT(ALPHA) + DO 420 K2=K1,KP + CALL DROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI) + IF (KP-K2.GE.1) THEN + CALL DROT(KP-K2,TFJACB(K2,1,K2+1),N*NQ, + + WRK3(K2+1),1,CO,SI) + END IF + TEMP = CO*WRK2(K2,1) + SI*S(KPVT(K1)) + S(KPVT(K1)) = -SI*WRK2(K2,1) + CO*S(KPVT(K1)) + WRK2(K2,1) = TEMP + 420 CONTINUE + 430 CONTINUE + END IF + +C COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY + + IF (NPP.GE.1) THEN + IF (ALPHA.EQ.ZERO) THEN + KP = NPP + +C ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR + + 440 CALL DTRCO(TFJACB,N*NQ,KP,RCOND,U,1) + IF (RCOND.LE.EPSFCN) THEN + ELIM = .TRUE. + IMAX = IDAMAX(KP,U,1) + +C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX KPVT + + IF (IMAX.NE.KP) THEN + CALL DCHEX(TFJACB,N*NQ,KP,IMAX,KP,WRK2,N*NQ,1, + + QRAUX,WRK3,2) + K = KPVT(IMAX) + DO 450 I=IMAX,KP-1 + KPVT(I) = KPVT(I+1) + 450 CONTINUE + KPVT(KP) = K + END IF + KP = KP-1 + ELSE + ELIM = .FALSE. + END IF + IF (ELIM .AND. KP.GE.1) THEN + GO TO 440 + ELSE + IRANK = NPP-KP + END IF + END IF + END IF + + IF (FORVCV) RETURN + +C BACKSOLVE AND UNSCRAMBLE + + IF (NPP.GE.1) THEN + DO 510 I=KP+1,NPP + WRK2(I,1) = ZERO + 510 CONTINUE + IF (KP.GE.1) THEN + CALL DTRSL(TFJACB,N*NQ,KP,WRK2,01,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + END IF + DO 520 I=1,NPP + IF (SS(1).GT.ZERO) THEN + S(KPVT(I)) = WRK2(I,1)/SS(KPVT(I)) + ELSE + S(KPVT(I)) = WRK2(I,1)/ABS(SS(1)) + END IF + 520 CONTINUE + END IF + + IF (ISODR) THEN + +C NOTE: T AND WRK1 HAVE BEEN INITIALIZED ABOVE, +C WHERE T = WD * DELTA = D*G2 +C WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) + + DO 670 I=1,N + +C COMPUTE WRK4, SUCH THAT +C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) + CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE WRK5 = INV(E)*D*G2 + DO 610 J=1,M + WRK5(J) = T(I,J) + 610 CONTINUE + CALL DSOLVE(M,WRK4,M,WRK5,1,4) + CALL DSOLVE(M,WRK4,M,WRK5,1,2) + + DO 640 L=1,NQ + WRK2(I,L) = F(I,L) + DO 620 K=1,NPP + WRK2(I,L) = WRK2(I,L) + FJACB(I,K,L)*S(K) + 620 CONTINUE + DO 630 J=1,M + WRK2(I,L) = WRK2(I,L) - FJACD(I,J,L)*WRK5(J) + 630 CONTINUE + 640 CONTINUE + + DO 660 J=1,M + WRK5(J) = ZERO + DO 650 L=1,NQ + WRK5(J) = WRK5(J) + WRK1(I,L,J)*WRK2(I,L) + 650 CONTINUE + T(I,J) = -(WRK5(J) + T(I,J)) + 660 CONTINUE + CALL DSOLVE(M,WRK4,M,T(I,1),N,4) + CALL DSOLVE(M,WRK4,M,T(I,1),N,2) + 670 CONTINUE + + END IF + +C COMPUTE PHI(ALPHA) FROM SCALED S AND T + + CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) + PHI = DNRM2(NPP+N*M,WRK,1) + ELSE + PHI = DNRM2(NPP,WRK,1) + END IF + + RETURN + END +*DODVCV + SUBROUTINE DODVCV + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + + EPSFCN,ISODR, + + VCV,SD, + + WRK6,OMEGA,U,QRAUX,JPVT, + + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODVCV +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPODI,DODSTP +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS +C***END PROLOGUE DODVCV + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSFCN,RCOND,RSS,RVAR + INTEGER + + IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ), + + FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SD(NP),SS(NP),SSF(NP), + + T(N,M),TT(LDTT,M),U(NP),VCV(NP,NP),WD(LDWD,LD2WD,M), + + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M), + + WRK6(N*NQ,NP),WRK(LWRK) + INTEGER + + IFIXB(NP),JPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + I,IUNFIX,J,JUNFIX,KP,L + LOGICAL + + FORVCV + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPODI,DODSTP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SQRT + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER SUBROUTINE DODSTP IS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE +C VALUE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. +C IUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. +C J: AN INDEXING VARIABLE. +C JPVT: THE PIVOT VECTOR. +C JUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. +C KP: THE RANK OF THE JACOBIAN WRT BETA. +C L: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OMEGA: THE ARRAY DEFINED S.T. +C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) +C = (I-FJACD*INV(P)*TRANS(FJACD)) +C WHERE E = D**2 + ALPHA*TT**2 +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C RSS: THE RESIDUAL SUM OF SQUARES. +C RVAR: THE RESIDUAL VARIANCE. +C S: THE STEP FOR BETA. +C SD: THE STANDARD DEVIATIONS OF THE ESTIMATED BETAS. +C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. +C SSF: THE SCALING VALUES USED FOR BETA. +C T: THE STEP FOR DELTA. +C TEMP: A TEMPORARY STORAGE LOCATION +C TT: THE SCALING VALUES FOR DELTA. +C U: THE APPROXIMATE NULL VECTOR FOR FJACB. +C VCV: THE COVARIANCE MATRIX OF THE ESTIMATED BETAS. +C WD: THE DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C WRK6: A WORK ARRAY OF (N*NQ BY P) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODVCV + + + FORVCV = .TRUE. + ISTOPC = 0 + + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ZERO,EPSFCN,ISODR, + + WRK6,OMEGA,U,QRAUX,JPVT, + + S,T,TEMP,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + KP = NPP - IRANK + CALL DPODI (WRK6,N*NQ,KP,WRK3,1) + + IDF = 0 + DO 150 I=1,N + DO 120 J=1,NPP + DO 110 L=1,NQ + IF (FJACB(I,J,L).NE.ZERO) THEN + IDF = IDF + 1 + GO TO 150 + END IF + 110 CONTINUE + 120 CONTINUE + IF (ISODR) THEN + DO 140 J=1,M + DO 130 L=1,NQ + IF (FJACD(I,J,L).NE.ZERO) THEN + IDF = IDF + 1 + GO TO 150 + END IF + 130 CONTINUE + 140 CONTINUE + END IF + 150 CONTINUE + + IF (IDF.GT.KP) THEN + IDF = IDF - KP + RVAR = RSS/IDF + ELSE + IDF = 0 + RVAR = RSS + END IF + +C STORE VARIANCES IN SD, RESTORING ORIGINAL ORDER + + DO 200 I=1,NP + SD(I) = ZERO + 200 CONTINUE + DO 210 I=1,KP + SD(JPVT(I)) = WRK6(I,I) + 210 CONTINUE + IF (NP.GT.NPP) THEN + JUNFIX = NPP + DO 220 J=NP,1,-1 + IF (IFIXB(J).EQ.0) THEN + SD(J) = ZERO + ELSE + SD(J) = SD(JUNFIX) + JUNFIX = JUNFIX - 1 + END IF + 220 CONTINUE + END IF + +C STORE COVARIANCE MATRIX IN VCV, RESTORING ORIGINAL ORDER + + DO 310 I=1,NP + DO 300 J=1,I + VCV(I,J) = ZERO + 300 CONTINUE + 310 CONTINUE + DO 330 I=1,KP + DO 320 J=I+1,KP + IF (JPVT(I).GT.JPVT(J)) THEN + VCV(JPVT(I),JPVT(J))=WRK6(I,J) + ELSE + VCV(JPVT(J),JPVT(I))=WRK6(I,J) + END IF + 320 CONTINUE + 330 CONTINUE + IF (NP.GT.NPP) THEN + IUNFIX = NPP + DO 360 I=NP,1,-1 + IF (IFIXB(I).EQ.0) THEN + DO 340 J=I,1,-1 + VCV(I,J) = ZERO + 340 CONTINUE + ELSE + JUNFIX = NPP + DO 350 J=NP,1,-1 + IF (IFIXB(J).EQ.0) THEN + VCV(I,J) = ZERO + ELSE + VCV(I,J) = VCV(IUNFIX,JUNFIX) + JUNFIX = JUNFIX - 1 + END IF + 350 CONTINUE + IUNFIX = IUNFIX - 1 + END IF + 360 CONTINUE + END IF + + DO 380 I=1,NP + VCV(I,I) = SD(I) + SD(I) = SQRT(RVAR*SD(I)) + DO 370 J=1,I + VCV(J,I) = VCV(I,J) + 370 CONTINUE + 380 CONTINUE + +C UNSCALE STANDARD ERRORS AND COVARIANCE MATRIX + DO 410 I=1,NP + IF (SSF(1).GT.ZERO) THEN + SD(I) = SD(I)/SSF(I) + ELSE + SD(I) = SD(I)/ABS(SSF(1)) + END IF + DO 400 J=1,NP + IF (SSF(1).GT.ZERO) THEN + VCV(I,J) = VCV(I,J)/(SSF(I)*SSF(J)) + ELSE + VCV(I,J) = VCV(I,J)/(SSF(1)*SSF(1)) + END IF + 400 CONTINUE + 410 CONTINUE + + RETURN + END +*DPACK + SUBROUTINE DPACK + + (N2,N1,V1,V2,IFIX) +C***BEGIN PROLOGUE DPACK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DCOPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1 +C***END PROLOGUE DPACK + +C...SCALAR ARGUMENTS + INTEGER + + N1,N2 + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + V1(N2),V2(N2) + INTEGER + + IFIX(N2) + +C...LOCAL SCALARS + INTEGER + + I + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C N1: THE NUMBER OF ITEMS IN V1. +C N2: THE NUMBER OF ITEMS IN V2. +C V1: THE VECTOR OF THE UNFIXED ITEMS FROM V2. +C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE +C UNFIXED ELEMENTS ARE TO BE EXTRACTED. + + +C***FIRST EXECUTABLE STATEMENT DPACK + + + N1 = 0 + IF (IFIX(1).GE.0) THEN + DO 10 I=1,N2 + IF (IFIX(I).NE.0) THEN + N1 = N1+1 + V1(N1) = V2(I) + END IF + 10 CONTINUE + ELSE + N1 = N2 + CALL DCOPY(N2,V2,1,V1,1) + END IF + + RETURN + END +*DPPNML + DOUBLE PRECISION FUNCTION DPPNML + + (P) +C***BEGIN PROLOGUE DPPNML +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***AUTHOR FILLIBEN, JAMES J., +C STATISTICAL ENGINEERING DIVISION +C NATIONAL BUREAU OF STANDARDS +C WASHINGTON, D. C. 20234 +C (ORIGINAL VERSION--JUNE 1972. +C (UPDATED --SEPTEMBER 1975, +C NOVEMBER 1975, AND +C OCTOBER 1976. +C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE +C NORMAL (GAUSSIAN) DISTRIBUTION WITH MEAN 0 AND STANDARD +C DEVIATION 1, AND WITH PROBABILITY DENSITY FUNCTION +C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). +C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS +C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) +C***DESCRIPTION +C --THE CODING AS PRESENTED BELOW IS ESSENTIALLY +C IDENTICAL TO THAT PRESENTED BY ODEH AND EVANS +C AS ALGORTIHM 70 OF APPLIED STATISTICS. +C --AS POINTED OUT BY ODEH AND EVANS IN APPLIED +C STATISTICS, THEIR ALGORITHM REPRESENTES A +C SUBSTANTIAL IMPROVEMENT OVER THE PREVIOUSLY EMPLOYED +C HASTINGS APPROXIMATION FOR THE NORMAL PERCENT POINT +C FUNCTION, WITH ACCURACY IMPROVING FROM 4.5*(10**-4) +C TO 1.5*(10**-8). +C***REFERENCES ODEH AND EVANS, THE PERCENTAGE POINTS OF THE NORMAL +C DISTRIBUTION, ALGORTIHM 70, APPLIED STATISTICS, 1974, +C PAGES 96-97. +C EVANS, ALGORITHMS FOR MINIMAL DEGREE POLYNOMIAL AND +C RATIONAL APPROXIMATION, M. SC. THESIS, 1972, +C UNIVERSITY OF VICTORIA, B. C., CANADA. +C HASTINGS, APPROXIMATIONS FOR DIGITAL COMPUTERS, 1955, +C PAGES 113, 191, 192. +C NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS +C SERIES 55, 1964, PAGE 933, FORMULA 26.2.23. +C FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE +C LOCATION PARAMETER OF A SYMMETRIC DISTRIBUTION +C (UNPUBLISHED PH.D. DISSERTATION, PRINCETON +C UNIVERSITY), 1969, PAGES 21-44, 229-231. +C FILLIBEN, "THE PERCENT POINT FUNCTION", +C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. +C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, +C VOLUME 1, 1970, PAGES 40-111. +C KELLEY STATISTICAL TABLES, 1948. +C OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, PAGES 3-16. +C PEARSON AND HARTLEY, BIOMETRIKA TABLES FOR +C STATISTICIANS, VOLUME 1, 1954, PAGES 104-113. +C***END PROLOGUE DPPNML + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + P + +C...LOCAL SCALARS + DOUBLE PRECISION + + ADEN,ANUM,HALF,ONE,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T,TWO,ZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + LOG,SQRT + +C...DATA STATEMENTS + DATA + + P0,P1,P2,P3,P4 + + /-0.322232431088D0,-1.0D0,-0.342242088547D0, + + -0.204231210245D-1,-0.453642210148D-4/ + DATA + + Q0,Q1,Q2,Q3,Q4 + + /0.993484626060D-1,0.588581570495D0, + + 0.531103462366D0,0.103537752850D0,0.38560700634D-2/ + DATA + + ZERO,HALF,ONE,TWO + + /0.0D0,0.5D0,1.0D0,2.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ADEN: A VALUE USED IN THE APPROXIMATION. +C ANUM: A VALUE USED IN THE APPROXIMATION. +C HALF: THE VALUE 0.5D0. +C ONE: THE VALUE 1.0D0. +C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE +C EVALUATED. P MUST BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVE. +C P0: A PARAMETER USED IN THE APPROXIMATION. +C P1: A PARAMETER USED IN THE APPROXIMATION. +C P2: A PARAMETER USED IN THE APPROXIMATION. +C P3: A PARAMETER USED IN THE APPROXIMATION. +C P4: A PARAMETER USED IN THE APPROXIMATION. +C Q0: A PARAMETER USED IN THE APPROXIMATION. +C Q1: A PARAMETER USED IN THE APPROXIMATION. +C Q2: A PARAMETER USED IN THE APPROXIMATION. +C Q3: A PARAMETER USED IN THE APPROXIMATION. +C Q4: A PARAMETER USED IN THE APPROXIMATION. +C R: THE PROBABILITY AT WHICH THE PERCENT POINT IS EVALUATED. +C T: A VALUE USED IN THE APPROXIMATION. +C TWO: THE VALUE 2.0D0. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DPPT + + + IF (P.EQ.HALF) THEN + DPPNML = ZERO + + ELSE + R = P + IF (P.GT.HALF) R = ONE - R + T = SQRT(-TWO*LOG(R)) + ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0) + ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0) + DPPNML = T + (ANUM/ADEN) + + IF (P.LT.HALF) DPPNML = -DPPNML + END IF + + RETURN + + END +*DPPT + DOUBLE PRECISION FUNCTION DPPT + + (P, IDF) +C***BEGIN PROLOGUE DPPT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPPNML +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***AUTHOR FILLIBEN, JAMES J., +C STATISTICAL ENGINEERING DIVISION +C NATIONAL BUREAU OF STANDARDS +C WASHINGTON, D. C. 20234 +C (ORIGINAL VERSION--OCTOBER 1975.) +C (UPDATED --NOVEMBER 1975.) +C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE +C STUDENT'S T DISTRIBUTION WITH IDF DEGREES OF FREEDOM. +C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS +C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) +C***DESCRIPTION +C --FOR IDF = 1 AND IDF = 2, THE PERCENT POINT FUNCTION +C FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM +C AND SO THE COMPUTED PERCENT POINTS ARE EXACT. +C --FOR IDF BETWEEN 3 AND 6, INCLUSIVELY, THE APPROXIMATION +C IS AUGMENTED BY 3 ITERATIONS OF NEWTON'S METHOD TO +C IMPROVE THE ACCURACY, ESPECIALLY FOR P NEAR 0 OR 1. +C***REFERENCES NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS +C SERIES 55, 1964, PAGE 949, FORMULA 26.7.5. +C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, +C VOLUME 2, 1970, PAGE 102, FORMULA 11. +C FEDERIGHI, "EXTENDED TABLES OF THE PERCENTAGE POINTS +C OF STUDENT"S T DISTRIBUTION, JOURNAL OF THE AMERICAN +C STATISTICAL ASSOCIATION, 1969, PAGES 683-688. +C HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS, A +C HANDBOOK FOR STUDENTS AND PRACTITIONERS, 1975, +C PAGES 120-123. +C***END PROLOGUE DPPT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + P + INTEGER + + IDF + +C...LOCAL SCALARS + DOUBLE PRECISION + + ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45, + + B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,EIGHT,FIFTN, + + HALF,ONE,PI,PPFN,S,TERM1,TERM2,TERM3,TERM4,TERM5,THREE,TWO, + + Z,ZERO + INTEGER + + IPASS,MAXIT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DPPNML + EXTERNAL + + DPPNML + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ATAN,COS,SIN,SQRT + +C...DATA STATEMENTS + DATA + + B21 + + /4.0D0/ + DATA + + B31, B32, B33, B34 + + /96.0D0,5.0D0,16.0D0,3.0D0/ + DATA + + B41, B42, B43, B44, B45 + + /384.0D0,3.0D0,19.0D0,17.0D0,-15.0D0/ + DATA + + B51,B52,B53,B54,B55,B56 + + /9216.0D0,79.0D0,776.0D0,1482.0D0,-1920.0D0,-945.0D0/ + DATA + + ZERO,HALF,ONE,TWO,THREE,EIGHT,FIFTN + + /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,8.0D0,15.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ARG: A VALUE USED IN THE APPROXIMATION. +C B21: A PARAMETER USED IN THE APPROXIMATION. +C B31: A PARAMETER USED IN THE APPROXIMATION. +C B32: A PARAMETER USED IN THE APPROXIMATION. +C B33: A PARAMETER USED IN THE APPROXIMATION. +C B34: A PARAMETER USED IN THE APPROXIMATION. +C B41: A PARAMETER USED IN THE APPROXIMATION. +C B42: A PARAMETER USED IN THE APPROXIMATION. +C B43: A PARAMETER USED IN THE APPROXIMATION. +C B44: A PARAMETER USED IN THE APPROXIMATION. +C B45: A PARAMETER USED IN THE APPROXIMATION. +C B51: A PARAMETER USED IN THE APPROXIMATION. +C B52: A PARAMETER USED IN THE APPROXIMATION. +C B53: A PARAMETER USED IN THE APPROXIMATION. +C B54: A PARAMETER USED IN THE APPROXIMATION. +C B55: A PARAMETER USED IN THE APPROXIMATION. +C B56: A PARAMETER USED IN THE APPROXIMATION. +C C: A VALUE USED IN THE APPROXIMATION. +C CON: A VALUE USED IN THE APPROXIMATION. +C DF: THE DEGREES OF FREEDOM. +C D1: A VALUE USED IN THE APPROXIMATION. +C D3: A VALUE USED IN THE APPROXIMATION. +C D5: A VALUE USED IN THE APPROXIMATION. +C D7: A VALUE USED IN THE APPROXIMATION. +C D9: A VALUE USED IN THE APPROXIMATION. +C EIGHT: THE VALUE 8.0D0. +C FIFTN: THE VALUE 15.0D0. +C HALF: THE VALUE 0.5D0. +C IDF: THE (POSITIVE INTEGER) DEGREES OF FREEDOM. +C IPASS: A VALUE USED IN THE APPROXIMATION. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR THE APPROX. +C ONE: THE VALUE 1.0D0. +C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE +C EVALUATED. P MUST LIE BETWEEN 0.0DO AND 1.0D0, EXCLUSIVE. +C PI: THE VALUE OF PI. +C PPFN: THE NORMAL PERCENT POINT VALUE. +C S: A VALUE USED IN THE APPROXIMATION. +C TERM1: A VALUE USED IN THE APPROXIMATION. +C TERM2: A VALUE USED IN THE APPROXIMATION. +C TERM3: A VALUE USED IN THE APPROXIMATION. +C TERM4: A VALUE USED IN THE APPROXIMATION. +C TERM5: A VALUE USED IN THE APPROXIMATION. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C Z: A VALUE USED IN THE APPROXIMATION. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DPPT + + + PI = 3.141592653589793238462643383279D0 + DF = IDF + MAXIT = 5 + + IF (IDF.LE.0) THEN + +C TREAT THE IDF < 1 CASE + DPPT = ZERO + + ELSE IF (IDF.EQ.1) THEN + +C TREAT THE IDF = 1 (CAUCHY) CASE + ARG = PI*P + DPPT = -COS(ARG)/SIN(ARG) + + ELSE IF (IDF.EQ.2) THEN + +C TREAT THE IDF = 2 CASE + TERM1 = SQRT(TWO)/TWO + TERM2 = TWO*P - ONE + TERM3 = SQRT(P*(ONE-P)) + DPPT = TERM1*TERM2/TERM3 + + ELSE IF (IDF.GE.3) THEN + +C TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE + PPFN = DPPNML(P) + D1 = PPFN + D3 = PPFN**3 + D5 = PPFN**5 + D7 = PPFN**7 + D9 = PPFN**9 + TERM1 = D1 + TERM2 = (ONE/B21)*(D3+D1)/DF + TERM3 = (ONE/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2) + TERM4 = (ONE/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) + TERM5 = (ONE/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4) + DPPT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5 + + IF (IDF.EQ.3) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 3 CASE + CON = PI*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 70 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - (Z+S*C-CON)/(TWO*C**2) + 70 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.4) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 4 CASE + CON = TWO*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 90 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - ((ONE+HALF*C**2)*S-CON)/((ONE+HALF)*C**3) + 90 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.5) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 5 CASE + + CON = PI*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 110 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - (Z+(C+(TWO/THREE)*C**3)*S-CON)/ + + ((EIGHT/THREE)*C**4) + 110 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.6) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 6 CASE + CON = TWO*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 130 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - ((ONE+HALF*C**2 + (THREE/EIGHT)*C**4)*S-CON)/ + + ((FIFTN/EIGHT)*C**5) + 130 CONTINUE + DPPT = SQRT(DF)*S/C + END IF + END IF + + RETURN + + END +*DPVB + SUBROUTINE DPVB + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVB, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DPVB +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP +C***END PROLOGUE DPVB + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PVB,STP + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAJ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAJ: THE CURRENT ESTIMATE OF THE JTH PARAMETER. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C PVB: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DPVB + + +C COMPUTE PREDICTED VALUES + + BETAJ = BETA(J) + BETA(J) = BETA(J) + STP + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + ELSE + RETURN + END IF + BETA(J) = BETAJ + + PVB = WRK2(NROW,LQ) + + RETURN + END +*DPVD + SUBROUTINE DPVD + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVD, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DPVD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE NROW-TH FUNCTION VALUE USING +C X(NROW,J) + DELTA(NROW,J) + STP +C***END PROLOGUE DPVD + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PVD,STP + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + XPDJ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C PVD: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C XPDJ: THE (NROW,J)TH ELEMENT OF XPLUSD. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DPVD + + +C COMPUTE PREDICTED VALUES + + XPDJ = XPLUSD(NROW,J) + XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + ELSE + RETURN + END IF + XPLUSD(NROW,J) = XPDJ + + PVD = WRK2(NROW,LQ) + + RETURN + END +*DSCALE + SUBROUTINE DSCALE + + (N,M,SCL,LDSCL,T,LDT,SCLT,LDSCLT) +C***BEGIN PROLOGUE DSCALE +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SCALE T BY THE INVERSE OF SCL, I.E., COMPUTE T/SCL +C***END PROLOGUE DSCALE + +C...SCALAR ARGUMENTS + INTEGER + + LDT,LDSCL,LDSCLT,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),SCL(LDSCL,M),SCLT(LDSCLT,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,TEMP,ZERO + INTEGER + + I,J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ONE,ZERO + + /1.0D0,0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDSCL: THE LEADING DIMENSION OF ARRAY SCL. +C LDSCLT: THE LEADING DIMENSION OF ARRAY SCLT. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C M: THE NUMBER OF COLUMNS OF DATA IN T. +C N: THE NUMBER OF ROWS OF DATA IN T. +C ONE: THE VALUE 1.0D0. +C SCL: THE SCALE VALUES. +C SCLT: THE INVERSELY SCALED MATRIX. +C T: THE ARRAY TO BE INVERSELY SCALED BY SCL. +C TEMP: A TEMPORARY SCALAR. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCALE + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (SCL(1,1).GE.ZERO) THEN + IF (LDSCL.GE.N) THEN + DO 80 J=1,M + DO 70 I=1,N + SCLT(I,J) = T(I,J)/SCL(I,J) + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 J=1,M + TEMP = ONE/SCL(1,J) + DO 90 I=1,N + SCLT(I,J) = T(I,J)*TEMP + 90 CONTINUE + 100 CONTINUE + END IF + ELSE + TEMP = ONE/ABS(SCL(1,1)) + DO 120 J=1,M + DO 110 I=1,N + SCLT(I,J) = T(I,J)*TEMP + 110 CONTINUE + 120 CONTINUE + END IF + + RETURN + END +*DSCLB + SUBROUTINE DSCLB + + (NP,BETA,SSF) +C***BEGIN PROLOGUE DSCLB +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT SCALING VALUES FOR BETA ACCORDING TO THE +C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE +C***END PROLOGUE DSCLB + +C...SCALAR ARGUMENTS + INTEGER + + NP + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SSF(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + BMAX,BMIN,ONE,TEN,ZERO + INTEGER + + K + LOGICAL + + BIGDIF + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,LOG10,MAX,MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TEN + + /0.0D0,1.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT +C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF +C BETA (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). +C BMAX: THE LARGEST NONZERO MAGNITUDE. +C BMIN: THE SMALLEST NONZERO MAGNITUDE. +C K: AN INDEXING VARIABLE. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SSF: THE SCALING VALUES FOR BETA. +C TEN: THE VALUE 10.0D0. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCLB + + + BMAX = ABS(BETA(1)) + DO 10 K=2,NP + BMAX = MAX(BMAX,ABS(BETA(K))) + 10 CONTINUE + + IF (BMAX.EQ.ZERO) THEN + +C ALL INPUT VALUES OF BETA ARE ZERO + + DO 20 K=1,NP + SSF(K) = ONE + 20 CONTINUE + + ELSE + +C SOME OF THE INPUT VALUES ARE NONZERO + + BMIN = BMAX + DO 30 K=1,NP + IF (BETA(K).NE.ZERO) THEN + BMIN = MIN(BMIN,ABS(BETA(K))) + END IF + 30 CONTINUE + BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE + DO 40 K=1,NP + IF (BETA(K).EQ.ZERO) THEN + SSF(K) = TEN/BMIN + ELSE + IF (BIGDIF) THEN + SSF(K) = ONE/ABS(BETA(K)) + ELSE + SSF(K) = ONE/BMAX + END IF + END IF + 40 CONTINUE + + END IF + + RETURN + END +*DSCLD + SUBROUTINE DSCLD + + (N,M,X,LDX,TT,LDTT) +C***BEGIN PROLOGUE DSCLD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT SCALING VALUES FOR DELTA ACCORDING TO THE +C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE +C***END PROLOGUE DSCLD + +C...SCALAR ARGUMENTS + INTEGER + + LDTT,LDX,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + TT(LDTT,M),X(LDX,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,TEN,XMAX,XMIN,ZERO + INTEGER + + I,J + LOGICAL + + BIGDIF + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,LOG10,MAX,MIN + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TEN + + /0.0D0,1.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT +C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF +C X (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C ONE: THE VALUE 1.0D0. +C TT: THE SCALING VALUES FOR DELTA. +C X: THE INDEPENDENT VARIABLE. +C XMAX: THE LARGEST NONZERO MAGNITUDE. +C XMIN: THE SMALLEST NONZERO MAGNITUDE. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCLD + + + DO 50 J=1,M + XMAX = ABS(X(1,J)) + DO 10 I=2,N + XMAX = MAX(XMAX,ABS(X(I,J))) + 10 CONTINUE + + IF (XMAX.EQ.ZERO) THEN + +C ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO + + DO 20 I=1,N + TT(I,J) = ONE + 20 CONTINUE + + ELSE + +C SOME OF THE INPUT VALUES ARE NONZERO + + XMIN = XMAX + DO 30 I=1,N + IF (X(I,J).NE.ZERO) THEN + XMIN = MIN(XMIN,ABS(X(I,J))) + END IF + 30 CONTINUE + BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE + DO 40 I=1,N + IF (X(I,J).NE.ZERO) THEN + IF (BIGDIF) THEN + TT(I,J) = ONE/ABS(X(I,J)) + ELSE + TT(I,J) = ONE/XMAX + END IF + ELSE + TT(I,J) = TEN/XMIN + END IF + 40 CONTINUE + END IF + 50 CONTINUE + + RETURN + END +*DSETN + SUBROUTINE DSETN + + (N,M,X,LDX,NROW) +C***BEGIN PROLOGUE DSETN +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED +C***END PROLOGUE DSETN + +C...SCALAR ARGUMENTS + INTEGER + + LDX,M,N,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEX VARIABLE. +C J: AN INDEX VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NROW: THE SELECTED ROW NUMBER OF THE INDEPENDENT VARIABLE. +C X: THE INDEPENDENT VARIABLE. + + +C***FIRST EXECUTABLE STATEMENT DSETN + + + IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN + +C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS +C IF THERE IS ONE, OTHERWISE FIRST ROW IS USED. + + DO 20 I = 1, N + DO 10 J = 1, M + IF (X(I,J).EQ.0.0) GO TO 20 + 10 CONTINUE + NROW = I + RETURN + 20 CONTINUE + + NROW = 1 + + RETURN + END +*DSOLVE + SUBROUTINE DSOLVE(N,T,LDT,B,LDB,JOB) +C***BEGIN PROLOGUE DSOLVE +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DAXPY,DDOT +C***DATE WRITTEN 920220 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE SOLVE SYSTEMS OF THE FORM +C T * X = B OR TRANS(T) * X = B +C WHERE T IS AN UPPER OR LOWER TRIANGULAR MATRIX OF ORDER N, +C AND THE SOLUTION X OVERWRITES THE RHS B. +C (ADAPTED FROM LINPACK SUBROUTINE DTRSL) +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***END PROLOGUE DSOLVE + +C...SCALAR ARGUMENTS + INTEGER + + JOB,LDB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(LDB,N),T(LDT,N) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + J1,J,JN + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT + EXTERNAL + + DDOT + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C B: ON INPUT: THE RIGHT HAND SIDE; ON EXIT: THE SOLUTION +C J1: THE FIRST NONZERO ENTRY IN T. +C J: AN INDEXING VARIABLE. +C JN: THE LAST NONZERO ENTRY IN T. +C JOB: WHAT KIND OF SYSTEM IS TO BE SOLVED, WHERE IF JOB IS +C 1 SOLVE T*X=B, T LOWER TRIANGULAR, +C 2 SOLVE T*X=B, T UPPER TRIANGULAR, +C 3 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, +C 4 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. +C LDB: THE LEADING DIMENSION OF ARRAY B. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY T. +C T: THE UPPER OR LOWER TRIDIAGONAL SYSTEM. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSOLVE + + +C FIND FIRST NONZERO DIAGONAL ENTRY IN T + J1 = 0 + DO 10 J=1,N + IF (J1.EQ.0 .AND. T(J,J).NE.ZERO) THEN + J1 = J + ELSE IF (T(J,J).EQ.ZERO) THEN + B(1,J) = ZERO + END IF + 10 CONTINUE + IF (J1.EQ.0) RETURN + +C FIND LAST NONZERO DIAGONAL ENTRY IN T + JN = 0 + DO 20 J=N,J1,-1 + IF (JN.EQ.0 .AND. T(J,J).NE.ZERO) THEN + JN = J + ELSE IF (T(J,J).EQ.ZERO) THEN + B(1,J) = ZERO + END IF + 20 CONTINUE + + IF (JOB.EQ.1) THEN + +C SOLVE T*X=B FOR T LOWER TRIANGULAR + B(1,J1) = B(1,J1)/T(J1,J1) + DO 30 J = J1+1, JN + TEMP = -B(1,J-1) + CALL DAXPY(JN-J+1,TEMP,T(J,J-1),1,B(1,J),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 30 CONTINUE + + ELSE IF (JOB.EQ.2) THEN + +C SOLVE T*X=B FOR T UPPER TRIANGULAR. + B(1,JN) = B(1,JN)/T(JN,JN) + DO 40 J = JN-1,J1,-1 + TEMP = -B(1,J+1) + CALL DAXPY(J,TEMP,T(1,J+1),1,B(1,1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 40 CONTINUE + + ELSE IF (JOB.EQ.3) THEN + +C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. + B(1,JN) = B(1,JN)/T(JN,JN) + DO 50 J = JN-1,J1,-1 + B(1,J) = B(1,J) - DDOT(JN-J+1,T(J+1,J),1,B(1,J+1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 50 CONTINUE + + ELSE IF (JOB.EQ.4) THEN + +C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. + B(1,J1) = B(1,J1)/T(J1,J1) + DO 60 J = J1+1,JN + B(1,J) = B(1,J) - DDOT(J-1,T(1,J),1,B(1,1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 60 CONTINUE + END IF + + RETURN + END +*DUNPAC + SUBROUTINE DUNPAC + + (N2,V1,V2,IFIX) +C***BEGIN PROLOGUE DUNPAC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DCOPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE +C UNFIXED +C***END PROLOGUE DUNPAC + +C...SCALAR ARGUMENTS + INTEGER + + N2 + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + V1(N2),V2(N2) + INTEGER + + IFIX(N2) + +C...LOCAL SCALARS + INTEGER + + I,N1 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ODRPACK REFERENCE GUIDE.) +C N1: THE NUMBER OF ITEMS IN V1. +C N2: THE NUMBER OF ITEMS IN V2. +C V1: THE VECTOR OF THE UNFIXED ITEMS. +C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE +C ELEMENTS OF V1 ARE TO BE INSERTED. + + +C***FIRST EXECUTABLE STATEMENT DUNPAC + + + N1 = 0 + IF (IFIX(1).GE.0) THEN + DO 10 I = 1,N2 + IF (IFIX(I).NE.0) THEN + N1 = N1 + 1 + V2(I) = V1(N1) + END IF + 10 CONTINUE + ELSE + N1 = N2 + CALL DCOPY(N2,V1,1,V2,1) + END IF + + RETURN + END +*DVEVTR + SUBROUTINE DVEVTR + + (M,NQ,INDX, + + V,LDV,LD2V, E,LDE, VE,LDVE,LD2VE, VEV,LDVEV, + + WRK5) +C***BEGIN PROLOGUE DVEVTR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DSOLVE +C***DATE WRITTEN 910613 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE V*E*TRANS(V) FOR THE (INDX)TH M BY NQ ARRAY IN V +C***END PROLOGUE DVEVTR + +C...SCALAR ARGUMENTS + INTEGER + + INDX,LDE,LDV,LDVE,LDVEV,LD2V,LD2VE,M,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + E(LDE,M),V(LDV,LD2V,NQ),VE(LDVE,LD2VE,M),VEV(LDVEV,NQ),WRK5(M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + J,L1,L2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DSOLVE + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C INDX: THE ROW IN V IN WHICH THE M BY NQ ARRAY IS STORED. +C J: AN INDEXING VARIABLE. +C LDE: THE LEADING DIMENSION OF ARRAY E. +C LDV: THE LEADING DIMENSION OF ARRAY V. +C LDVE: THE LEADING DIMENSION OF ARRAY VE. +C LDVEV: THE LEADING DIMENSION OF ARRAY VEV. +C LD2V: THE SECOND DIMENSION OF ARRAY V. +C L1: AN INDEXING VARIABLE. +C L2: AN INDEXING VARIABLE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C E: THE M BY M MATRIX OF THE FACTORS SO ETE = (D**2 + ALPHA*T**2). +C V: AN ARRAY OF NQ BY M MATRICES. +C VE: THE NQ BY M ARRAY VE = V * INV(E) +C VEV: THE NQ BY NQ ARRAY VEV = V * INV(ETE) * TRANS(V). +C WRK5: AN M WORK VECTOR. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DVEVTR + + + IF (NQ.EQ.0 .OR. M.EQ.0) RETURN + + DO 140 L1 = 1,NQ + DO 110 J = 1,M + WRK5(J) = V(INDX,J,L1) + 110 CONTINUE + CALL DSOLVE(M,E,LDE,WRK5,1,4) + DO 120 J = 1,M + VE(INDX,L1,J) = WRK5(J) + 120 CONTINUE + 140 CONTINUE + + DO 230 L1 = 1,NQ + DO 220 L2 = 1,L1 + VEV(L1,L2) = ZERO + DO 210 J = 1,M + VEV(L1,L2) = VEV(L1,L2) + VE(INDX,L1,J)*VE(INDX,L2,J) + 210 CONTINUE + VEV(L2,L1) = VEV(L1,L2) + 220 CONTINUE + 230 CONTINUE + + RETURN + END +*DWGHT + SUBROUTINE DWGHT + + (N,M,WT,LDWT,LD2WT,T,LDT,WTT,LDWTT) +C***BEGIN PROLOGUE DWGHT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SCALE MATRIX T USING WT, I.E., COMPUTE WTT = WT*T +C***END PROLOGUE DWGHT + +C...SCALAR ARGUMENTS + INTEGER + + LDT,LDWT,LDWTT,LD2WT,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),WT(LDWT,LD2WT,M),WTT(LDWTT,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + I,J,K + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C LDWT: THE LEADING DIMENSION OF ARRAY WT. +C LDWTT: THE LEADING DIMENSION OF ARRAY WTT. +C LD2WT: THE SECOND DIMENSION OF ARRAY WT. +C M: THE NUMBER OF COLUMNS OF DATA IN T. +C N: THE NUMBER OF ROWS OF DATA IN T. +C T: THE ARRAY BEING SCALED BY WT. +C TEMP: A TEMPORARY SCALAR. +C WT: THE WEIGHTS. +C WTT: THE RESULTS OF WEIGHTING ARRAY T BY WT. +C ARRAY WTT CAN BE THE SAME AS T ONLY IF THE ARRAYS IN WT +C ARE UPPER TRIANGULAR WITH ZEROS BELOW THE DIAGONAL. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DWGHT + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (WT(1,1,1).GE.ZERO) THEN + IF (LDWT.GE.N) THEN + IF (LD2WT.GE.M) THEN +C WT IS AN N-ARRAY OF M BY M MATRICES + DO 130 I=1,N + DO 120 J=1,M + TEMP = ZERO + DO 110 K=1,M + TEMP = TEMP + WT(I,J,K)*T(I,K) + 110 CONTINUE + WTT(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE +C WT IS AN N-ARRAY OF DIAGONAL MATRICES + DO 230 I=1,N + DO 220 J=1,M + WTT(I,J) = WT(I,1,J)*T(I,J) + 220 CONTINUE + 230 CONTINUE + END IF + ELSE + IF (LD2WT.GE.M) THEN +C WT IS AN M BY M MATRIX + DO 330 I=1,N + DO 320 J=1,M + TEMP = ZERO + DO 310 K=1,M + TEMP = TEMP + WT(1,J,K)*T(I,K) + 310 CONTINUE + WTT(I,J) = TEMP + 320 CONTINUE + 330 CONTINUE + ELSE +C WT IS A DIAGONAL MATRICE + DO 430 I=1,N + DO 420 J=1,M + WTT(I,J) = WT(1,1,J)*T(I,J) + 420 CONTINUE + 430 CONTINUE + END IF + END IF + ELSE +C WT IS A SCALAR + DO 520 J=1,M + DO 510 I=1,N + WTT(I,J) = ABS(WT(1,1,1))*T(I,J) + 510 CONTINUE + 520 CONTINUE + END IF + + RETURN + END +*DWINF + SUBROUTINE DWINF + + (N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) +C***BEGIN PROLOGUE DWINF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE +C***END PROLOGUE DWINF + +C...SCALAR ARGUMENTS + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + + DIFFI,EPSI,EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,LDWE,LD2WE,LWKMN, + + M,N,NP,NQ,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI, + + WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + WSSI,WSSDEI,WSSEPI,XPLUSI + LOGICAL + + ISODR + +C...LOCAL SCALARS + INTEGER + + NEXT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NEXT: THE NEXT AVAILABLE LOCATION WITH WORK. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCONDI. +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. +C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. +C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. + + +C***FIRST EXECUTABLE STATEMENT DWINF + + + IF (N.GE.1 .AND. M.GE.1 .AND. NP.GE.1 .AND. NQ.GE.1 .AND. + + LDWE.GE.1 .AND. LD2WE.GE.1) THEN + + DELTAI = 1 + EPSI = DELTAI + N*M + XPLUSI = EPSI + N*NQ + FNI = XPLUSI + N*M + SDI = FNI + N*NQ + VCVI = SDI + NP + RVARI = VCVI + NP*NP + + WSSI = RVARI + 1 + WSSDEI = WSSI + 1 + WSSEPI = WSSDEI + 1 + RCONDI = WSSEPI + 1 + ETAI = RCONDI + 1 + OLMAVI = ETAI + 1 + + TAUI = OLMAVI + 1 + ALPHAI = TAUI + 1 + ACTRSI = ALPHAI + 1 + PNORMI = ACTRSI + 1 + RNORSI = PNORMI + 1 + PRERSI = RNORSI + 1 + PARTLI = PRERSI + 1 + SSTOLI = PARTLI + 1 + TAUFCI = SSTOLI + 1 + EPSMAI = TAUFCI + 1 + BETA0I = EPSMAI + 1 + + BETACI = BETA0I + NP + BETASI = BETACI + NP + BETANI = BETASI + NP + SI = BETANI + NP + SSI = SI + NP + SSFI = SSI + NP + QRAUXI = SSFI + NP + UI = QRAUXI + NP + FSI = UI + NP + + FJACBI = FSI + N*NQ + + WE1I = FJACBI + N*NP*NQ + + DIFFI = WE1I + LDWE*LD2WE*NQ + + NEXT = DIFFI + NQ*(NP+M) + + IF (ISODR) THEN + DELTSI = NEXT + DELTNI = DELTSI + N*M + TI = DELTNI + N*M + TTI = TI + N*M + OMEGAI = TTI + N*M + FJACDI = OMEGAI + NQ*NQ + WRK1I = FJACDI + N*M*NQ + NEXT = WRK1I + N*M*NQ + ELSE + DELTSI = DELTAI + DELTNI = DELTAI + TI = DELTAI + TTI = DELTAI + OMEGAI = DELTAI + FJACDI = DELTAI + WRK1I = DELTAI + END IF + + WRK2I = NEXT + WRK3I = WRK2I + N*NQ + WRK4I = WRK3I + NP + WRK5I = WRK4I + M*M + WRK6I = WRK5I + M + WRK7I = WRK6I + N*NQ*NP + NEXT = WRK7I + 5*NQ + + LWKMN = NEXT + ELSE + DELTAI = 1 + EPSI = 1 + XPLUSI = 1 + FNI = 1 + SDI = 1 + VCVI = 1 + RVARI = 1 + WSSI = 1 + WSSDEI = 1 + WSSEPI = 1 + RCONDI = 1 + ETAI = 1 + OLMAVI = 1 + TAUI = 1 + ALPHAI = 1 + ACTRSI = 1 + PNORMI = 1 + RNORSI = 1 + PRERSI = 1 + PARTLI = 1 + SSTOLI = 1 + TAUFCI = 1 + EPSMAI = 1 + BETA0I = 1 + BETACI = 1 + BETASI = 1 + BETANI = 1 + SI = 1 + SSI = 1 + SSFI = 1 + QRAUXI = 1 + FSI = 1 + UI = 1 + FJACBI = 1 + WE1I = 1 + DIFFI = 1 + DELTSI = 1 + DELTNI = 1 + TI = 1 + TTI = 1 + FJACDI = 1 + OMEGAI = 1 + WRK1I = 1 + WRK2I = 1 + WRK3I = 1 + WRK4I = 1 + WRK5I = 1 + WRK6I = 1 + WRK7I = 1 + LWKMN = 1 + END IF + + RETURN + END +*DXMY + SUBROUTINE DXMY + + (N,M,X,LDX,Y,LDY,XMY,LDXMY) +C***BEGIN PROLOGUE DXMY +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE XMY = X - Y +C***END PROLOGUE DXMY + +C...SCALAR ARGUMENTS + INTEGER + + LDX,LDXMY,LDY,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M),XMY(LDXMY,M),Y(LDY,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDXMY: THE LEADING DIMENSION OF ARRAY XMY. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. +C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. +C X: THE FIRST OF THE TWO ARRAYS. +C XMY: THE VALUES OF X-Y. +C Y: THE SECOND OF THE TWO ARRAYS. + + +C***FIRST EXECUTABLE STATEMENT DXMY + + + DO 20 J=1,M + DO 10 I=1,N + XMY(I,J) = X(I,J) - Y(I,J) + 10 CONTINUE + 20 CONTINUE + + RETURN + END +*DXPY + SUBROUTINE DXPY + + (N,M,X,LDX,Y,LDY,XPY,LDXPY) +C***BEGIN PROLOGUE DXPY +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE XPY = X + Y +C***END PROLOGUE DXPY + +C...SCALAR ARGUMENTS + INTEGER + + LDX,LDXPY,LDY,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M),XPY(LDXPY,M),Y(LDY,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDXPY: THE LEADING DIMENSION OF ARRAY XPY. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. +C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. +C X: THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER. +C XPY: THE VALUES OF X+Y. +C Y: THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER. + + +C***FIRST EXECUTABLE STATEMENT DXPY + + + DO 20 J=1,M + DO 10 I=1,N + XPY(I,J) = X(I,J) + Y(I,J) + 10 CONTINUE + 20 CONTINUE + + RETURN + END +*DZERO + SUBROUTINE DZERO + + (N,M,A,LDA) +C***BEGIN PROLOGUE DZERO +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET A = ZERO +C***END PROLOGUE DZERO + +C...SCALAR ARGUMENTS + INTEGER + + LDA,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + A(LDA,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: THE ARRAY TO BE SET TO ZERO. +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDA: THE LEADING DIMENSION OF ARRAY A. +C M: THE NUMBER OF COLUMNS TO BE SET TO ZERO. +C N: THE NUMBER OF ROWS TO BE SET TO ZERO. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DZERO + + + DO 20 J=1,M + DO 10 I=1,N + A(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + + RETURN + END diff --git a/dataassim/math/optimization/dble_pikaia.f b/dataassim/math/optimization/dble_pikaia.f new file mode 100644 index 0000000..d1fe047 --- /dev/null +++ b/dataassim/math/optimization/dble_pikaia.f @@ -0,0 +1,1177 @@ +c********************************************************************* + double precision function urand() +c===================================================================== +c Return the next pseudo-random deviate from a sequence which is +c uniformly distributed in the interval [0,1] +c +c Uses the function ran0, the "minimal standard" random number +c generator of Park and Miller (Comm. ACM 31, 1192-1201, Oct 1988; +c Comm. ACM 36 No. 7, 105-110, July 1993). +c===================================================================== + implicit none +c +c Input - none +c +c Output + +c Local + double precision ran2 + external ran2 +c + urand = ran2() + return + end +c********************************************************************** + subroutine rqsort(n,a,p) +c====================================================================== +c Return integer array p which indexes array a in increasing order. +c Array a is not disturbed. The Quicksort algorithm is used. +c +c B. G. Knapp, 86/12/23 +c +c Reference: N. Wirth, Algorithms and Data Structures, +c Prentice-Hall, 1986 +c====================================================================== + implicit none + +c Input: + integer n + double precision a(n) + +c Output: + integer p(n) + +c Constants + integer LGN, Q + parameter (LGN=32, Q=11) +c (LGN = log base 2 of maximum n; +c Q = smallest subfile to use quicksort on) + +c Local: + double precision x + integer stackl(LGN),stackr(LGN),s,t,l,m,r,i,j + +c Initialize the stack + stackl(1)=1 + stackr(1)=n + s=1 + +c Initialize the pointer array + do 1 i=1,n + p(i)=i + 1 continue + + 2 if (s.gt.0) then + l=stackl(s) + r=stackr(s) + s=s-1 + + 3 if ((r-l).lt.Q) then + +c Use straight insertion + do 6 i=l+1,r + t = p(i) + x = a(t) + do 4 j=i-1,l,-1 + if (a(p(j)).le.x) goto 5 + p(j+1) = p(j) + 4 continue + j=l-1 + 5 p(j+1) = t + 6 continue + else + +c Use quicksort, with pivot as median of a(l), a(m), a(r) + m=(l+r)/2 + t=p(m) + if (a(t).lt.a(p(l))) then + p(m)=p(l) + p(l)=t + t=p(m) + endif + if (a(t).gt.a(p(r))) then + p(m)=p(r) + p(r)=t + t=p(m) + if (a(t).lt.a(p(l))) then + p(m)=p(l) + p(l)=t + t=p(m) + endif + endif + +c Partition + x=a(t) + i=l+1 + j=r-1 + 7 if (i.le.j) then + 8 if (a(p(i)).lt.x) then + i=i+1 + goto 8 + endif + 9 if (x.lt.a(p(j))) then + j=j-1 + goto 9 + endif + if (i.le.j) then + t=p(i) + p(i)=p(j) + p(j)=t + i=i+1 + j=j-1 + endif + goto 7 + endif + +c Stack the larger subfile + s=s+1 + if ((j-l).gt.(r-i)) then + stackl(s)=l + stackr(s)=j + l=i + else + stackl(s)=i + stackr(s)=r + r=j + endif + goto 3 + endif + goto 2 + endif + return + end +c*********************************************************************** + subroutine pikaia(ff,n,ctrl,x,f,icondi) +c======================================================================= +c Optimization (maximization) of user-supplied "fitness" function +c ff over n-dimensional parameter space x using a basic genetic +c algorithm method. +c +c Paul Charbonneau & Barry Knapp +c High Altitude Observatory +c National Center for Atmospheric Research +c Boulder CO 80307-3000 +c +c +c +c Version 1.2 [ 2002 April 3 ] +c +c Genetic algorithms are heuristic search techniques that +c incorporate in a computational setting, the biological notion +c of evolution by means of natural selection. This subroutine +c implements the three basic operations of selection, crossover, +c and mutation, operating on "genotypes" encoded as strings. +c +c Version 1.2 differs from version 1.0 (December 1995) in that +c it includes (1) two-point crossover, (2) creep mutation, and +c (3) dynamical adjustment of the mutation rate based on metric +c distance in parameter space. +c +c References: +c +c Charbonneau, Paul. "An introduction to gemetic algorithms for +c numerical optimization", NCAR Technical Note TN-450+IA +c (April 2002) +c +c Charbonneau, Paul. "Release Notes for PIKAIA 1.2", +c NCAR Technical Note TN-451+STR (April 2002) +c +c Charbonneau, Paul, and Knapp, Barry. "A User's Guide +c to PIKAIA 1.0" NCAR Technical Note TN-418+IA +c (December 1995) +c +c Goldberg, David E. Genetic Algorithms in Search, Optimization, +c & Machine Learning. Addison-Wesley, 1989. +c +c Davis, Lawrence, ed. Handbook of Genetic Algorithms. +c Van Nostrand Reinhold, 1991. +c +c======================================================================= +c USES: ff, urand, setctl, report, rnkpop, select, encode, decode, +c cross, mutate, genrep, stdrep, newpop, adjmut + implicit none + +c Input: + integer n + double precision ff + external ff +c +c o Integer n is the parameter space dimension, i.e., the number +c of adjustable parameters. +c +c o Function ff is a user-supplied scalar function of n vari- +c ables, which must have the calling sequence f = ff(n,x), where +c x is a double precision parameter array of length n. This function must +c be written so as to bound all parameters to the interval [0,1]; +c that is, the user must determine a priori bounds for the para- +c meter space, and ff must use these bounds to perform the appro- +c priate scalings to recover true parameter values in the +c a priori ranges. +c +c By convention, ff should return higher values for more optimal +c parameter values (i.e., individuals which are more "fit"). +c For example, in fitting a function through data points, ff +c could return the inverse of chi**2. +c +c In most cases initialization code will have to be written +c (either in a driver or in a separate subroutine) which loads +c in data values and communicates with ff via one or more labeled +c common blocks. An example exercise driver and fitness function +c are provided in the accompanying file, xpkaia.f. +c +c +c Input/Output: + double precision ctrl(12) +c +c o Array ctrl is an array of control flags and parameters, to +c control the genetic behavior of the algorithm, and also printed +c output. A default value will be used for any control variable +c which is supplied with a value less than zero. On exit, ctrl +c contains the actual values used as control variables. The +c elements of ctrl and their defaults are: +c +c ctrl( 1) - number of individuals in a population (default +c is 100) +c ctrl( 2) - number of generations over which solution is +c to evolve (default is 500) +c ctrl( 3) - number of significant digits (i.e., number of +c genes) retained in chromosomal encoding (default +c is 6) (Note: This number is limited by the +c machine floating point precision. Most 32-bit +c floating point representations have only 6 full +c digits of precision. To achieve greater preci- +c sion this routine could be converted to double +c precision, but note that this would also require +c a double precision random number generator, which +c likely would not have more than 9 digits of +c precision if it used 4-byte integers internally.) +c ctrl( 4) - crossover probability; must be <= 1.0 (default +c is 0.85). If crossover takes place, either one +c or two splicing points are used, with equal +c probabilities +c ctrl( 5) - mutation mode; 1/2/3/4/5 (default is 2) +c 1=one-point mutation, fixed rate +c 2=one-point, adjustable rate based on fitness +c 3=one-point, adjustable rate based on distance +c 4=one-point+creep, fixed rate +c 5=one-point+creep, adjustable rate based on fitness +c 6=one-point+creep, adjustable rate based on distance +c ctrl( 6) - initial mutation rate; should be small (default +c is 0.005) (Note: the mutation rate is the proba- +c bility that any one gene locus will mutate in +c any one generation.) +c ctrl( 7) - minimum mutation rate; must be >= 0.0 (default +c is 0.0005) +c ctrl( 8) - maximum mutation rate; must be <= 1.0 (default +c is 0.25) +c ctrl( 9) - relative fitness differential; range from 0 +c (none) to 1 (maximum). (default is 1.) +c ctrl(10) - reproduction plan; 1/2/3=Full generational +c replacement/Steady-state-replace-random/Steady- +c state-replace-worst (default is 3) +c ctrl(11) - elitism flag; 0/1=off/on (default is 0) +c (Applies only to reproduction plans 1 and 2) +c ctrl(12) - printed output 0/1/2=None/Minimal/Verbose +c (default is 0) +c +c +c Output: + double precision x(n), f + integer icondi +c +c o Array x(1:n) is the "fittest" (optimal) solution found, +c i.e., the solution which maximizes fitness function ff +c +c o Scalar f is the value of the fitness function at x +c +c o Integer icondi is an indicator of the success or failure +c of the call to pikaia (0=success; non-zero=failure) +c +c +c Constants + integer NMAX, PMAX, DMAX + parameter (NMAX = 200, PMAX = 5001, DMAX = 9) +c +c o NMAX is the maximum number of adjustable parameters +c (n <= NMAX). original NMAX was 32 +c +c o PMAX is the maximum population (ctrl(1) <= PMAX) +c +c o DMAX is the maximum number of Genes (digits) per Chromosome +c segement (parameter) (ctrl(3) <= DMAX) +c +c +c Local variables + integer np, nd, ngen, imut, irep, ielite, ivrb, k, ip, ig, + + ip1, ip2, new, newtot + double precision pcross, pmut, pmutmn, pmutmx, fdif +c + double precision ph(NMAX,2), oldph(NMAX,PMAX), newph(NMAX,PMAX) +c + integer gn1(NMAX*DMAX), gn2(NMAX*DMAX) + integer ifit(PMAX), jfit(PMAX) + double precision fitns(PMAX) +c +c User-supplied uniform random number generator + double precision urand + external urand +c +c Function urand should not take any arguments. If the user wishes +c to be able to initialize urand, so that the same sequence of +c random numbers can be repeated, this capability could be imple- +c mented with a separate subroutine, and called from the user's +c driver program. An example urand function (and initialization +c subroutine) which uses the function ran0 (the "minimal standard" +c random number generator of Park and Miller [Comm. ACM 31, 1192- +c 1201, Oct 1988; Comm. ACM 36 No. 7, 105-110, July 1993]) is +c provided. +c +c +c Set control variables from input and defaults + call setctl + + (ctrl,n,np,ngen,nd,pcross,pmutmn,pmutmx,pmut,imut, + + fdif,irep,ielite,ivrb,icondi) + +c Make sure locally-dimensioned arrays are big enough + if (n.gt.NMAX .or. np.gt.PMAX .or. nd.gt.DMAX) then + write(*,*)n,NMAX,np,PMAX,nd,DMAX + + write(*,*) + + ' Number of parameters, population, or genes too large' + icondi = -1 + return + endif + +c Compute initial (random but bounded) phenotypes + do 1 ip=2,np + do 2 k=1,n + oldph(k,ip)=urand() + 2 continue + 1 continue + + do k=1,n + oldph(k,1)=x(k) + enddo + do ip=1,np + fitns(ip) = ff(n,oldph(1,ip)) + enddo + +c Rank initial population by fitness order + call rnkpop(np,fitns,ifit,jfit) + +c Main Generation Loop + do 10 ig=1,ngen + +c Main Population Loop + newtot=0 + do 20 ip=1,np/2 + +c 1. pick two parents + call select(np,jfit,fdif,ip1) + 21 call select(np,jfit,fdif,ip2) + if (ip1.eq.ip2) goto 21 + +c 2. encode parent phenotypes + call encode(n,nd,oldph(1,ip1),gn1) + call encode(n,nd,oldph(1,ip2),gn2) + +c 3. breed + call cross(n,nd,pcross,gn1,gn2) + call mutate(n,nd,pmut,gn1,imut) + call mutate(n,nd,pmut,gn2,imut) + +c 4. decode offspring genotypes + call decode(n,nd,gn1,ph(1,1)) + call decode(n,nd,gn2,ph(1,2)) + +c 5. insert into population + if (irep.eq.1) then + call genrep(NMAX,n,np,ip,ph,newph) + else + call stdrep(ff,NMAX,n,np,irep,ielite, + + ph,oldph,fitns,ifit,jfit,new) + newtot = newtot+new + endif + +c End of Main Population Loop + 20 continue + +c if running full generational replacement: swap populations + if (irep.eq.1) + + call newpop(ff,ielite,NMAX,n,np,oldph,newph, + + ifit,jfit,fitns,newtot) + +c adjust mutation rate? + if (imut.eq.2 .or. imut.eq.3 .or. imut.eq.5 .or. imut.eq.6) + + call adjmut(NMAX,n,np,oldph,fitns,ifit,pmutmn,pmutmx, + + pmut,imut) +c + if (ivrb.gt.0) call report + + (ivrb,NMAX,n,np,nd,oldph,fitns,ifit,pmut,ig,newtot) + +c End of Main Generation Loop + 10 continue +c +c Return best phenotype and its fitness + do 30 k=1,n + x(k) = oldph(k,ifit(np)) + 30 continue + f = fitns(ifit(np)) +c + end +c******************************************************************** + subroutine setctl + + (ctrl,n,np,ngen,nd,pcross,pmutmn,pmutmx,pmut,imut, + + fdif,irep,ielite,ivrb,icondi) +c=================================================================== +c Set control variables and flags from input and defaults +c=================================================================== + implicit none +c +c Input + integer n +c +c Input/Output + double precision ctrl(12) +c +c Output + integer np, ngen, nd, imut, irep, ielite, ivrb, icondi + double precision pcross, pmutmn, pmutmx, pmut, fdif +c +c Local + integer i + double precision DFAULT(12) + save DFAULT + data DFAULT /100.0d0,500.0d0,5.0d0,0.85d0,2.0d0,0.005d0, + &0.0005d0,0.25d0,1.0d0,1.0d0,1.0d0,0.0d0/ +c + do 1 i=1,12 + if (ctrl(i).lt.0.0d0) ctrl(i)=DFAULT(i) + 1 continue + + np = ctrl(1) + ngen = ctrl(2) + nd = ctrl(3) + pcross = ctrl(4) + imut = ctrl(5) + pmut = ctrl(6) + pmutmn = ctrl(7) + pmutmx = ctrl(8) + fdif = ctrl(9) + irep = ctrl(10) + ielite = ctrl(11) + ivrb = ctrl(12) + icondi = 0 +c +c Print a header + if (ivrb.gt.0) then + + write(*,2) ngen,np,n,nd,pcross,pmut,pmutmn,pmutmx,fdif + 2 format(/1x,60('*'),/, + + ' *',13x,'PIKAIA Genetic Algorithm Report ',13x,'*',/, + + 1x,60('*'),//, + + ' Number of Generations evolving: ',i4,/, + + ' Individuals per generation: ',i4,/, + + ' Number of Chromosome segments: ',i4,/, + + ' Length of Chromosome segments: ',i4,/, + + ' Crossover probability: ',f9.4,/, + + ' Initial mutation rate: ',f9.4,/, + + ' Minimum mutation rate: ',f9.4,/, + + ' Maximum mutation rate: ',f9.4,/, + + ' Relative fitness differential: ',f9.4) + if (imut.eq.1) write(*,3) 'Uniform, Constant Rate' + if (imut.eq.2) write(*,3) 'Uniform, Variable Rate (F)' + if (imut.eq.3) write(*,3) 'Uniform, Variable Rate (D)' + if (imut.eq.4) write(*,3) 'Uniform+Creep, Constant Rate' + if (imut.eq.5) write(*,3) 'Uniform+Creep, Variable Rate (F)' + if (imut.eq.6) write(*,3) 'Uniform+Creep, Variable Rate (D)' + 3 format( + + ' Mutation Mode: ',A) + if (irep.eq.1) write(*,4) 'Full generational replacement' + if (irep.eq.2) write(*,4) 'Steady-state-replace-random' + if (irep.eq.3) write(*,4) 'Steady-state-replace-worst' + 4 format( + + ' Reproduction Plan: ',A) + endif + +c Check some control values + if (imut.ne.1 .and. imut.ne.2 .and. imut.ne.3 .and. imut.ne.4 + + .and. imut.ne.5 .and. imut.ne.6) then + write(*,10) + icondi = 5 + endif + 10 format(' ERROR: illegal value for imut (ctrl(5))') + + if (fdif.gt.1.) then + write(*,11) + icondi = 9 + endif + 11 format(' ERROR: illegal value for fdif (ctrl(9))') + + if (irep.ne.1 .and. irep.ne.2 .and. irep.ne.3) then + write(*,12) + icondi = 10 + endif + 12 format(' ERROR: illegal value for irep (ctrl(10))') + + if (pcross.gt.1.0d0.or.pcross.lt.0.0d0)then + write(*,13) + icondi = 4 + endif + 13 format(' ERROR: illegal value for pcross (ctrl(4))') + + if (ielite.ne.0 .and. ielite.ne.1) then + write(*,14) + icondi = 11 + endif + 14 format(' ERROR: illegal value for ielite (ctrl(11))') + + if (irep.eq.1 .and. imut.eq.1 .and. pmut.gt.0.5 .and. + + ielite.eq.0) then + write(*,15) + endif + 15 format(' WARNING: dangerously high value for pmut (ctrl(6));', + + /' (Should enforce elitism with ctrl(11)=1.)') + + if (irep.eq.1 .and. imut.eq.2 .and. pmutmx.gt.0.5 .and. + + ielite.eq.0) then + write(*,16) + endif + 16 format(' WARNING: dangerously high value for pmutmx (ctrl(8));', + + /' (Should enforce elitism with ctrl(11)=1.)') + + if (fdif.lt.0.33d0.and. irep.ne.3) then + write(*,17) + endif + 17 format(' WARNING: dangerously low value of fdif (ctrl(9))') + + if (mod(np,2).gt.0) then + np=np-1 + write(*,18) np + endif + 18 format(' WARNING: decreasing population size (ctrl(1)) to np=',i4) + + return + end +c******************************************************************** + subroutine report + + (ivrb,ndim,n,np,nd,oldph,fitns,ifit,pmut,ig,nnew) +c +c Write generation report to standard output +c + implicit none + +c Input: + integer np,ifit(np),ivrb,ndim,n,nd,ig,nnew + double precision oldph(ndim,np),fitns(np),pmut +c +c Output: none +c +c Local + double precision bestft,pmutpv + save bestft,pmutpv + integer ndpwr,k + logical rpt + data bestft,pmutpv /0.0d0,0.0d0/ +c + rpt=.false. + + if (pmut.ne.pmutpv) then + pmutpv=pmut + rpt=.true. + endif + + if (fitns(ifit(np)).ne.bestft) then + bestft=fitns(ifit(np)) + rpt=.true. + endif + + if (rpt .or. ivrb.ge.2) then + +c Power of 10 to make integer genotypes for display + ndpwr = idnint(10.d0**nd) + + write(*,'(/i6,i6,f10.6,4f10.6)') ig,nnew,pmut, + + fitns(ifit(np)), fitns(ifit(np-1)), fitns(ifit(np/2)) + do 15 k=1,n + write(*,'(22x,3i10)') + + idnint(ndpwr*oldph(k,ifit(np ))), + + idnint(ndpwr*oldph(k,ifit(np-1))), + + idnint(ndpwr*oldph(k,ifit(np/2))) + 15 continue + + endif + end + +c********************************************************************** +c GENETICS MODULE +c********************************************************************** +c +c ENCODE: encodes phenotype into genotype +c called by: PIKAIA +c +c DECODE: decodes genotype into phenotype +c called by: PIKAIA +c +c CROSS: Breeds two offspring from two parents +c called by: PIKAIA +c +c MUTATE: Introduces random mutation in a genotype +c called by: PIKAIA +c +c ADJMUT: Implements variable mutation rate +c called by: PIKAIA +c +c********************************************************************** + subroutine encode(n,nd,ph,gn) +c====================================================================== +c encode phenotype parameters into integer genotype +c ph(k) are x,y coordinates [ 0 < x,y < 1 ] +c====================================================================== +c + implicit none +c +c Inputs: + integer n, nd + double precision ph(n) +c +c Output: + integer gn(n*nd) +c +c Local: + integer ip, i, j, ii + double precision z +c + z=10.0d0**nd + ii=0 + do 1 i=1,n + ip=idint(ph(i)*z) + do 2 j=nd,1,-1 + gn(ii+j)=mod(ip,10) + ip=ip/10 + 2 continue + ii=ii+nd + 1 continue + + return + end + +c********************************************************************** + subroutine decode(n,nd,gn,ph) +c====================================================================== +c decode genotype into phenotype parameters +c ph(k) are x,y coordinates [ 0 < x,y < 1 ] +c====================================================================== +c + implicit none +c +c Inputs: + integer n, nd, gn(n*nd) +c +c Output: + double precision ph(n) +c +c Local: + integer ip, i, j, ii + double precision z +c + z=10.0d0**(-nd) + ii=0 + do 1 i=1,n + ip=0 + do 2 j=1,nd + ip=10*ip+gn(ii+j) + 2 continue + ph(i)=ip*z + ii=ii+nd + 1 continue + + return + end + +c********************************************************************** + subroutine cross(n,nd,pcross,gn1,gn2) +c====================================================================== +c breeds two parent chromosomes into two offspring chromosomes +c breeding occurs through crossover. If the crossover probability +c test yields true (crossover taking place), either one-point or +c two-point crossover is used, with equal probabilities. +c +c Compatibility with version 1.0: To enforce 100% use of one-point +c crossover, un-comment appropriate line in source code below +c====================================================================== +c + implicit none +c +c Inputs: + integer n, nd + double precision pcross +c +c Input/Output: + integer gn1(n*nd), gn2(n*nd) +c +c Local: + integer i, ispl, ispl2, itmp, t +c +c Function + double precision urand + external urand + + +c Use crossover probability to decide whether a crossover occurs + if (urand().lt.pcross) then + +c Compute first crossover point + ispl=idint(urand()*n*nd)+1 + +c Now choose between one-point and two-point crossover + if (urand().lt.0.5d0) then + ispl2=n*nd + else + ispl2=idint(urand()*n*nd)+1 +c Un-comment following line to enforce one-point crossover +c ispl2=n*nd + if (ispl2.lt.ispl) then + itmp=ispl2 + ispl2=ispl + ispl=itmp + endif + endif + +c Swap genes from ispl to ispl2 + do 10 i=ispl,ispl2 + t=gn2(i) + gn2(i)=gn1(i) + gn1(i)=t + 10 continue + endif + + return + end + +c********************************************************************** + subroutine mutate(n,nd,pmut,gn,imut) +c====================================================================== +c Mutations occur at rate pmut at all gene loci +c imut=1 Uniform mutation, constant rate +c imut=2 Uniform mutation, variable rate based on fitness +c imut=3 Uniform mutation, variable rate based on distance +c imut=4 Uniform or creep mutation, constant rate +c imut=5 Uniform or creep mutation, variable rate based on +c fitness +c imut=6 Uniform or creep mutation, variable rate based on +c distance +c====================================================================== +c + implicit none +c +c Input: + integer n, nd, imut + double precision pmut +c +c Input/Output: + integer gn(n*nd) +c +c Local: + integer i,j,k,l,ist,inc,iloc,kk + +c +c Function: + double precision urand + external urand +c +c Decide which type of mutation is to occur + if(imut.ge.4.and.urand().le.0.5d0)then + +c CREEP MUTATION OPERATOR +c Subject each locus to random +/- 1 increment at the rate pmut + do 1 i=1,n + do 2 j=1,nd + if (urand().lt.pmut) then +c Construct integer + iloc=(i-1)*nd+j + inc=idnint(urand())*2-1 + ist=(i-1)*nd+1 + gn(iloc)=gn(iloc)+inc +c write(*,*) ist,iloc,inc +c This is where we carry over the one (up to two digits) +c first take care of decrement below 0 case + if(inc.lt.0 .and. gn(iloc).lt.0)then + if(j.eq.1)then + gn(iloc)=0 + else + do 3 k=iloc,ist+1,-1 + gn(k)=9 + gn(k-1)=gn(k-1)-1 + if( gn(k-1).ge.0 )goto 4 + 3 continue +c we popped under 0.00000 lower bound; fix it up + if( gn(ist).lt.0)then + do 5 l=ist,iloc + gn(l)=0 + 5 continue + endif + 4 continue + endif + endif + if(inc.gt.0 .and. gn(iloc).gt.9)then + if(j.eq.1)then + gn(iloc)=9 + else + do 6 k=iloc,ist+1,-1 + gn(k)=0 + gn(k-1)=gn(k-1)+1 + if( gn(k-1).le.9 )goto 7 + 6 continue +c we popped over 9.99999 upper bound; fix it up + if( gn(ist).gt.9 )then + do 8 l=ist,iloc + gn(l)=9 + 8 continue + endif + 7 continue + endif + endif + endif + 2 continue + 1 continue + + else + +c UNIFORM MUTATION OPERATOR +c Subject each locus to random mutation at the rate pmut + do 10 i=1,n*nd + if (urand().lt.pmut) then + gn(i)=idint(urand()*10.0d0) + endif + 10 continue + endif + + return + end + +c********************************************************************** + subroutine adjmut(ndim,n,np,oldph,fitns,ifit,pmutmn,pmutmx, + + pmut,imut) +c====================================================================== +c dynamical adjustment of mutation rate; +c imut=2 or imut=5 : adjustment based on fitness differential +c between best and median individuals +c imut=3 or imut=6 : adjustment based on metric distance +c between best and median individuals +c====================================================================== +c + implicit none +c +c Input: + integer n, ndim, np, ifit(np), imut + double precision oldph(ndim,np), fitns(np), pmutmn, pmutmx +c +c Input/Output: + double precision pmut +c +c Local: + integer i + double precision rdif, rdiflo, rdifhi, delta + parameter (rdiflo=0.05d0,rdifhi=0.25d0,delta=1.5d0) + + if(imut.eq.2.or.imut.eq.5)then +c Adjustment based on fitness differential + rdif=abs(fitns(ifit(np))-fitns(ifit(np/2)))/ + + (fitns(ifit(np))+fitns(ifit(np/2))) + else if(imut.eq.3.or.imut.eq.6)then +c Adjustment based on normalized metric distance + rdif=0.0d0 + do 1 i=1,n + rdif=rdif+( oldph(i,ifit(np))-oldph(i,ifit(np/2)) )**2 + 1 continue + rdif=dsqrt(rdif)/dble(n) + endif + + if(rdif.le.rdiflo)then + pmut=min(pmutmx,pmut*delta) + else if(rdif.ge.rdifhi)then + pmut=max(pmutmn,pmut/delta) + endif + + return + end + + +c********************************************************************** +c REPRODUCTION MODULE +c********************************************************************** +c +c SELECT: Parent selection by roulette wheel algorithm +c called by: PIKAIA +c +c RNKPOP: Ranks initial population +c called by: PIKAIA, NEWPOP +c +c GENREP: Inserts offspring into population, for full +c generational replacement +c called by: PIKAIA +c +c STDREP: Inserts offspring into population, for steady-state +c reproduction +c called by: PIKAIA +c calls: FF +c +c NEWPOP: Replaces old generation with new generation +c called by: PIKAIA +c calls: FF, RNKPOP +c +c********************************************************************** + subroutine select(np,jfit,fdif,idad) +c====================================================================== +c Selects a parent from the population, using roulette wheel +c algorithm with the relative fitnesses of the phenotypes as +c the "hit" probabilities [see Davis 1991, chap. 1]. +c====================================================================== +c USES: urand + implicit none +c +c Input: + integer np, jfit(np) + double precision fdif +c +c Output: + integer idad +c +c Local: + integer np1, i + double precision dice, rtfit +c +c Function: + double precision urand + external urand +c +c + np1 = np+1 + dice = urand()*np*np1 + rtfit = 0.0d0 + do 1 i=1,np + rtfit = rtfit+np1+fdif*(np1-2*jfit(i)) + if (rtfit.ge.dice) then + idad=i + goto 2 + endif + 1 continue +c Assert: loop will never exit by falling through + + 2 return + end + +c********************************************************************** + subroutine rnkpop(n,arrin,indx,rank) +c====================================================================== +c Calls external sort routine to produce key index and rank order +c of input array arrin (which is not altered). +c====================================================================== +c USES: rqsort + implicit none +c +c Input + integer n + double precision arrin(n) +c +c Output + integer indx(n),rank(n) +c +c Local + integer i +c +c External sort subroutine + external rqsort +c +c +c Compute the key index + call rqsort(n,arrin,indx) +c +c ...and the rank order + do 1 i=1,n + rank(indx(i)) = n-i+1 + 1 continue + return + end + +c*********************************************************************** + subroutine genrep(ndim,n,np,ip,ph,newph) +c======================================================================= +c full generational replacement: accumulate offspring into new +c population array +c======================================================================= +c + implicit none + +c Input: + integer ndim, n, np, ip + double precision ph(ndim,2) +c +c Output: + double precision newph(ndim,np) +c +c Local: + integer i1, i2, k +c +c +c Insert one offspring pair into new population + i1=2*ip-1 + i2=i1+1 + do 1 k=1,n + newph(k,i1)=ph(k,1) + newph(k,i2)=ph(k,2) + 1 continue + + return + end + +c********************************************************************** + subroutine stdrep + + (ff,ndim,n,np,irep,ielite,ph,oldph,fitns,ifit,jfit,nnew) +c====================================================================== +c steady-state reproduction: insert offspring pair into population +c only if they are fit enough (replace-random if irep=2 or +c replace-worst if irep=3). +c====================================================================== +c USES: ff, urand + implicit none +c +c Input: + integer ndim, n, np, irep, ielite + double precision ff, ph(ndim,2) + external ff +c +c Input/Output: + double precision oldph(ndim,np), fitns(np) + integer ifit(np), jfit(np) +c +c Output: + integer nnew + +c Local: + integer i, j, k, i1, if1 + double precision fit +c +c External function + double precision urand + external urand +c +c + nnew = 0 + do 1 j=1,2 + +c 1. compute offspring fitness (with caller's fitness function) + fit=ff(n,ph(1,j)) + +c 2. if fit enough, insert in population + do 20 i=np,1,-1 + if (fit.gt.fitns(ifit(i))) then + +c make sure the phenotype is not already in the population + if (i.lt.np) then + do 5 k=1,n + if (oldph(k,ifit(i+1)).ne.ph(k,j)) goto 6 + 5 continue + goto 1 + 6 continue + endif + +c offspring is fit enough for insertion, and is unique + +c (i) insert phenotype at appropriate place in population + if (irep.eq.3) then + i1=1 + else if (ielite.eq.0 .or. i.eq.np) then + i1=idint(urand()*np)+1 + else + i1=idint(urand()*(np-1))+1 + endif + if1 = ifit(i1) + fitns(if1)=fit + do 21 k=1,n + oldph(k,if1)=ph(k,j) + 21 continue + +c (ii) shift and update ranking arrays + if (i.lt.i1) then + +c shift up + jfit(if1)=np-i + do 22 k=i1-1,i+1,-1 + jfit(ifit(k))=jfit(ifit(k))-1 + ifit(k+1)=ifit(k) + 22 continue + ifit(i+1)=if1 + else + +c shift down + jfit(if1)=np-i+1 + do 23 k=i1+1,i + jfit(ifit(k))=jfit(ifit(k))+1 + ifit(k-1)=ifit(k) + 23 continue + ifit(i)=if1 + endif + nnew = nnew+1 + goto 1 + endif + 20 continue + + 1 continue + + return + end + +c********************************************************************** + subroutine newpop + + (ff,ielite,ndim,n,np,oldph,newph,ifit,jfit,fitns,nnew) +c====================================================================== +c replaces old population by new; recomputes fitnesses & ranks +c====================================================================== +c USES: ff, rnkpop + implicit none +c +c Input: + integer ndim, np, n, ielite + double precision ff + external ff +c +c Input/Output: + double precision oldph(ndim,np), newph(ndim,np) +c +c Output: + integer ifit(np), jfit(np), nnew + double precision fitns(np) +c +c Local: + integer i, k +c +c + nnew = np + +c if using elitism, introduce in new population fittest of old +c population (if greater than fitness of the individual it is +c to replace) + if (ielite.eq.1 .and. ff(n,newph(1,1)).lt.fitns(ifit(np))) then + do 1 k=1,n + newph(k,1)=oldph(k,ifit(np)) + 1 continue + nnew = nnew-1 + endif + +c replace population + do 2 i=1,np + do 3 k=1,n + oldph(k,i)=newph(k,i) + 3 continue + +c get fitness using caller's fitness function + fitns(i)=ff(n,oldph(1,i)) + 2 continue + +c compute new population fitness rank order + call rnkpop(np,fitns,ifit,jfit) + + return + end diff --git a/dataassim/math/optimization/distancesys.f b/dataassim/math/optimization/distancesys.f new file mode 100644 index 0000000..1ba5949 --- /dev/null +++ b/dataassim/math/optimization/distancesys.f @@ -0,0 +1,119 @@ + subroutine distancesys(nunknowns,scldxp, + & scldfequ,scldfsqsum,idowhat) + implicit none +! +!--------------------- Variables through arguments ------------------------- +!(in) nunknowns: the number of unknowns and non-linear equations +!(in) scldxp(1:nunknowns): the scaled unknowns in the nonlinear system +!(out) scldfequ(1:nunknowns): the scaled function values evaluated at imported unknowns +!(out) scldfsqsum: half of the sum of the squared scaled function values. + integer nunknowns,idowhat + double precision scldxp(1:nunknowns), + & scldfequ(1:nunknowns),scldfsqsum +!--------------------------- Local variables----------------------------------- + integer i,j,numys + parameter + double precision xvar(nunknowns),xscalingfact(nunknowns), + & xtarget(nunknowns),yvar(numys),yscalingfact(numys), + & ytarget(numys),diffy(numys) +!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + do i=1,nunknowns + scalingfact(i)=1.0d0 + xvar(i)=scldxp(i)/xscalingfact(i) + enddo + call surface(numys,yvar,nunknowns,xvar) + do i=1,numys + diff(i)=yvar(i)-ytarget(i) + endif + if(idowhat.eq.1)then + scldfsqsum=0.0d0 + do i=1,nunknowns + scldfequ(i)=scldfequ(i)*scalingfact(i) + scldfsqsum=scldfsqsum+scldfequ(i)*scldfequ(i) + enddo + scldfsqsum=0.5d0*scldfsqsum + endif + if(idowhat.eq.2)then + + return + end subroutine leafsys + + subroutine surface(numys,ysurface,nunknowns,xvar) + implicit none + integer numys,nunknowns + double precision ysurface(numys),xvar(nunknowns) + ysurface(1)=xvar(1) + return + end + +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + subroutine sqsum_fequ(nunknowns,xp,fequsqsum) +!This subroutine returns half of the sum of the squared equation residues + implicit none + integer nunknowns + double precision xp(nunknowns),fequsqsum, + & fequ(nunknowns) + integer idowhat + parameter(idowhat=1) + call distancesys(nunknowns,xp,fequ,fequsqsum,idowhat) + return + end + + double precision function cpf1dim_fequ(x) +!this function subroutine returns half of the sum of the squared equation residues for line search + INTEGER NMAX + double precision x + PARAMETER (NMAX=1000) + INTEGER j,ncom,idowhat + parameter(idowhat=1) + double precision pcom(NMAX),xicom(NMAX), + & xt(NMAX),fequ(NMAX) + COMMON /cpf1com/ pcom,xicom,ncom + save /cpf1com/ + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call distancesys(ncom,xt,fequ,cpf1dim_fequ,idowhat) + return + END + + subroutine getequationvalues((nunknowns,xp, + & fequ,fequsqsum) +!this subroutine is for solving a nonlinear system + implicit none + integer nunknowns,idowhat + double precision xp(nunknowns),fequ(nunknowns),fequsqsum + parameter(idowhat=1) + call distancesys(nunknowns,xp,fequ,fequsqsum,idowhat) + return + end + + subroutine getsqdistance(nunknowns,xp,sqdistance) +!This subroutine returns the distance between a point on a curve (surface) and another point +!that is specified in distancesys + implicit none + integer nunknowns,idowhat + double precision xp(nunknowns),sqdistance,fequ(nunknowns) + parameter(idowhat=2) + call distancesys(nunknowns,xp,fequ,sqdistance,idowhat) + return + end + + double precision function cpf1dim_distance(x) +!this function subroutine returns the distance for line search + INTEGER NMAX + double precision x + PARAMETER (NMAX=1000) + INTEGER j,ncom,idowhat + parameter(idowhat=2) + double precision pcom(NMAX),xicom(NMAX), + & xt(NMAX),fequ(NMAX) + COMMON /cpf1com/ pcom,xicom,ncom + save /cpf1com/ + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call distancesys(ncom,xt,fequ,cpf1dim_distance,idowhat) + return + END +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ diff --git a/dataassim/math/optimization/dualannactivatefunc.f b/dataassim/math/optimization/dualannactivatefunc.f new file mode 100644 index 0000000..660fcda --- /dev/null +++ b/dataassim/math/optimization/dualannactivatefunc.f @@ -0,0 +1,122 @@ +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function + &annfunc(nparams,params,nh,q,w,bph,bend,c) + implicit none + integer nparams,nh +!nh is the number of hidden nodes in one hiden layer +!params is the inputs +!w is the weighting coefficients for the inputs + double precision params(nparams),q(nh), + & w(nparams,nh),bph(nh),bend,c(nh) + integer i,v + double precision term,activatefunc1,activatefunc2 + annfunc=bend + do i=1,nh + term=bph(i) + do v=1,nparams + term=term+w(v,i)*params(v) + enddo + annfunc=annfunc+q(i)*activatefunc1(term)+ + &c(i)*activatefunc2(term) + enddo + end + + subroutine derannfunc(nparams,params,nh,q,w,bph, + & bend,c,derq,derw,derbph,derbend,derc) + implicit none + integer nparams,nh +!nh is the number of hidden nodes in one hiden layer +!params is the inputs +!w is the weighting coefficients for the inputs + double precision params(nparams),q(nh), + & w(nparams,nh),bph(nh),bend,c(nh),derq(nh), + & derw(nparams,nh),derbph(nh),derbend,derc(nh) + integer i,v + double precision term,activatefunc1,gradactivatefunc1, + &activatefunc2,gradactivatefunc2 + + derbend=1.0d0 + do i=1,nh + term=bph(i) + do v=1,nparams + term=term+w(v,i)*params(v) + enddo + derq(i)=activatefunc1(term) + derc(i)=activatefunc2(term) + derbph(i)=q(i)*gradactivatefunc1(term)+ + & c(i)*gradactivatefunc2(term) + do v=1,nparams + derw(v,i)=derbph(i)*params(v) + enddo + enddo + end + + subroutine gradannfunc(nparams,params,nh,q,w,bph, + & c,der_params) + implicit none + integer nparams,nh + double precision params(nparams),der_params(nparams), + & q(nh),w(nparams,nh),bph(nh),c(nh) + integer i,v + double precision term,gradactivatefunc1,gradactivatefunc2 + do i=1,nparams + der_params(i)=0.0d0 + enddo + do i=1,nh + term=bph(i) + do v=1,nparams + term=term+w(v,i)*params(v) + enddo + do v=1,nparams + der_params(v)=der_params(v)+(q(i)*gradactivatefunc1(term) + &+c(i)*gradactivatefunc2(term))*w(v,i) + enddo + enddo + return + end + + double precision function activatefunc1(x) + implicit none + double precision x,crit + parameter(crit=300) + if(x.gt.-crit)then + activatefunc1=1.0d0/(1.0d0+dexp(-x)) + else + activatefunc1=dexp(x)/(1.0d0+dexp(x)) + endif + return + end + + double precision function gradactivatefunc1(x) + implicit none + double precision x,crit + parameter(crit=600) + if(x.gt.-crit.and.x.lt.crit)then + gradactivatefunc1= + & (1.0d0/(dexp(x/2.0d0)+dexp(-x/2.0d0)))**2 + else + gradactivatefunc1=0.0d0 + endif + return + end + + double precision function activatefunc2(x) + implicit none + double precision x + +! activatefunc2=2.0d0*datan(x)/3.14159265d0 +! activatefunc2=1.001d0+dsin(x) + activatefunc2=x+x*x + return + end + + double precision function gradactivatefunc2(x) + implicit none + double precision x,crit + parameter(crit=600) + +! gradactivatefunc2=2.0d0/(3.14159265d0*(1.0d0+x*x)) +! gradactivatefunc2=dcos(x) + gradactivatefunc2=1.0d0+2.0d0*x + return + end diff --git a/dataassim/math/optimization/findmindistance.f b/dataassim/math/optimization/findmindistance.f new file mode 100644 index 0000000..978dfaa --- /dev/null +++ b/dataassim/math/optimization/findmindistance.f @@ -0,0 +1,105 @@ + subroutine findmindistance(funcnleq1,fmin_funcnleq1, + & f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp, + & nunknowns,iwhichsolver) + implicit none + integer nunknowns,iwhichsolver + double precision x0min(nunknowns),x0ori(nunknowns), + & xp(nunknowns),x0max(nunknowns),fp(nunknowns) +!-------- Specified values --------------------------------------- +!funcnleq1: the subroutine that calculates the functional values of the +! the nonlinear system in the following form: +! funcnleq1(nunknowns,xp,fp,fsqsum) +!fmin_funcnleq1: the subroutine that calls funcnleq1 and returns fsqsum (half +! of the sum of the squared functional values of the nonlinear system) +! fmin_funcnleq1(nunknowns,xp,fsqsum) +!f1dim_funcnleq1: a function subroutine that returns fsqsum +! f1dim_funcnleq1(xp) +! nunknowns: The number of unknowns to be solved +! x0ori(1:nunknowns): initial guess for the unknowns +! x0min(1:nunknowns): lower bound of the solution +! x0max(1:nunknowns): upper bound of the solution +! --------- Calculated values ------------------------------------- +! fp(1:nunknowns): function values at the last step of iteration +! xp(1:nunknowns): final solutions +! iwhichsolver: +! =1 solved by plain fixed point method 1 +! =2 solved by fixed point method 2 +! =3 solved by fixed point method 3 +! =4 solved by fixed point method 4 +! =6 solved by broydn +! =7 Solved by multiobjective minimization. +! =-9999 Best approximation returned. Solution may not be accurate. +! --------- Local variables --------------------------------------- + double precision x0(nunknowns),TOLF,stpmax,scldstpmax, + & sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum, + & f1dim_funcnleq1 + integer i,irepeat,maxrepeats,IERR,notfound + intrinsic dble + parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-10) + external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1 +!------------------------------------------------------------------- + stpmax=0.0d0 + sum=0.0d0 + do i=1, nunknowns + x0(i)=x0ori(i) + sum=sum+x0ori(i)*x0ori(i) + stpmax=stpmax+ + & (x0min(i)-x0max(i))*(x0min(i)-x0max(i)) + enddo + stpmax=dsqrt(stpmax)/4.0d0 + scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns)) +! In Numerical Recipes, scldstpmax (STPMX) is 100 + scldstpmax=dmax1(100.0d0,scldstpmax) + iwhichsolver=notfound + do irepeat=1,maxrepeats + call fixedpoint(funcnleq1,x0min,x0,xp, + & x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver) + tp=dabs(fp(1)) + do i=1,nunknowns + if(dabs(fp(i)).gt.tp)tp=dabs(fp(i)) + xb(i)=xp(i) + enddo + call broydn(x0min,xb,x0max,scldstpmax,nunknowns, + & fb,funcnleq1,TOLF,IERR) + call funcnleq1(nunknowns,xb,fb,fsqsum) + tb=dabs(fb(1)) + do i=2,nunknowns + if(dabs(fb(i)).gt.tb)tb=dabs(fb(i)) + enddo + if(tb.lt.tp)then + do i=1,nunknowns + xp(i)=xb(i) + fp(i)=fb(i) + enddo + if(iwhichsolver.eq.notfound.and. + & tb.lt.TOLF)then + iwhichsolver=6 + endif + endif + fsqsum=0.0d0 + do i=1,nunknowns + fsqsum=fsqsum+fp(i)*fp(i) + enddo + fsqsum=fsqsum*0.5d0 + call nongradopt(nunknowns,fmin_funcnleq1, + & f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum) + call RepeatCompassSearch(nunknowns,xp,fsqsum, + & x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,TOLF) + call funcnleq1(nunknowns,xp,fp,fsqsum) + if(iwhichsolver.eq.notfound)then + tp=dabs(fp(1)) + do i=2,nunknowns + if(dabs(fp(i)).gt.tp)tp=dabs(fp(i)) + enddo + if(tp.lt.TOLF)iwhichsolver=7 + endif + IERR=0 + do i=1,nunknowns + if(dabs(xp(i)-x0(i)).gt.TOLF)IERR=1 + enddo + if(IERR.eq.0)return + do i=1,nunknowns + x0(i)=xp(i) + enddo + enddo + end subroutine findmindistance diff --git a/dataassim/math/optimization/forgenericregres.h b/dataassim/math/optimization/forgenericregres.h new file mode 100644 index 0000000..edd5871 --- /dev/null +++ b/dataassim/math/optimization/forgenericregres.h @@ -0,0 +1,15 @@ + integer maxndim,nobs,nxvars,nyvars,maxnobs, + & maxnxvars,maxnyvars,iregrestype,iknowder,idobounded + parameter(maxnobs=50000,maxnxvars=10,maxnyvars=10, + & maxndim=1000) + common /int_com_generic/nobs,nxvars,nyvars,iregrestype, + &iknowder,idobounded + double precision xvars(maxnobs,maxnxvars), + & yobs(maxnobs,maxnyvars),weity(maxnobs,maxnyvars), + & weitx(maxnobs,maxnxvars),betamin(maxndim), + & betamax(maxndim),shorty(maxnobs,maxnyvars), + & shortx(maxnobs,maxnxvars),xmin(maxnobs,maxnxvars), + & xmax(maxnobs,maxnxvars) + common /dble_com_generic/xvars,yobs,weity,weitx, + & betamin,betamax,shorty,shortx,xmin,xmax + save /int_com_generic/,/dble_com_generic/ diff --git a/dataassim/math/optimization/function_generic.f b/dataassim/math/optimization/function_generic.f new file mode 100644 index 0000000..89d79d4 --- /dev/null +++ b/dataassim/math/optimization/function_generic.f @@ -0,0 +1,80 @@ + subroutine function_generic(ndim,beta,nxvars, + & xvars,nyvars,ymod) + integer ndim,nxvars,nyvars + double precision beta(ndim),xvars(nxvars), + & ymod(nyvars) + double precision y0,a,b,c,x0,x,term,crit + parameter(crit=300.0d0) + a=beta(1) + b=beta(2) + c=beta(3) + x0=beta(4) + y0=beta(5) + x=xvars(1) + if((-(x-x0)/b).lt.crit)then + term=dexp(-(x-x0)/b) + ymod(1)=y0+a*(1.0d0/(1.0d0+term))**c + else + term=dexp((x-x0)/b) + ymod(1)=y0+a*(term/(1.0d0+term))**c + endif + return + end + + subroutine der_function_generic(np,beta,m, + & xvars,nq,der_beta) + implicit none + integer np,m,nq + double precision beta(np),xvars(m),der_beta(np,nq) + double precision y0,a,b,c,x0,x,term,crit + parameter(crit=300.0d0) + a=beta(1) + b=beta(2) + c=beta(3) + x0=beta(4) + y0=beta(5) + x=xvars(1) + der_beta(5,1)=1.0d0 + if((-(x-x0)/b).lt.crit)then + term=dexp(-(x-x0)/b) + der_beta(1,1)=(1.0d0/(1.0d0+term))**c +! der_x=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c) + der_beta(4,1)=-(a*c*term/b)* + & (1.0d0/(1.0d0+term))**(1.0d0+c) + der_beta(2,1)=-(a*c*term*(x-x0)/(b*b))* + & (1.0d0/(1.0d0+term))**(1.0d0+c) + der_beta(3,1)=-(a*dlog(1.0d0+term))* + & (1.0d0/(1.0d0+term))**c + else + term=(x-x0)/b + der_beta(1,1)=(dexp(term)/(1.0d0+dexp(term)))**c +! der_x=(a*c/b)*(dexp(term*c/(c+1.0d0))/ +! & (1.0d0+dexp(term)))**(c+1.0d0) + der_beta(4,1)=-(a*c/b)*(dexp(term*c/(c+1))/ + & (1.0d0+dexp(term)))**(c+1.0d0) + der_beta(2,1)=-(a*c*(x-x0)/(b*b))*(dexp(term*c/ + & (c+1.0d0))/(1.0d0+dexp(term)))**(1.0d0+c) + der_beta(3,1)=-a*(dlog(1.0d0+dexp(term))-term)* + & (dexp(term)/(1.0d0+dexp(term)))**c + endif + return + end + + subroutine indices_function_generic(ndim,beta,root, + & der_root,fmax) + implicit none + integer ndim + double precision beta(ndim),root,der_root,fmax + double precision a,b,c,x0,y0,term + a=beta(1) + b=beta(2) + c=beta(3) + x0=beta(4) + y0=beta(5) + term=(-a/y0)**(1.0d0/c)-1.0d0 + root=x0-b*dlog(term) + term=dexp(-(root-x0)/b) + der_root=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c) + fmax=a+y0 + return + end diff --git a/dataassim/math/optimization/lbfgsroutines.f b/dataassim/math/optimization/lbfgsroutines.f new file mode 100644 index 0000000..8cbfd39 --- /dev/null +++ b/dataassim/math/optimization/lbfgsroutines.f @@ -0,0 +1,4440 @@ +c================ L-BFGS-B (version 2.4) ========================== + + subroutine setulb(n, m, x, l, u, nbd, f, g, factr, pgtol, wa, iwa, + + task, iprint, csave, lsave, isave, dsave) + + character*60 task, csave + logical lsave(4) + integer n, m, iprint, + + nbd(n), iwa(3*n), isave(44) + double precision f, factr, pgtol, x(n), l(n), u(n), g(n), + + wa(2*m*n+4*n+11*m*m+8*m), dsave(29) + +c ************ +c +c Subroutine setulb +c +c This subroutine partitions the working arrays wa and iwa, and +c then uses the limited memory BFGS method to solve the bound +c constrained optimization problem by calling mainlb. +c (The direct method will be used in the subspace minimization.) +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c x is a double precision array of dimension n. +c On entry x is an approximation to the solution. +c On exit x is the current approximation. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound on x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound on x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c f is a double precision variable. +c On first entry f is unspecified. +c On final exit f is the value of the function at x. +c +c g is a double precision array of dimension n. +c On first entry g is unspecified. +c On final exit g is the value of the gradient at x. +c +c factr is a double precision variable. +c On entry factr >= 0 is specified by the user. The iteration +c will stop when +c +c (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch +c +c where epsmch is the machine precision, which is automatically +c generated by the code. Typical values for factr: 1.d+12 for +c low accuracy; 1.d+7 for moderate accuracy; 1.d+1 for extremely +c high accuracy. +c On exit factr is unchanged. +c +c pgtol is a double precision variable. +c On entry pgtol >= 0 is specified by the user. The iteration +c will stop when +c +c max{|proj g_i | i = 1, ..., n} <= pgtol +c +c where pg_i is the ith component of the projected gradient. +c On exit pgtol is unchanged. +c +c wa is a double precision working array of length +c (2mmax + 4)nmax + 11mmax^2 + 8mmax. +c +c iwa is an integer working array of length 3nmax. +c +c task is a working string of characters of length 60 indicating +c the current job when entering and quitting this subroutine. +c +c iprint is an integer variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c csave is a working string of characters of length 60. +c +c lsave is a logical working array of dimension 4. +c On exit with 'task' = NEW_X, the following information is +c available: +c If lsave(1) = .true. then the initial X has been replaced by +c its projection in the feasible set; +c If lsave(2) = .true. then the problem is constrained; +c If lsave(3) = .true. then each variable has upper and lower +c bounds; +c +c isave is an integer working array of dimension 44. +c On exit with 'task' = NEW_X, the following information is +c available: +c isave(22) = the total number of intervals explored in the +c search of Cauchy points; +c isave(26) = the total number of skipped BFGS updates before +c the current iteration; +c isave(30) = the number of current iteration; +c isave(31) = the total number of BFGS updates prior the current +c iteration; +c isave(33) = the number of intervals explored in the search of +c Cauchy point in the current iteration; +c isave(34) = the total number of function and gradient +c evaluations; +c isave(36) = the number of function value or gradient +c evaluations in the current iteration; +c if isave(37) = 0 then the subspace argmin is within the box; +c if isave(37) = 1 then the subspace argmin is beyond the box; +c isave(38) = the number of free variables in the current +c iteration; +c isave(39) = the number of active constraints in the current +c iteration; +c n + 1 - isave(40) = the number of variables leaving the set of +c active constraints in the current iteration; +c isave(41) = the number of variables entering the set of active +c constraints in the current iteration. +c +c dsave is a double precision working array of dimension 29. +c On exit with 'task' = NEW_X, the following information is +c available: +c dsave(1) = current 'theta' in the BFGS matrix; +c dsave(2) = f(x) in the previous iteration; +c dsave(3) = factr*epsmch; +c dsave(4) = 2-norm of the line search direction vector; +c dsave(5) = the machine precision epsmch generated by the code; +c dsave(7) = the accumulated time spent on searching for +c Cauchy points; +c dsave(8) = the accumulated time spent on +c subspace minimization; +c dsave(9) = the accumulated time spent on line search; +c dsave(11) = the slope of the line search function at +c the current point of line search; +c dsave(12) = the maximum relative step length imposed in +c line search; +c dsave(13) = the infinity norm of the projected gradient; +c dsave(14) = the relative step length in the line search; +c dsave(15) = the slope of the line search function at +c the starting point of the line search; +c dsave(16) = the square of the 2-norm of the line search +c direction vector. +c +c Subprograms called: +c +c L-BFGS-B Library ... mainlb. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a +c limited memory FORTRAN code for solving bound constrained +c optimization problems'', Tech. Report, NAM-11, EECS Department, +c Northwestern University, 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to ece.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision April 1997.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer l1,l2,l3,lws,lr,lz,lt,ld,lwa,lwy,lsy,lss,lwt,lwn,lsnd + + if (task .eq. 'START') then + isave(1) = m*n + isave(2) = m**2 + isave(3) = 4*m**2 + isave(4) = 1 + isave(5) = isave(4) + isave(1) + isave(6) = isave(5) + isave(1) + isave(7) = isave(6) + isave(2) + isave(8) = isave(7) + isave(2) + isave(9) = isave(8) + isave(10) = isave(9) + isave(2) + isave(11) = isave(10) + isave(3) + isave(12) = isave(11) + isave(3) + isave(13) = isave(12) + n + isave(14) = isave(13) + n + isave(15) = isave(14) + n + isave(16) = isave(15) + n + endif + l1 = isave(1) + l2 = isave(2) + l3 = isave(3) + lws = isave(4) + lwy = isave(5) + lsy = isave(6) + lss = isave(7) + lwt = isave(9) + lwn = isave(10) + lsnd = isave(11) + lz = isave(12) + lr = isave(13) + ld = isave(14) + lt = isave(15) + lwa = isave(16) + + call mainlb(n,m,x,l,u,nbd,f,g,factr,pgtol, + + wa(lws),wa(lwy),wa(lsy),wa(lss),wa(lwt), + + wa(lwn),wa(lsnd),wa(lz),wa(lr),wa(ld),wa(lt), + + wa(lwa),iwa(1),iwa(n+1),iwa(2*n+1),task,iprint, + + csave,lsave,isave(22),dsave) + + return + + end + +c======================= The end of setulb ============================= + + subroutine mainlb(n, m, x, l, u, nbd, f, g, factr, pgtol, ws, wy, + + sy, ss, wt, wn, snd, z, r, d, t, wa, + + index, iwhere, indx2, task, iprint, + + csave, lsave, isave, dsave) + + character*60 task, csave + logical lsave(4) + integer n, m, iprint, nbd(n), index(n), + + iwhere(n), indx2(n), isave(23) + double precision f, factr, pgtol, + + x(n), l(n), u(n), g(n), z(n), r(n), d(n), t(n), + + wa(8*m), ws(n, m), wy(n, m), sy(m, m), ss(m, m), + + wt(m, m), wn(2*m, 2*m), snd(2*m, 2*m), dsave(29) + +c ************ +c +c Subroutine mainlb +c +c This subroutine solves bound constrained optimization problems by +c using the compact formula of the limited memory BFGS updates. +c +c n is an integer variable. +c On entry n is the number of variables. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric +c corrections allowed in the limited memory matrix. +c On exit m is unchanged. +c +c x is a double precision array of dimension n. +c On entry x is an approximation to the solution. +c On exit x is the current approximation. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c f is a double precision variable. +c On first entry f is unspecified. +c On final exit f is the value of the function at x. +c +c g is a double precision array of dimension n. +c On first entry g is unspecified. +c On final exit g is the value of the gradient at x. +c +c factr is a double precision variable. +c On entry factr >= 0 is specified by the user. The iteration +c will stop when +c +c (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch +c +c where epsmch is the machine precision, which is automatically +c generated by the code. +c On exit factr is unchanged. +c +c pgtol is a double precision variable. +c On entry pgtol >= 0 is specified by the user. The iteration +c will stop when +c +c max{|proj g_i | i = 1, ..., n} <= pgtol +c +c where pg_i is the ith component of the projected gradient. +c On exit pgtol is unchanged. +c +c ws, wy, sy, and wt are double precision working arrays used to +c store the following information defining the limited memory +c BFGS matrix: +c ws, of dimension n x m, stores S, the matrix of s-vectors; +c wy, of dimension n x m, stores Y, the matrix of y-vectors; +c sy, of dimension m x m, stores S'Y; +c ss, of dimension m x m, stores S'S; +c wt, of dimension m x m, stores the Cholesky factorization +c of (theta*S'S+LD^(-1)L'); see eq. +c (2.26) in [3]. +c +c wn is a double precision working array of dimension 2m x 2m +c used to store the LEL^T factorization of the indefinite matrix +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c where E = [-I 0] +c [ 0 I] +c +c snd is a double precision working array of dimension 2m x 2m +c used to store the lower triangular part of +c N = [Y' ZZ'Y L_a'+R_z'] +c [L_a +R_z S'AA'S ] +c +c z(n),r(n),d(n),t(n),wa(8*m) are double precision working arrays. +c z is used at different times to store the Cauchy point and +c the Newton point. +c +c +c index is an integer working array of dimension n. +c In subroutine freev, index is used to store the free and fixed +c variables at the Generalized Cauchy Point (GCP). +c +c iwhere is an integer working array of dimension n used to record +c the status of the vector x for GCP computation. +c iwhere(i)=0 or -3 if x(i) is free and has bounds, +c 1 if x(i) is fixed at l(i), and l(i) .ne. u(i) +c 2 if x(i) is fixed at u(i), and u(i) .ne. l(i) +c 3 if x(i) is always fixed, i.e., u(i)=x(i)=l(i) +c -1 if x(i) is always free, i.e., no bounds on it. +c +c indx2 is an integer working array of dimension n. +c Within subroutine cauchy, indx2 corresponds to the array iorder. +c In subroutine freev, a list of variables entering and leaving +c the free set is stored in indx2, and it is passed on to +c subroutine formk with this information. +c +c task is a working string of characters of length 60 indicating +c the current job when entering and leaving this subroutine. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c csave is a working string of characters of length 60. +c +c lsave is a logical working array of dimension 4. +c +c isave is an integer working array of dimension 23. +c +c dsave is a double precision working array of dimension 29. +c +c +c Subprograms called +c +c L-BFGS-B Library ... cauchy, subsm, lnsrlb, formk, +c +c errclb, prn1lb, prn2lb, prn3lb, active, projgr, +c +c freev, cmprlb, matupd, formt. +c +c Minpack2 Library ... timer, dpmeps. +c +c Linpack Library ... dcopy, ddot. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN +c Subroutines for Large Scale Bound Constrained Optimization'' +c Tech. Report, NAM-11, EECS Department, Northwestern University, +c 1994. +c +c [3] R. Byrd, J. Nocedal and R. Schnabel "Representations of +c Quasi-Newton Matrices and their use in Limited Memory Methods'', +c Mathematical Programming 63 (1994), no. 4, pp. 129-156. +c +c (Postscript files of these papers are available via anonymous +c ftp to ece.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision April 1997.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + logical prjctd,cnstnd,boxed,updatd,wrk + character*3 word + integer i,k,nintol,itfile,iback,nskip, + + head,col,iter,itail,iupdat, + + nint,nfgv,info,ifun, + + iword,nfree,nact,ileave,nenter + double precision theta,fold,ddot,dr,rr,tol,dpmeps, + + xstep,sbgnrm,ddum,dnorm,dtd,epsmch, + + cpu1,cpu2,cachyt,sbtime,lnscht,time1,time2, + + gd,gdold,stp,stpmx,time + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + + if (task .eq. 'START') then + + call timer(time1) + +c Generate the current machine precision. + + epsmch = dpmeps() + fold = 0.0d0 + dnorm = 0.0d0 + cpu1 = 0.0d0 + gd = 0.0d0 + sbgnrm = 0.0d0 + stp = 0.0d0 + stpmx = 0.0d0 + gdold = 0.0d0 + dtd = 0.0d0 + + +c Initialize counters and scalars when task='START'. + +c for the limited memory BFGS matrices: + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + iback = 0 + itail = 0 + ifun = 0 + iword = 0 + nact = 0 + ileave = 0 + nenter = 0 + +c for operation counts: + iter = 0 + nfgv = 0 + nint = 0 + nintol = 0 + nskip = 0 + nfree = n + +c for stopping tolerance: + tol = factr*epsmch + +c for measuring running time: + cachyt = 0 + sbtime = 0 + lnscht = 0 + +c 'word' records the status of subspace solutions. + word = '---' + +c 'info' records the termination information. + info = 0 + itfile = 0 + + if (iprint .ge. 1) then +c open a summary file 'iterate.dat' + open (8, file = 'iterate.dat', status = 'unknown') + itfile = 8 + endif + +c Check the input arguments for errors. + + call errclb(n,m,factr,l,u,nbd,task,info,k) + if (task(1:5) .eq. 'ERROR') then + call prn3lb(n,x,f,task,iprint,info,itfile, + + iter,nfgv,nintol,nskip,nact,sbgnrm, + + zero,nint,word,iback,stp,xstep,k, + + cachyt,sbtime,lnscht) + return + endif + + call prn1lb(n,m,l,u,x,iprint,itfile,epsmch) + +c Initialize iwhere & project x onto the feasible set. + + call active(n,l,u,nbd,x,iwhere,iprint,prjctd,cnstnd,boxed) + +c The end of the initialization. + + else +c restore local variables. + + prjctd = lsave(1) + cnstnd = lsave(2) + boxed = lsave(3) + updatd = lsave(4) + + nintol = isave(1) + itfile = isave(3) + iback = isave(4) + nskip = isave(5) + head = isave(6) + col = isave(7) + itail = isave(8) + iter = isave(9) + iupdat = isave(10) + nint = isave(12) + nfgv = isave(13) + info = isave(14) + ifun = isave(15) + iword = isave(16) + nfree = isave(17) + nact = isave(18) + ileave = isave(19) + nenter = isave(20) + + theta = dsave(1) + fold = dsave(2) + tol = dsave(3) + dnorm = dsave(4) + epsmch = dsave(5) + cpu1 = dsave(6) + cachyt = dsave(7) + sbtime = dsave(8) + lnscht = dsave(9) + time1 = dsave(10) + gd = dsave(11) + stpmx = dsave(12) + sbgnrm = dsave(13) + stp = dsave(14) + gdold = dsave(15) + dtd = dsave(16) + +c After returning from the driver go to the point where execution +c is to resume. + + if (task(1:5) .eq. 'FG_LN') goto 666 + if (task(1:5) .eq. 'NEW_X') goto 777 + if (task(1:5) .eq. 'FG_ST') goto 111 + if (task(1:4) .eq. 'STOP') then + if (task(7:9) .eq. 'CPU') then +c restore the previous iterate. + call dcopy(n,t,1,x,1) + call dcopy(n,r,1,g,1) + f = fold + endif + goto 999 + endif + endif + +c Compute f0 and g0. + + task = 'FG_START' +c return to the driver to calculate f and g; reenter at 111. + goto 1000 + 111 continue + nfgv = 1 + +c Compute the infinity norm of the (-) projected gradient. + + call projgr(n,l,u,nbd,x,g,sbgnrm) + + if (iprint .ge. 1) then + write (6,1002) iter,f,sbgnrm + write (itfile,1003) iter,nfgv,sbgnrm,f + endif + if (sbgnrm .le. pgtol) then +c terminate the algorithm. + task = 'CONVERGENCE: NORM OF PROJECTED GRADIENT <= PGTOL' + goto 999 + endif + +c ----------------- the beginning of the loop -------------------------- + + 222 continue + if (iprint .ge. 99) write (6,1001) iter + 1 + iword = -1 +c + if (.not. cnstnd .and. col .gt. 0) then +c skip the search for GCP. + call dcopy(n,x,1,z,1) + wrk = updatd + nint = 0 + goto 333 + endif + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Compute the Generalized Cauchy Point (GCP). +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + call timer(cpu1) + call cauchy(n,x,l,u,nbd,g,indx2,iwhere,t,d,z, + + m,wy,ws,sy,wt,theta,col,head, + + wa(1),wa(2*m+1),wa(4*m+1),wa(6*m+1),nint, + + iprint,sbgnrm,info,epsmch) + if (info .ne. 0) then +c singular triangular system detected; refresh the lbfgs memory. + if(iprint .ge. 1) write (6, 1005) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + cachyt = cachyt + cpu2 - cpu1 + goto 222 + endif + call timer(cpu2) + cachyt = cachyt + cpu2 - cpu1 + nintol = nintol + nint + +c Count the entering and leaving variables for iter > 0; +c find the index set of free and active variables at the GCP. + + call freev(n,nfree,index,nenter,ileave,indx2, + + iwhere,wrk,updatd,cnstnd,iprint,iter) + + nact = n - nfree + + 333 continue + +c If there are no free variables or B=theta*I, then +c skip the subspace minimization. + + if (nfree .eq. 0 .or. col .eq. 0) goto 555 + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Subspace minimization. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + call timer(cpu1) + +c Form the LEL^T factorization of the indefinite +c matrix K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] + + if (wrk) call formk(n,nfree,index,nenter,ileave,indx2,iupdat, + + updatd,wn,snd,m,ws,wy,sy,theta,col,head,info) + if (info .ne. 0) then +c nonpositive definiteness in Cholesky factorization; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1006) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + goto 222 + endif + +c compute r=-Z'B(xcp-xk)-Z'g (using wa(2m+1)=W'(xcp-x) +c from 'cauchy'). + call cmprlb(n,m,x,g,ws,wy,sy,wt,z,r,wa,index, + + theta,col,head,nfree,cnstnd,info) + if (info .ne. 0) goto 444 +c call the direct method. + call subsm(n,m,nfree,index,l,u,nbd,z,r,ws,wy,theta, + + col,head,iword,wa,wn,iprint,info) + 444 continue + if (info .ne. 0) then +c singular triangular system detected; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1005) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + goto 222 + endif + + call timer(cpu2) + sbtime = sbtime + cpu2 - cpu1 + 555 continue + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Line search and optimality tests. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +c Generate the search direction d:=z-x. + + do 40 i = 1, n + d(i) = z(i) - x(i) + 40 continue + call timer(cpu1) + 666 continue + call lnsrlb(n,l,u,nbd,x,f,fold,gd,gdold,g,d,r,t,z,stp,dnorm, + + dtd,xstep,stpmx,iter,ifun,iback,nfgv,info,task, + + boxed,cnstnd,csave,isave(22),dsave(17)) + if (info .ne. 0 .or. iback .ge. 20) then +c restore the previous iterate. + call dcopy(n,t,1,x,1) + call dcopy(n,r,1,g,1) + f = fold + if (col .eq. 0) then +c abnormal termination. + if (info .eq. 0) then + info = -9 +c restore the actual number of f and g evaluations etc. + nfgv = nfgv - 1 + ifun = ifun - 1 + iback = iback - 1 + endif + task = 'ABNORMAL_TERMINATION_IN_LNSRCH' + iter = iter + 1 + goto 999 + else +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1008) + if (info .eq. 0) nfgv = nfgv - 1 + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + task = 'RESTART_FROM_LNSRCH' + call timer(cpu2) + lnscht = lnscht + cpu2 - cpu1 + goto 222 + endif + else if (task(1:5) .eq. 'FG_LN') then +c return to the driver for calculating f and g; reenter at 666. + goto 1000 + else +c calculate and print out the quantities related to the new X. + call timer(cpu2) + lnscht = lnscht + cpu2 - cpu1 + iter = iter + 1 + +c Compute the infinity norm of the projected (-)gradient. + + call projgr(n,l,u,nbd,x,g,sbgnrm) + +c Print iteration information. + + call prn2lb(n,x,f,g,iprint,itfile,iter,nfgv,nact, + + sbgnrm,nint,word,iword,iback,stp,xstep) + goto 1000 + endif + 777 continue + +c Test for termination. + + if (sbgnrm .le. pgtol) then +c terminate the algorithm. + task = 'CONVERGENCE: NORM OF PROJECTED GRADIENT <= PGTOL' + goto 999 + endif + + ddum = max(abs(fold), abs(f), one) + if ((fold - f) .le. tol*ddum) then +c terminate the algorithm. + task = 'CONVERGENCE: REL_REDUCTION_OF_F <= FACTR*EPSMCH' + if (iback .ge. 10) info = -5 +c i.e., to issue a warning if iback>10 in the line search. + goto 999 + endif + +c Compute d=newx-oldx, r=newg-oldg, rr=y'y and dr=y's. + + do 42 i = 1, n + r(i) = g(i) - r(i) + 42 continue + rr = ddot(n,r,1,r,1) + if (stp .eq. one) then + dr = gd - gdold + ddum = -gdold + else + dr = (gd - gdold)*stp + call dscal(n,stp,d,1) + ddum = -gdold*stp + endif + + if (dr .le. epsmch*ddum) then +c skip the L-BFGS update. + nskip = nskip + 1 + updatd = .false. + if (iprint .ge. 1) write (6,1004) dr, ddum + goto 888 + endif + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Update the L-BFGS matrix. +c +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + updatd = .true. + iupdat = iupdat + 1 + +c Update matrices WS and WY and form the middle matrix in B. + + call matupd(n,m,ws,wy,sy,ss,d,r,itail, + + iupdat,col,head,theta,rr,dr,stp,dtd) + +c Form the upper half of the pds T = theta*SS + L*D^(-1)*L'; +c Store T in the upper triangular of the array wt; +c Cholesky factorize T to J*J' with +c J' stored in the upper triangular of wt. + + call formt(m,wt,sy,ss,col,theta,info) + + if (info .ne. 0) then +c nonpositive definiteness in Cholesky factorization; +c refresh the lbfgs memory and restart the iteration. + if(iprint .ge. 1) write (6, 1007) + info = 0 + col = 0 + head = 1 + theta = one + iupdat = 0 + updatd = .false. + goto 222 + endif + +c Now the inverse of the middle matrix in B is + +c [ D^(1/2) O ] [ -D^(1/2) D^(-1/2)*L' ] +c [ -L*D^(-1/2) J ] [ 0 J' ] + + 888 continue + +c -------------------- the end of the loop ----------------------------- + + goto 222 + 999 continue + call timer(time2) + time = time2 - time1 + call prn3lb(n,x,f,task,iprint,info,itfile, + + iter,nfgv,nintol,nskip,nact,sbgnrm, + + time,nint,word,iback,stp,xstep,k, + + cachyt,sbtime,lnscht) + 1000 continue + +c Save local variables. + + lsave(1) = prjctd + lsave(2) = cnstnd + lsave(3) = boxed + lsave(4) = updatd + + isave(1) = nintol + isave(3) = itfile + isave(4) = iback + isave(5) = nskip + isave(6) = head + isave(7) = col + isave(8) = itail + isave(9) = iter + isave(10) = iupdat + isave(12) = nint + isave(13) = nfgv + isave(14) = info + isave(15) = ifun + isave(16) = iword + isave(17) = nfree + isave(18) = nact + isave(19) = ileave + isave(20) = nenter + + dsave(1) = theta + dsave(2) = fold + dsave(3) = tol + dsave(4) = dnorm + dsave(5) = epsmch + dsave(6) = cpu1 + dsave(7) = cachyt + dsave(8) = sbtime + dsave(9) = lnscht + dsave(10) = time1 + dsave(11) = gd + dsave(12) = stpmx + dsave(13) = sbgnrm + dsave(14) = stp + dsave(15) = gdold + dsave(16) = dtd + + 1001 format (//,'ITERATION ',i5) + 1002 format + + (/,'At iterate',i5,4x,'f= ',1p,d12.5,4x,'|proj g|= ',1p,d12.5) + 1003 format (2(1x,i4),5x,'-',5x,'-',3x,'-',5x,'-',5x,'-',8x,'-',3x, + + 1p,2(1x,d10.3)) + 1004 format (' ys=',1p,e10.3,' -gs=',1p,e10.3,' BFGS update SKIPPED') + 1005 format (/, + +' Singular triangular system detected;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1006 format (/, + +' Nonpositive definiteness in Cholesky factorization in formk;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1007 format (/, + +' Nonpositive definiteness in Cholesky factorization in formt;',/, + +' refresh the lbfgs memory and restart the iteration.') + 1008 format (/, + +' Bad direction in the line search;',/, + +' refresh the lbfgs memory and restart the iteration.') + + return + + end + +c======================= The end of mainlb ============================= + + subroutine active(n, l, u, nbd, x, iwhere, iprint, + + prjctd, cnstnd, boxed) + + logical prjctd, cnstnd, boxed + integer n, iprint, nbd(n), iwhere(n) + double precision x(n), l(n), u(n) + +c ************ +c +c Subroutine active +c +c This subroutine initializes iwhere and projects the initial x to +c the feasible set if necessary. +c +c iwhere is an integer array of dimension n. +c On entry iwhere is unspecified. +c On exit iwhere(i)=-1 if x(i) has no bounds +c 3 if l(i)=u(i) +c 0 otherwise. +c In cauchy, iwhere is given finer gradations. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer nbdd,i + double precision zero + parameter (zero=0.0d0) + +c Initialize nbdd, prjctd, cnstnd and boxed. + + nbdd = 0 + prjctd = .false. + cnstnd = .false. + boxed = .true. + +c Project the initial x to the easible set if necessary. + + do 10 i = 1, n + if (nbd(i) .gt. 0) then + if (nbd(i) .le. 2 .and. x(i) .le. l(i)) then + if (x(i) .lt. l(i)) then + prjctd = .true. + x(i) = l(i) + endif + nbdd = nbdd + 1 + else if (nbd(i) .ge. 2 .and. x(i) .ge. u(i)) then + if (x(i) .gt. u(i)) then + prjctd = .true. + x(i) = u(i) + endif + nbdd = nbdd + 1 + endif + endif + 10 continue + +c Initialize iwhere and assign values to cnstnd and boxed. + + do 20 i = 1, n + if (nbd(i) .ne. 2) boxed = .false. + if (nbd(i) .eq. 0) then +c this variable is always free + iwhere(i) = -1 + +c otherwise set x(i)=mid(x(i), u(i), l(i)). + else + cnstnd = .true. + if (nbd(i) .eq. 2 .and. u(i) - l(i) .le. zero) then +c this variable is always fixed + iwhere(i) = 3 + else + iwhere(i) = 0 + endif + endif + 20 continue + + if (iprint .ge. 0) then + if (prjctd) write (6,*) + + 'The initial X is infeasible. Restart with its projection.' + if (.not. cnstnd) + + write (6,*) 'This problem is unconstrained.' + endif + + if (iprint .gt. 0) write (6,1001) nbdd + + 1001 format (/,'At X0 ',i9,' variables are exactly at the bounds') + + return + + end + +c======================= The end of active ============================= + + subroutine bmv(m, sy, wt, col, v, p, info) + + integer m, col, info + double precision sy(m, m), wt(m, m), v(2*col), p(2*col) + +c ************ +c +c Subroutine bmv +c +c This subroutine computes the product of the 2m x 2m middle matrix +c in the compact L-BFGS formula of B and a 2m vector v; +c it returns the product in p. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c sy is a double precision array of dimension m x m. +c On entry sy specifies the matrix S'Y. +c On exit sy is unchanged. +c +c wt is a double precision array of dimension m x m. +c On entry wt specifies the upper triangular matrix J' which is +c the Cholesky factor of (thetaS'S+LD^(-1)L'). +c On exit wt is unchanged. +c +c col is an integer variable. +c On entry col specifies the number of s-vectors (or y-vectors) +c stored in the compact L-BFGS formula. +c On exit col is unchanged. +c +c v is a double precision array of dimension 2col. +c On entry v specifies vector v. +c On exit v is unchanged. +c +c p is a double precision array of dimension 2col. +c On entry p is unspecified. +c On exit p is the product Mv. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return, +c = nonzero for abnormal return when the system +c to be solved by dtrsl is singular. +c +c Subprograms called: +c +c Linpack ... dtrsl. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,k,i2 + double precision sum + + if (col .eq. 0) return + +c PART I: solve [ D^(1/2) O ] [ p1 ] = [ v1 ] +c [ -L*D^(-1/2) J ] [ p2 ] [ v2 ]. + +c solve Jp2=v2+LD^(-1)v1. + p(col + 1) = v(col + 1) + do 20 i = 2, col + i2 = col + i + sum = 0.0d0 + do 10 k = 1, i - 1 + sum = sum + sy(i,k)*v(k)/sy(k,k) + 10 continue + p(i2) = v(i2) + sum + 20 continue +c Solve the triangular system + call dtrsl(wt,m,col,p(col+1),11,info) + if (info .ne. 0) return + +c solve D^(1/2)p1=v1. +cc do 30 i = 1, col +cc p(i) = v(i)/sqrt(sy(i,i)) +cc30 continue + +c PART II: solve [ -D^(1/2) D^(-1/2)*L' ] [ p1 ] = [ p1 ] +c [ 0 J' ] [ p2 ] [ p2 ]. + +c solve J^Tp2=p2. + call dtrsl(wt,m,col,p(col+1),01,info) + if (info .ne. 0) return + +c compute p1=-D^(-1/2)(p1-D^(-1/2)L'p2) +c =-D^(-1/2)p1+D^(-1)L'p2. + do 40 i = 1, col +cc p(i) = -p(i)/sqrt(sy(i,i)) combined with do 30 loop +cc into the next line + p(i) = -v(i)/sy(i,i) + 40 continue + do 60 i = 1, col + sum = 0.d0 + do 50 k = i + 1, col + sum = sum + sy(k,i)*p(col+k)/sy(i,i) + 50 continue + p(i) = p(i) + sum + 60 continue + + return + + end + +c======================== The end of bmv =============================== + + subroutine cauchy(n, x, l, u, nbd, g, iorder, iwhere, t, d, xcp, + + m, wy, ws, sy, wt, theta, col, head, p, c, wbp, + + v, nint, iprint, sbgnrm, info, epsmch) + + integer n, m, head, col, nint, iprint, info, + + nbd(n), iorder(n), iwhere(n) + double precision theta, epsmch, + + x(n), l(n), u(n), g(n), t(n), d(n), xcp(n), + + wy(n, col), ws(n, col), sy(m, m), + + wt(m, m), p(2*m), c(2*m), wbp(2*m), v(2*m) + +c ************ +c +c Subroutine cauchy +c +c For given x, l, u, g (with sbgnrm > 0), and a limited memory +c BFGS matrix B defined in terms of matrices WY, WS, WT, and +c scalars head, col, and theta, this subroutine computes the +c generalized Cauchy point (GCP), defined as the first local +c minimizer of the quadratic +c +c Q(x + s) = g's + 1/2 s'Bs +c +c along the projected gradient direction P(x-tg,l,u). +c The routine returns the GCP in xcp. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c x is a double precision array of dimension n. +c On entry x is the starting point for the GCP computation. +c On exit x is unchanged. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is an integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c g is a double precision array of dimension n. +c On entry g is the gradient of f(x). g must be a nonzero vector. +c On exit g is unchanged. +c +c iorder is an integer working array of dimension n. +c iorder will be used to store the breakpoints in the piecewise +c linear path and free variables encountered. On exit, +c iorder(1),...,iorder(nleft) are indices of breakpoints +c which have not been encountered; +c iorder(nleft+1),...,iorder(nbreak) are indices of +c encountered breakpoints; and +c iorder(nfree),...,iorder(n) are indices of variables which +c have no bound constraits along the search direction. +c +c iwhere is an integer array of dimension n. +c On entry iwhere indicates only the permanently fixed (iwhere=3) +c or free (iwhere= -1) components of x. +c On exit iwhere records the status of the current x variables. +c iwhere(i)=-3 if x(i) is free and has bounds, but is not moved +c 0 if x(i) is free and has bounds, and is moved +c 1 if x(i) is fixed at l(i), and l(i) .ne. u(i) +c 2 if x(i) is fixed at u(i), and u(i) .ne. l(i) +c 3 if x(i) is always fixed, i.e., u(i)=x(i)=l(i) +c -1 if x(i) is always free, i.e., it has no bounds. +c +c t is a double precision working array of dimension n. +c t will be used to store the break points. +c +c d is a double precision array of dimension n used to store +c the Cauchy direction P(x-tg)-x. +c +c xcp is a double precision array of dimension n used to return the +c GCP on exit. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c ws, wy, sy, and wt are double precision arrays. +c On entry they store information that defines the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c sy(m,m) stores S'Y; +c wt(m,m) stores the +c Cholesky factorization of (theta*S'S+LD^(-1)L'). +c On exit these arrays are unchanged. +c +c theta is a double precision variable. +c On entry theta is the scaling factor specifying B_0 = theta I. +c On exit theta is unchanged. +c +c col is an integer variable. +c On entry col is the actual number of variable metric +c corrections stored so far. +c On exit col is unchanged. +c +c head is an integer variable. +c On entry head is the location of the first s-vector +c (or y-vector) in S (or Y). +c On exit col is unchanged. +c +c p is a double precision working array of dimension 2m. +c p will be used to store the vector p = W^(T)d. +c +c c is a double precision working array of dimension 2m. +c c will be used to store the vector c = W^(T)(xcp-x). +c +c wbp is a double precision working array of dimension 2m. +c wbp will be used to store the row of W corresponding +c to a breakpoint. +c +c v is a double precision working array of dimension 2m. +c +c nint is an integer variable. +c On exit nint records the number of quadratic segments explored +c in searching for the GCP. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c sbgnrm is a double precision variable. +c On entry sbgnrm is the norm of the projected gradient at x. +c On exit sbgnrm is unchanged. +c +c info is an integer variable. +c On entry info is 0. +c On exit info = 0 for normal return, +c = nonzero for abnormal return when the the system +c used in routine bmv is singular. +c +c Subprograms called: +c +c L-BFGS-B Library ... hpsolb, bmv. +c +c Linpack ... dscal dcopy, daxpy. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN +c Subroutines for Large Scale Bound Constrained Optimization'' +c Tech. Report, NAM-11, EECS Department, Northwestern University, +c 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to ece.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision April 1997.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + logical xlower,xupper,bnded + integer i,j,col2,nfree,nbreak,pointr, + + ibp,nleft,ibkmin,iter + double precision f1,f2,dt,dtm,tsum,dibp,zibp,dibp2,bkmin, + + tu,tl,wmc,wmp,wmw,ddot,tj,tj0,neggi,sbgnrm, + + f2_org + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + +c Check the status of the variables, reset iwhere(i) if necessary; +c compute the Cauchy direction d and the breakpoints t; initialize +c the derivative f1 and the vector p = W'd (for theta = 1). + + if (sbgnrm .le. zero) then + if (iprint .ge. 0) write (6,*) 'Subgnorm = 0. GCP = X.' + call dcopy(n,x,1,xcp,1) + return + endif + bnded = .true. + nfree = n + 1 + nbreak = 0 + ibkmin = 0 + bkmin = zero + col2 = 2*col + f1 = zero + if (iprint .ge. 99) write (6,3010) + +c We set p to zero and build it up as we determine d. + + do 20 i = 1, col2 + p(i) = zero + 20 continue + +c In the following loop we determine for each variable its bound +c status and its breakpoint, and update p accordingly. +c Smallest breakpoint is identified. + + do 50 i = 1, n + neggi = -g(i) + if (iwhere(i) .ne. 3 .and. iwhere(i) .ne. -1) then +c if x(i) is not a constant and has bounds, +c compute the difference between x(i) and its bounds. + if (nbd(i) .le. 2) tl = x(i) - l(i) + if (nbd(i) .ge. 2) tu = u(i) - x(i) + +c If a variable is close enough to a bound +c we treat it as at bound. + xlower = nbd(i) .le. 2 .and. tl .le. zero + xupper = nbd(i) .ge. 2 .and. tu .le. zero + +c reset iwhere(i). + iwhere(i) = 0 + if (xlower) then + if (neggi .le. zero) iwhere(i) = 1 + else if (xupper) then + if (neggi .ge. zero) iwhere(i) = 2 + else + if (abs(neggi) .le. zero) iwhere(i) = -3 + endif + endif + pointr = head + if (iwhere(i) .ne. 0 .and. iwhere(i) .ne. -1) then + d(i) = zero + else + d(i) = neggi + f1 = f1 - neggi*neggi +c calculate p := p - W'e_i* (g_i). + do 40 j = 1, col + p(j) = p(j) + wy(i,pointr)* neggi + p(col + j) = p(col + j) + ws(i,pointr)*neggi + pointr = mod(pointr,m) + 1 + 40 continue + if (nbd(i) .le. 2 .and. nbd(i) .ne. 0 + + .and. neggi .lt. zero) then +c x(i) + d(i) is bounded; compute t(i). + nbreak = nbreak + 1 + iorder(nbreak) = i + t(nbreak) = tl/(-neggi) + if (nbreak .eq. 1 .or. t(nbreak) .lt. bkmin) then + bkmin = t(nbreak) + ibkmin = nbreak + endif + else if (nbd(i) .ge. 2 .and. neggi .gt. zero) then +c x(i) + d(i) is bounded; compute t(i). + nbreak = nbreak + 1 + iorder(nbreak) = i + t(nbreak) = tu/neggi + if (nbreak .eq. 1 .or. t(nbreak) .lt. bkmin) then + bkmin = t(nbreak) + ibkmin = nbreak + endif + else +c x(i) + d(i) is not bounded. + nfree = nfree - 1 + iorder(nfree) = i + if (abs(neggi) .gt. zero) bnded = .false. + endif + endif + 50 continue + +c The indices of the nonzero components of d are now stored +c in iorder(1),...,iorder(nbreak) and iorder(nfree),...,iorder(n). +c The smallest of the nbreak breakpoints is in t(ibkmin)=bkmin. + + if (theta .ne. one) then +c complete the initialization of p for theta not= one. + call dscal(col,theta,p(col+1),1) + endif + +c Initialize GCP xcp = x. + + call dcopy(n,x,1,xcp,1) + + if (nbreak .eq. 0 .and. nfree .eq. n + 1) then +c is a zero vector, return with the initial xcp as GCP. + if (iprint .gt. 100) write (6,1010) (xcp(i), i = 1, n) + return + endif + +c Initialize c = W'(xcp - x) = 0. + + do 60 j = 1, col2 + c(j) = zero + 60 continue + +c Initialize derivative f2. + + f2 = -theta*f1 + f2_org = f2 + if (col .gt. 0) then + call bmv(m,sy,wt,col,p,v,info) + if (info .ne. 0) return + f2 = f2 - ddot(col2,v,1,p,1) + endif + dtm = -f1/f2 + tsum = zero + nint = 1 + if (iprint .ge. 99) + + write (6,*) 'There are ',nbreak,' breakpoints ' + +c If there are no breakpoints, locate the GCP and return. + + if (nbreak .eq. 0) goto 888 + + nleft = nbreak + iter = 1 + + + tj = zero + +c------------------- the beginning of the loop ------------------------- + + 777 continue + +c Find the next smallest breakpoint; +c compute dt = t(nleft) - t(nleft + 1). + + tj0 = tj + if (iter .eq. 1) then +c Since we already have the smallest breakpoint we need not do +c heapsort yet. Often only one breakpoint is used and the +c cost of heapsort is avoided. + tj = bkmin + ibp = iorder(ibkmin) + else + if (iter .eq. 2) then +c Replace the already used smallest breakpoint with the +c breakpoint numbered nbreak > nlast, before heapsort call. + if (ibkmin .ne. nbreak) then + t(ibkmin) = t(nbreak) + iorder(ibkmin) = iorder(nbreak) + endif +c Update heap structure of breakpoints +c (if iter=2, initialize heap). + endif + call hpsolb(nleft,t,iorder,iter-2) + tj = t(nleft) + ibp = iorder(nleft) + endif + + dt = tj - tj0 + + if (dt .ne. zero .and. iprint .ge. 100) then + write (6,4011) nint,f1,f2 + write (6,5010) dt + write (6,6010) dtm + endif + +c If a minimizer is within this interval, +c locate the GCP and return. + + if (dtm .lt. dt) goto 888 + +c Otherwise fix one variable and +c reset the corresponding component of d to zero. + + tsum = tsum + dt + nleft = nleft - 1 + iter = iter + 1 + dibp = d(ibp) + d(ibp) = zero + if (dibp .gt. zero) then + zibp = u(ibp) - x(ibp) + xcp(ibp) = u(ibp) + iwhere(ibp) = 2 + else + zibp = l(ibp) - x(ibp) + xcp(ibp) = l(ibp) + iwhere(ibp) = 1 + endif + if (iprint .ge. 100) write (6,*) 'Variable ',ibp,' is fixed.' + if (nleft .eq. 0 .and. nbreak .eq. n) then +c all n variables are fixed, +c return with xcp as GCP. + dtm = dt + goto 999 + endif + +c Update the derivative information. + + nint = nint + 1 + dibp2 = dibp**2 + +c Update f1 and f2. + +c temporarily set f1 and f2 for col=0. + f1 = f1 + dt*f2 + dibp2 - theta*dibp*zibp + f2 = f2 - theta*dibp2 + + if (col .gt. 0) then +c update c = c + dt*p. + call daxpy(col2,dt,p,1,c,1) + +c choose wbp, +c the row of W corresponding to the breakpoint encountered. + pointr = head + do 70 j = 1,col + wbp(j) = wy(ibp,pointr) + wbp(col + j) = theta*ws(ibp,pointr) + pointr = mod(pointr,m) + 1 + 70 continue + +c compute (wbp)Mc, (wbp)Mp, and (wbp)M(wbp)'. + call bmv(m,sy,wt,col,wbp,v,info) + if (info .ne. 0) return + wmc = ddot(col2,c,1,v,1) + wmp = ddot(col2,p,1,v,1) + wmw = ddot(col2,wbp,1,v,1) + +c update p = p - dibp*wbp. + call daxpy(col2,-dibp,wbp,1,p,1) + +c complete updating f1 and f2 while col > 0. + f1 = f1 + dibp*wmc + f2 = f2 + 2.0d0*dibp*wmp - dibp2*wmw + endif + + f2 = max(epsmch*f2_org,f2) + if (nleft .gt. 0) then + dtm = -f1/f2 + goto 777 +c to repeat the loop for unsearched intervals. + else if(bnded) then + f1 = zero + f2 = zero + dtm = zero + else + dtm = -f1/f2 + endif + +c------------------- the end of the loop ------------------------------- + + 888 continue + if (iprint .ge. 99) then + write (6,*) + write (6,*) 'GCP found in this segment' + write (6,4010) nint,f1,f2 + write (6,6010) dtm + endif + if (dtm .le. zero) dtm = zero + tsum = tsum + dtm + +c Move free variables (i.e., the ones w/o breakpoints) and +c the variables whose breakpoints haven't been reached. + + call daxpy(n,tsum,d,1,xcp,1) + + 999 continue + +c Update c = c + dtm*p = W'(x^c - x) +c which will be used in computing r = Z'(B(x^c - x) + g). + + if (col .gt. 0) call daxpy(col2,dtm,p,1,c,1) + if (iprint .gt. 100) write (6,1010) (xcp(i),i = 1,n) + if (iprint .ge. 99) write (6,2010) + + 1010 format ('Cauchy X = ',/,(4x,1p,6(1x,d11.4))) + 2010 format (/,'---------------- exit CAUCHY----------------------',/) + 3010 format (/,'---------------- CAUCHY entered-------------------') + 4010 format ('Piece ',i3,' --f1, f2 at start point ',1p,2(1x,d11.4)) + 4011 format (/,'Piece ',i3,' --f1, f2 at start point ', + + 1p,2(1x,d11.4)) + 5010 format ('Distance to the next break point = ',1p,d11.4) + 6010 format ('Distance to the stationary point = ',1p,d11.4) + + return + + end + +c====================== The end of cauchy ============================== + + subroutine cmprlb(n, m, x, g, ws, wy, sy, wt, z, r, wa, index, + + theta, col, head, nfree, cnstnd, info) + + logical cnstnd + integer n, m, col, head, nfree, info, index(n) + double precision theta, + + x(n), g(n), z(n), r(n), wa(4*m), + + ws(n, m), wy(n, m), sy(m, m), wt(m, m) + +c ************ +c +c Subroutine cmprlb +c +c This subroutine computes r=-Z'B(xcp-xk)-Z'g by using +c wa(2m+1)=W'(xcp-x) from subroutine cauchy. +c +c Subprograms called: +c +c L-BFGS-B Library ... bmv. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,j,k,pointr + double precision a1,a2 + + if (.not. cnstnd .and. col .gt. 0) then + do 26 i = 1, n + r(i) = -g(i) + 26 continue + else + do 30 i = 1, nfree + k = index(i) + r(i) = -theta*(z(k) - x(k)) - g(k) + 30 continue + call bmv(m,sy,wt,col,wa(2*m+1),wa(1),info) + if (info .ne. 0) then + info = -8 + return + endif + pointr = head + do 34 j = 1, col + a1 = wa(j) + a2 = theta*wa(col + j) + do 32 i = 1, nfree + k = index(i) + r(i) = r(i) + wy(k,pointr)*a1 + ws(k,pointr)*a2 + 32 continue + pointr = mod(pointr,m) + 1 + 34 continue + endif + + return + + end + +c======================= The end of cmprlb ============================= + + subroutine errclb(n, m, factr, l, u, nbd, task, info, k) + + character*60 task + integer n, m, info, k, nbd(n) + double precision factr, l(n), u(n) + +c ************ +c +c Subroutine errclb +c +c This subroutine checks the validity of the input data. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision April 1997.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + double precision zero + parameter (zero=0.0d0) + +c Check the input arguments for errors. + + if (n .le. 0) task = 'ERROR: N .LE. 0' + if (m .le. 0) task = 'ERROR: M .LE. 0' + if (factr .lt. zero) task = 'ERROR: FACTR .LT. 0' + +c Check the validity of the arrays nbd(i), u(i), and l(i). + + do 10 i = 1, n + if (nbd(i) .lt. 0 .or. nbd(i) .gt. 3) then +c return + task = 'ERROR: INVALID NBD' + info = -6 + k = i + endif + if (nbd(i) .eq. 2) then + if (l(i) .gt. u(i)) then +c return + task = 'ERROR: NO FEASIBLE SOLUTION' + info = -7 + k = i + endif + endif + 10 continue + + return + + end + +c======================= The end of errclb ============================= + + subroutine formk(n, nsub, ind, nenter, ileave, indx2, iupdat, + + updatd, wn, wn1, m, ws, wy, sy, theta, col, + + head, info) + + integer n, nsub, m, col, head, nenter, ileave, iupdat, + + info, ind(n), indx2(n) + double precision theta, wn(2*m, 2*m), wn1(2*m, 2*m), + + ws(n, m), wy(n, m), sy(m, m) + logical updatd + +c ************ +c +c Subroutine formk +c +c This subroutine forms the LEL^T factorization of the indefinite +c +c matrix K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] +c The matrix K can be shown to be equal to the matrix M^[-1]N +c occurring in section 5.1 of [1], as well as to the matrix +c Mbar^[-1] Nbar in section 5.3. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c nsub is an integer variable +c On entry nsub is the number of subspace variables in free set. +c On exit nsub is not changed. +c +c ind is an integer array of dimension nsub. +c On entry ind specifies the indices of subspace variables. +c On exit ind is unchanged. +c +c nenter is an integer variable. +c On entry nenter is the number of variables entering the +c free set. +c On exit nenter is unchanged. +c +c ileave is an integer variable. +c On entry indx2(ileave),...,indx2(n) are the variables leaving +c the free set. +c On exit ileave is unchanged. +c +c indx2 is an integer array of dimension n. +c On entry indx2(1),...,indx2(nenter) are the variables entering +c the free set, while indx2(ileave),...,indx2(n) are the +c variables leaving the free set. +c On exit indx2 is unchanged. +c +c iupdat is an integer variable. +c On entry iupdat is the total number of BFGS updates made so far. +c On exit iupdat is unchanged. +c +c updatd is a logical variable. +c On entry 'updatd' is true if the L-BFGS matrix is updatd. +c On exit 'updatd' is unchanged. +c +c wn is a double precision array of dimension 2m x 2m. +c On entry wn is unspecified. +c On exit the upper triangle of wn stores the LEL^T factorization +c of the 2*col x 2*col indefinite matrix +c [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c wn1 is a double precision array of dimension 2m x 2m. +c On entry wn1 stores the lower triangular part of +c [Y' ZZ'Y L_a'+R_z'] +c [L_a+R_z S'AA'S ] +c in the previous iteration. +c On exit wn1 stores the corresponding updated matrices. +c The purpose of wn1 is just to store these inner products +c so they can be easily updated and inserted into wn. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c ws, wy, sy, and wtyy are double precision arrays; +c theta is a double precision variable; +c col is an integer variable; +c head is an integer variable. +c On entry they store the information defining the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c sy(m,m) stores S'Y; +c wtyy(m,m) stores the Cholesky factorization +c of (theta*S'S+LD^(-1)L') +c theta is the scaling factor specifying B_0 = theta I; +c col is the number of variable metric corrections stored; +c head is the location of the 1st s- (or y-) vector in S (or Y). +c On exit they are unchanged. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return; +c = -1 when the 1st Cholesky factorization failed; +c = -2 when the 2st Cholesky factorization failed. +c +c Subprograms called: +c +c Linpack ... dcopy, dpofa, dtrsl. +c +c +c References: +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a +c limited memory FORTRAN code for solving bound constrained +c optimization problems'', Tech. Report, NAM-11, EECS Department, +c Northwestern University, 1994. +c +c (Postscript files of these papers are available via anonymous +c ftp to ece.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.) +c +c * * * +c +c NEOS, November 1994. (Latest revision April 1997.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer m2,ipntr,jpntr,iy,is,jy,js,is1,js1,k1,i,k, + + col2,pbegin,pend,dbegin,dend,upcl + double precision ddot,temp1,temp2,temp3,temp4 + double precision zero + parameter (zero=0.0d0) + +c Form the lower triangular part of +c WN1 = [Y' ZZ'Y L_a'+R_z'] +c [L_a+R_z S'AA'S ] +c where L_a is the strictly lower triangular part of S'AA'Y +c R_z is the upper triangular part of S'ZZ'Y. + + if (updatd) then + if (iupdat .gt. m) then +c shift old part of WN1. + do 10 jy = 1, m - 1 + js = m + jy + call dcopy(m-jy,wn1(jy+1,jy+1),1,wn1(jy,jy),1) + call dcopy(m-jy,wn1(js+1,js+1),1,wn1(js,js),1) + call dcopy(m-1,wn1(m+2,jy+1),1,wn1(m+1,jy),1) + 10 continue + endif + +c put new rows in blocks (1,1), (2,1) and (2,2). + pbegin = 1 + pend = nsub + dbegin = nsub + 1 + dend = n + iy = col + is = m + col + ipntr = head + col - 1 + if (ipntr .gt. m) ipntr = ipntr - m + jpntr = head + do 20 jy = 1, col + js = m + jy + temp1 = zero + temp2 = zero + temp3 = zero +c compute element jy of row 'col' of Y'ZZ'Y + do 15 k = pbegin, pend + k1 = ind(k) + temp1 = temp1 + wy(k1,ipntr)*wy(k1,jpntr) + 15 continue +c compute elements jy of row 'col' of L_a and S'AA'S + do 16 k = dbegin, dend + k1 = ind(k) + temp2 = temp2 + ws(k1,ipntr)*ws(k1,jpntr) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 16 continue + wn1(iy,jy) = temp1 + wn1(is,js) = temp2 + wn1(is,jy) = temp3 + jpntr = mod(jpntr,m) + 1 + 20 continue + +c put new column in block (2,1). + jy = col + jpntr = head + col - 1 + if (jpntr .gt. m) jpntr = jpntr - m + ipntr = head + do 30 i = 1, col + is = m + i + temp3 = zero +c compute element i of column 'col' of R_z + do 25 k = pbegin, pend + k1 = ind(k) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 25 continue + ipntr = mod(ipntr,m) + 1 + wn1(is,jy) = temp3 + 30 continue + upcl = col - 1 + else + upcl = col + endif + +c modify the old parts in blocks (1,1) and (2,2) due to changes +c in the set of free variables. + ipntr = head + do 45 iy = 1, upcl + is = m + iy + jpntr = head + do 40 jy = 1, iy + js = m + jy + temp1 = zero + temp2 = zero + temp3 = zero + temp4 = zero + do 35 k = 1, nenter + k1 = indx2(k) + temp1 = temp1 + wy(k1,ipntr)*wy(k1,jpntr) + temp2 = temp2 + ws(k1,ipntr)*ws(k1,jpntr) + 35 continue + do 36 k = ileave, n + k1 = indx2(k) + temp3 = temp3 + wy(k1,ipntr)*wy(k1,jpntr) + temp4 = temp4 + ws(k1,ipntr)*ws(k1,jpntr) + 36 continue + wn1(iy,jy) = wn1(iy,jy) + temp1 - temp3 + wn1(is,js) = wn1(is,js) - temp2 + temp4 + jpntr = mod(jpntr,m) + 1 + 40 continue + ipntr = mod(ipntr,m) + 1 + 45 continue + +c modify the old parts in block (2,1). + ipntr = head + do 60 is = m + 1, m + upcl + jpntr = head + do 55 jy = 1, upcl + temp1 = zero + temp3 = zero + do 50 k = 1, nenter + k1 = indx2(k) + temp1 = temp1 + ws(k1,ipntr)*wy(k1,jpntr) + 50 continue + do 51 k = ileave, n + k1 = indx2(k) + temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr) + 51 continue + if (is .le. jy + m) then + wn1(is,jy) = wn1(is,jy) + temp1 - temp3 + else + wn1(is,jy) = wn1(is,jy) - temp1 + temp3 + endif + jpntr = mod(jpntr,m) + 1 + 55 continue + ipntr = mod(ipntr,m) + 1 + 60 continue + +c Form the upper triangle of WN = [D+Y' ZZ'Y/theta -L_a'+R_z' ] +c [-L_a +R_z S'AA'S*theta] + + m2 = 2*m + do 70 iy = 1, col + is = col + iy + is1 = m + iy + do 65 jy = 1, iy + js = col + jy + js1 = m + jy + wn(jy,iy) = wn1(iy,jy)/theta + wn(js,is) = wn1(is1,js1)*theta + 65 continue + do 66 jy = 1, iy - 1 + wn(jy,is) = -wn1(is1,jy) + 66 continue + do 67 jy = iy, col + wn(jy,is) = wn1(is1,jy) + 67 continue + wn(iy,iy) = wn(iy,iy) + sy(iy,iy) + 70 continue + +c Form the upper triangle of +c WN= [ LL' L^-1(-L_a'+R_z')] +c [(-L_a +R_z)L'^-1 S'AA'S*theta ] + +c first Cholesky factor (1,1) block of wn to get LL' +c with L' stored in the upper triangle of wn. + call dpofa(wn,m2,col,info) + if (info .ne. 0) then + info = -1 + return + endif +c then form L^-1(-L_a'+R_z') in the (1,2) block. + col2 = 2*col + do 71 js = col+1 ,col2 + call dtrsl(wn,m2,col,wn(1,js),11,info) + 71 continue + +c Form S'AA'S*theta + (L^-1(-L_a'+R_z'))'L^-1(-L_a'+R_z') in the +c upper triangle of (2,2) block of wn. + + + do 72 is = col+1, col2 + do 74 js = is, col2 + wn(is,js) = wn(is,js) + ddot(col,wn(1,is),1,wn(1,js),1) + 74 continue + 72 continue + +c Cholesky factorization of (2,2) block of wn. + + call dpofa(wn(col+1,col+1),m2,col,info) + if (info .ne. 0) then + info = -2 + return + endif + + return + + end + +c======================= The end of formk ============================== + + subroutine formt(m, wt, sy, ss, col, theta, info) + + integer m, col, info + double precision theta, wt(m, m), sy(m, m), ss(m, m) + +c ************ +c +c Subroutine formt +c +c This subroutine forms the upper half of the pos. def. and symm. +c T = theta*SS + L*D^(-1)*L', stores T in the upper triangle +c of the array wt, and performs the Cholesky factorization of T +c to produce J*J', with J' stored in the upper triangle of wt. +c +c Subprograms called: +c +c Linpack ... dpofa. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,j,k,k1 + double precision ddum + double precision zero + parameter (zero=0.0d0) + + +c Form the upper half of T = theta*SS + L*D^(-1)*L', +c store T in the upper triangle of the array wt. + + do 52 j = 1, col + wt(1,j) = theta*ss(1,j) + 52 continue + do 55 i = 2, col + do 54 j = i, col + k1 = min(i,j) - 1 + ddum = zero + do 53 k = 1, k1 + ddum = ddum + sy(i,k)*sy(j,k)/sy(k,k) + 53 continue + wt(i,j) = ddum + theta*ss(i,j) + 54 continue + 55 continue + +c Cholesky factorize T to J*J' with +c J' stored in the upper triangle of wt. + + call dpofa(wt,m,col,info) + if (info .ne. 0) then + info = -3 + endif + + return + + end + +c======================= The end of formt ============================== + + subroutine freev(n, nfree, index, nenter, ileave, indx2, + + iwhere, wrk, updatd, cnstnd, iprint, iter) + + integer n, nfree, nenter, ileave, iprint, iter, + + index(n), indx2(n), iwhere(n) + logical wrk, updatd, cnstnd + +c ************ +c +c Subroutine freev +c +c This subroutine counts the entering and leaving variables when +c iter > 0, and finds the index set of free and active variables +c at the GCP. +c +c cnstnd is a logical variable indicating whether bounds are present +c +c index is an integer array of dimension n +c for i=1,...,nfree, index(i) are the indices of free variables +c for i=nfree+1,...,n, index(i) are the indices of bound variables +c On entry after the first iteration, index gives +c the free variables at the previous iteration. +c On exit it gives the free variables based on the determination +c in cauchy using the array iwhere. +c +c indx2 is an integer array of dimension n +c On entry indx2 is unspecified. +c On exit with iter>0, indx2 indicates which variables +c have changed status since the previous iteration. +c For i= 1,...,nenter, indx2(i) have changed from bound to free. +c For i= ileave+1,...,n, indx2(i) have changed from free to bound. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer iact,i,k + + nenter = 0 + ileave = n + 1 + if (iter .gt. 0 .and. cnstnd) then +c count the entering and leaving variables. + do 20 i = 1, nfree + k = index(i) + if (iwhere(k) .gt. 0) then + ileave = ileave - 1 + indx2(ileave) = k + if (iprint .ge. 100) write (6,*) + + 'Variable ',k,' leaves the set of free variables' + endif + 20 continue + do 22 i = 1 + nfree, n + k = index(i) + if (iwhere(k) .le. 0) then + nenter = nenter + 1 + indx2(nenter) = k + if (iprint .ge. 100) write (6,*) + + 'Variable ',k,' enters the set of free variables' + endif + 22 continue + if (iprint .ge. 99) write (6,*) + + n+1-ileave,' variables leave; ',nenter,' variables enter' + endif + wrk = (ileave .lt. n+1) .or. (nenter .gt. 0) .or. updatd + +c Find the index set of free and active variables at the GCP. + + nfree = 0 + iact = n + 1 + do 24 i = 1, n + if (iwhere(i) .le. 0) then + nfree = nfree + 1 + index(nfree) = i + else + iact = iact - 1 + index(iact) = i + endif + 24 continue + if (iprint .ge. 99) write (6,*) + + nfree,' variables are free at GCP ',iter + 1 + + return + + end + +c======================= The end of freev ============================== + + subroutine hpsolb(n, t, iorder, iheap) + integer iheap, n, iorder(n) + double precision t(n) + +c ************ +c +c Subroutine hpsolb +c +c This subroutine sorts out the least element of t, and puts the +c remaining elements of t in a heap. +c +c n is an integer variable. +c On entry n is the dimension of the arrays t and iorder. +c On exit n is unchanged. +c +c t is a double precision array of dimension n. +c On entry t stores the elements to be sorted, +c On exit t(n) stores the least elements of t, and t(1) to t(n-1) +c stores the remaining elements in the form of a heap. +c +c iorder is an integer array of dimension n. +c On entry iorder(i) is the index of t(i). +c On exit iorder(i) is still the index of t(i), but iorder may be +c permuted in accordance with t. +c +c iheap is an integer variable specifying the task. +c On entry iheap should be set as follows: +c iheap .eq. 0 if t(1) to t(n) is not in the form of a heap, +c iheap .ne. 0 if otherwise. +c On exit iheap is unchanged. +c +c +c References: +c Algorithm 232 of CACM (J. W. J. Williams): HEAPSORT. +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c ************ + + integer i,j,k,indxin,indxou + double precision ddum,out + + if (iheap .eq. 0) then + +c Rearrange the elements t(1) to t(n) to form a heap. + + do 20 k = 2, n + ddum = t(k) + indxin = iorder(k) + +c Add ddum to the heap. + i = k + 10 continue + if (i.gt.1) then + j = i/2 + if (ddum .lt. t(j)) then + t(i) = t(j) + iorder(i) = iorder(j) + i = j + goto 10 + endif + endif + t(i) = ddum + iorder(i) = indxin + 20 continue + endif + +c Assign to 'out' the value of t(1), the least member of the heap, +c and rearrange the remaining members to form a heap as +c elements 1 to n-1 of t. + + if (n .gt. 1) then + i = 1 + out = t(1) + indxou = iorder(1) + ddum = t(n) + indxin = iorder(n) + +c Restore the heap + 30 continue + j = i+i + if (j .le. n-1) then + if (t(j+1) .lt. t(j)) j = j+1 + if (t(j) .lt. ddum ) then + t(i) = t(j) + iorder(i) = iorder(j) + i = j + goto 30 + endif + endif + t(i) = ddum + iorder(i) = indxin + +c Put the least member in t(n). + + t(n) = out + iorder(n) = indxou + endif + + return + + end + +c====================== The end of hpsolb ============================== + + subroutine lnsrlb(n, l, u, nbd, x, f, fold, gd, gdold, g, d, r, t, + + z, stp, dnorm, dtd, xstep, stpmx, iter, ifun, + + iback, nfgv, info, task, boxed, cnstnd, csave, + + isave, dsave) + + character*60 task, csave + logical boxed, cnstnd + integer n, iter, ifun, iback, nfgv, info, + + nbd(n), isave(2) + double precision f, fold, gd, gdold, stp, dnorm, dtd, xstep, + + stpmx, x(n), l(n), u(n), g(n), d(n), r(n), t(n), + + z(n), dsave(13) +c ********** +c +c Subroutine lnsrlb +c +c This subroutine calls subroutine dcsrch from the Minpack2 library +c to perform the line search. Subroutine dscrch is safeguarded so +c that all trial points lie within the feasible region. +c +c Subprograms called: +c +c Minpack2 Library ... dcsrch. +c +c Linpack ... dtrsl, ddot. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ********** + + integer i + double precision ddot,a1,a2 + double precision one,zero,big + parameter (one=1.0d0,zero=0.0d0,big=1.0d+10) + double precision ftol,gtol,xtol + parameter (ftol=1.0d-3,gtol=0.9d0,xtol=0.1d0) + + if (task(1:5) .eq. 'FG_LN') goto 556 + + dtd = ddot(n,d,1,d,1) + dnorm = sqrt(dtd) + +c Determine the maximum step length. + + stpmx = big + if (cnstnd) then + if (iter .eq. 0) then + stpmx = one + else + do 43 i = 1, n + a1 = d(i) + if (nbd(i) .ne. 0) then + if (a1 .lt. zero .and. nbd(i) .le. 2) then + a2 = l(i) - x(i) + if (a2 .ge. zero) then + stpmx = zero + else if (a1*stpmx .lt. a2) then + stpmx = a2/a1 + endif + else if (a1 .gt. zero .and. nbd(i) .ge. 2) then + a2 = u(i) - x(i) + if (a2 .le. zero) then + stpmx = zero + else if (a1*stpmx .gt. a2) then + stpmx = a2/a1 + endif + endif + endif + 43 continue + endif + endif + + if (iter .eq. 0 .and. .not. boxed) then + stp = min(one/dnorm, stpmx) + else + stp = one + endif + + call dcopy(n,x,1,t,1) + call dcopy(n,g,1,r,1) + fold = f + ifun = 0 + iback = 0 + csave = 'START' + 556 continue + gd = ddot(n,g,1,d,1) + if (ifun .eq. 0) then + gdold=gd + if (gd .ge. zero) then +c the directional derivative >=0. +c Line search is impossible. + info = -4 + return + endif + endif + + call dcsrch(f,gd,stp,ftol,gtol,xtol,zero,stpmx,csave,isave,dsave) + + xstep = stp*dnorm + if (csave(1:4) .ne. 'CONV' .and. csave(1:4) .ne. 'WARN') then + task = 'FG_LNSRCH' + ifun = ifun + 1 + nfgv = nfgv + 1 + iback = ifun - 1 + if (stp .eq. one) then + call dcopy(n,z,1,x,1) + else + do 41 i = 1, n + x(i) = stp*d(i) + t(i) + 41 continue + endif + else + task = 'NEW_X' + endif + + return + + end + +c======================= The end of lnsrlb ============================= + + subroutine matupd(n, m, ws, wy, sy, ss, d, r, itail, + + iupdat, col, head, theta, rr, dr, stp, dtd) + + integer n, m, itail, iupdat, col, head + double precision theta, rr, dr, stp, dtd, d(n), r(n), + + ws(n, m), wy(n, m), sy(m, m), ss(m, m) + +c ************ +c +c Subroutine matupd +c +c This subroutine updates matrices WS and WY, and forms the +c middle matrix in B. +c +c Subprograms called: +c +c Linpack ... dcopy, ddot. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer j,pointr + double precision ddot + double precision one + parameter (one=1.0d0) + +c Set pointers for matrices WS and WY. + + if (iupdat .le. m) then + col = iupdat + itail = mod(head+iupdat-2,m) + 1 + else + itail = mod(itail,m) + 1 + head = mod(head,m) + 1 + endif + +c Update matrices WS and WY. + + call dcopy(n,d,1,ws(1,itail),1) + call dcopy(n,r,1,wy(1,itail),1) + +c Set theta=yy/ys. + + theta = rr/dr + +c Form the middle matrix in B. + +c update the upper triangle of SS, +c and the lower triangle of SY: + if (iupdat .gt. m) then +c move old information + do 50 j = 1, col - 1 + call dcopy(j,ss(2,j+1),1,ss(1,j),1) + call dcopy(col-j,sy(j+1,j+1),1,sy(j,j),1) + 50 continue + endif +c add new information: the last row of SY +c and the last column of SS: + pointr = head + do 51 j = 1, col - 1 + sy(col,j) = ddot(n,d,1,wy(1,pointr),1) + ss(j,col) = ddot(n,ws(1,pointr),1,d,1) + pointr = mod(pointr,m) + 1 + 51 continue + if (stp .eq. one) then + ss(col,col) = dtd + else + ss(col,col) = stp*stp*dtd + endif + sy(col,col) = dr + + return + + end + +c======================= The end of matupd ============================= + + subroutine prn1lb(n, m, l, u, x, iprint, itfile, epsmch) + + integer n, m, iprint, itfile + double precision epsmch, x(n), l(n), u(n) + +c ************ +c +c Subroutine prn1lb +c +c This subroutine prints the input data, initial point, upper and +c lower bounds of each variable, machine precision, as well as +c the headings of the output. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + + if (iprint .ge. 0) then + write (6,7001) epsmch + write (6,*) 'N = ',n,' M = ',m + if (iprint .ge. 1) then + write (itfile,2001) epsmch + write (itfile,*)'N = ',n,' M = ',m + write (itfile,9001) + if (iprint .gt. 100) then + write (6,1004) 'L =',(l(i),i = 1,n) + write (6,1004) 'X0 =',(x(i),i = 1,n) + write (6,1004) 'U =',(u(i),i = 1,n) + endif + endif + endif + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 2001 format ('RUNNING THE L-BFGS-B CODE',/,/, + + 'it = iteration number',/, + + 'nf = number of function evaluations',/, + + 'nint = number of segments explored during the Cauchy search',/, + + 'nact = number of active bounds at the generalized Cauchy point' + + ,/, + + 'sub = manner in which the subspace minimization terminated:' + + ,/,' con = converged, bnd = a bound was reached',/, + + 'itls = number of iterations performed in the line search',/, + + 'stepl = step length used',/, + + 'tstep = norm of the displacement (total step)',/, + + 'projg = norm of the projected gradient',/, + + 'f = function value',/,/, + + ' * * *',/,/, + + 'Machine precision =',1p,d10.3) + 7001 format ('RUNNING THE L-BFGS-B CODE',/,/, + + ' * * *',/,/, + + 'Machine precision =',1p,d10.3) + 9001 format (/,3x,'it',3x,'nf',2x,'nint',2x,'nact',2x,'sub',2x,'itls', + + 2x,'stepl',4x,'tstep',5x,'projg',8x,'f') + + return + + end + +c======================= The end of prn1lb ============================= + + subroutine prn2lb(n, x, f, g, iprint, itfile, iter, nfgv, nact, + + sbgnrm, nint, word, iword, iback, stp, xstep) + + character*3 word + integer n, iprint, itfile, iter, nfgv, nact, nint, + + iword, iback + double precision f, sbgnrm, stp, xstep, x(n), g(n) + +c ************ +c +c Subroutine prn2lb +c +c This subroutine prints out new information after a successful +c line search. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i,imod + +c 'word' records the status of subspace solutions. + if (iword .eq. 0) then +c the subspace minimization converged. + word = 'con' + else if (iword .eq. 1) then +c the subspace minimization stopped at a bound. + word = 'bnd' + else if (iword .eq. 5) then +c the truncated Newton step has been used. + word = 'TNT' + else + word = '---' + endif + if (iprint .ge. 99) then + write (6,*) 'LINE SEARCH',iback,' times; norm of step = ',xstep + write (6,2001) iter,f,sbgnrm + if (iprint .gt. 100) then + write (6,1004) 'X =',(x(i), i = 1, n) + write (6,1004) 'G =',(g(i), i = 1, n) + endif + else if (iprint .gt. 0) then + imod = mod(iter,iprint) + if (imod .eq. 0) write (6,2001) iter,f,sbgnrm + endif + if (iprint .ge. 1) write (itfile,3001) + + iter,nfgv,nint,nact,word,iback,stp,xstep,sbgnrm,f + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 2001 format + + (/,'At iterate',i5,4x,'f= ',1p,d12.5,4x,'|proj g|= ',1p,d12.5) + 3001 format(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d7.1),1p,2(1x,d10.3)) + + return + + end + +c======================= The end of prn2lb ============================= + + subroutine prn3lb(n, x, f, task, iprint, info, itfile, + + iter, nfgv, nintol, nskip, nact, sbgnrm, + + time, nint, word, iback, stp, xstep, k, + + cachyt, sbtime, lnscht) + + character*60 task + character*3 word + integer n, iprint, info, itfile, iter, nfgv, nintol, + + nskip, nact, nint, iback, k + double precision f, sbgnrm, time, stp, xstep, cachyt, sbtime, + + lnscht, x(n) + +c ************ +c +c Subroutine prn3lb +c +c This subroutine prints out information when either a built-in +c convergence test is satisfied or when an error message is +c generated. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision April 1997.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + + if (task(1:5) .eq. 'ERROR') goto 999 + + if (iprint .ge. 0) then + write (6,3003) + write (6,3004) + write(6,3005) n,iter,nfgv,nintol,nskip,nact,sbgnrm,f + if (iprint .ge. 100) then + write (6,1004) 'X =',(x(i),i = 1,n) + endif + if (iprint .ge. 1) write (6,*) ' F =',f + endif + 999 continue + if (iprint .ge. 0) then + write (6,3009) task + if (info .ne. 0) then + if (info .eq. -1) write (6,9011) + if (info .eq. -2) write (6,9012) + if (info .eq. -3) write (6,9013) + if (info .eq. -4) write (6,9014) + if (info .eq. -5) write (6,9015) + if (info .eq. -6) write (6,*)' Input nbd(',k,') is invalid.' + if (info .eq. -7) + + write (6,*)' l(',k,') > u(',k,'). No feasible solution.' + if (info .eq. -8) write (6,9018) + if (info .eq. -9) write (6,9019) + endif + if (iprint .ge. 1) write (6,3007) cachyt,sbtime,lnscht + write (6,3008) time + if (iprint .ge. 1) then + if (info .eq. -4 .or. info .eq. -9) then + write (itfile,3002) + + iter,nfgv,nint,nact,word,iback,stp,xstep + endif + write (itfile,3009) task + if (info .ne. 0) then + if (info .eq. -1) write (itfile,9011) + if (info .eq. -2) write (itfile,9012) + if (info .eq. -3) write (itfile,9013) + if (info .eq. -4) write (itfile,9014) + if (info .eq. -5) write (itfile,9015) + if (info .eq. -8) write (itfile,9018) + if (info .eq. -9) write (itfile,9019) + endif + write (itfile,3008) time + endif + endif + + 1004 format (/,a4, 1p, 6(1x,d11.4),/,(4x,1p,6(1x,d11.4))) + 3002 format(2(1x,i4),2(1x,i5),2x,a3,1x,i4,1p,2(2x,d7.1),6x,'-',10x,'-') + 3003 format (/, + + ' * * *',/,/, + + 'Tit = total number of iterations',/, + + 'Tnf = total number of function evaluations',/, + + 'Tnint = total number of segments explored during', + + ' Cauchy searches',/, + + 'Skip = number of BFGS updates skipped',/, + + 'Nact = number of active bounds at final generalized', + + ' Cauchy point',/, + + 'Projg = norm of the final projected gradient',/, + + 'F = final function value',/,/, + + ' * * *') + 3004 format (/,3x,'N',3x,'Tit',2x,'Tnf',2x,'Tnint',2x, + + 'Skip',2x,'Nact',5x,'Projg',8x,'F') + 3005 format (i5,2(1x,i4),(1x,i6),(2x,i4),(1x,i5),1p,2(2x,d10.3)) + 3007 format (/,' Cauchy time',1p,e10.3,' seconds.',/ + + ' Subspace minimization time',1p,e10.3,' seconds.',/ + + ' Line search time',1p,e10.3,' seconds.') + 3008 format (/,' Total User time',1p,e10.3,' seconds.',/) + 3009 format (/,a60) + 9011 format (/, + +' Matrix in 1st Cholesky factorization in formk is not Pos. Def.') + 9012 format (/, + +' Matrix in 2st Cholesky factorization in formk is not Pos. Def.') + 9013 format (/, + +' Matrix in the Cholesky factorization in formt is not Pos. Def.') + 9014 format (/, + +' Derivative >= 0, backtracking line search impossible.',/, + +' Previous x, f and g restored.',/, + +' Possible causes: 1 error in function or gradient evaluation;',/, + +' 2 rounding errors dominate computation.') + 9015 format (/, + +' Warning: more than 10 function and gradient',/, + +' evaluations in the last line search. Termination',/, + +' may possibly be caused by a bad search direction.') + 9018 format (/,' The triangular system is singular.') + 9019 format (/, + +' Line search cannot locate an adequate point after 20 function',/ + +,' and gradient evaluations. Previous x, f and g restored.',/, + +' Possible causes: 1 error in function or gradient evaluation;',/, + +' 2 rounding error dominate computation.') + + return + + end + +c======================= The end of prn3lb ============================= + + subroutine projgr(n, l, u, nbd, x, g, sbgnrm) + + integer n, nbd(n) + double precision sbgnrm, x(n), l(n), u(n), g(n) + +c ************ +c +c Subroutine projgr +c +c This subroutine computes the infinity norm of the projected +c gradient. +c +c +c * * * +c +c NEOS, November 1994. (Latest revision April 1997.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + integer i + double precision gi + double precision zero + parameter (zero=0.0d0) + + sbgnrm = zero + do 15 i = 1, n + gi = g(i) + if (nbd(i) .ne. 0) then + if (gi .lt. zero) then + if (nbd(i) .ge. 2) gi = max((x(i)-u(i)),gi) + else + if (nbd(i) .le. 2) gi = min((x(i)-l(i)),gi) + endif + endif + sbgnrm = max(sbgnrm,abs(gi)) + 15 continue + + return + + end + +c======================= The end of projgr ============================= + + subroutine subsm(n, m, nsub, ind, l, u, nbd, x, d, ws, wy, theta, + + col, head, iword, wv, wn, iprint, info) + + integer n, m, nsub, col, head, iword, iprint, info, + + ind(nsub), nbd(n) + double precision theta, + + l(n), u(n), x(n), d(n), + + ws(n, m), wy(n, m), + + wv(2*m), wn(2*m, 2*m) + +c ************ +c +c Subroutine subsm +c +c Given xcp, l, u, r, an index set that specifies +c the active set at xcp, and an l-BFGS matrix B +c (in terms of WY, WS, SY, WT, head, col, and theta), +c this subroutine computes an approximate solution +c of the subspace problem +c +c (P) min Q(x) = r'(x-xcp) + 1/2 (x-xcp)' B (x-xcp) +c +c subject to l<=x<=u +c x_i=xcp_i for all i in A(xcp) +c +c along the subspace unconstrained Newton direction +c +c d = -(Z'BZ)^(-1) r. +c +c The formula for the Newton direction, given the L-BFGS matrix +c and the Sherman-Morrison formula, is +c +c d = (1/theta)r + (1/theta*2) Z'WK^(-1)W'Z r. +c +c where +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c +c Note that this procedure for computing d differs +c from that described in [1]. One can show that the matrix K is +c equal to the matrix M^[-1]N in that paper. +c +c n is an integer variable. +c On entry n is the dimension of the problem. +c On exit n is unchanged. +c +c m is an integer variable. +c On entry m is the maximum number of variable metric corrections +c used to define the limited memory matrix. +c On exit m is unchanged. +c +c nsub is an integer variable. +c On entry nsub is the number of free variables. +c On exit nsub is unchanged. +c +c ind is an integer array of dimension nsub. +c On entry ind specifies the coordinate indices of free variables. +c On exit ind is unchanged. +c +c l is a double precision array of dimension n. +c On entry l is the lower bound of x. +c On exit l is unchanged. +c +c u is a double precision array of dimension n. +c On entry u is the upper bound of x. +c On exit u is unchanged. +c +c nbd is a integer array of dimension n. +c On entry nbd represents the type of bounds imposed on the +c variables, and must be specified as follows: +c nbd(i)=0 if x(i) is unbounded, +c 1 if x(i) has only a lower bound, +c 2 if x(i) has both lower and upper bounds, and +c 3 if x(i) has only an upper bound. +c On exit nbd is unchanged. +c +c x is a double precision array of dimension n. +c On entry x specifies the Cauchy point xcp. +c On exit x(i) is the minimizer of Q over the subspace of +c free variables. +c +c d is a double precision array of dimension n. +c On entry d is the reduced gradient of Q at xcp. +c On exit d is the Newton direction of Q. +c +c ws and wy are double precision arrays; +c theta is a double precision variable; +c col is an integer variable; +c head is an integer variable. +c On entry they store the information defining the +c limited memory BFGS matrix: +c ws(n,m) stores S, a set of s-vectors; +c wy(n,m) stores Y, a set of y-vectors; +c theta is the scaling factor specifying B_0 = theta I; +c col is the number of variable metric corrections stored; +c head is the location of the 1st s- (or y-) vector in S (or Y). +c On exit they are unchanged. +c +c iword is an integer variable. +c On entry iword is unspecified. +c On exit iword specifies the status of the subspace solution. +c iword = 0 if the solution is in the box, +c 1 if some bound is encountered. +c +c wv is a double precision working array of dimension 2m. +c +c wn is a double precision array of dimension 2m x 2m. +c On entry the upper triangle of wn stores the LEL^T factorization +c of the indefinite matrix +c +c K = [-D -Y'ZZ'Y/theta L_a'-R_z' ] +c [L_a -R_z theta*S'AA'S ] +c where E = [-I 0] +c [ 0 I] +c On exit wn is unchanged. +c +c iprint is an INTEGER variable that must be set by the user. +c It controls the frequency and type of output generated: +c iprint<0 no output is generated; +c iprint=0 print only one line at the last iteration; +c 0100 print details of every iteration including x and g; +c When iprint > 0, the file iterate.dat will be created to +c summarize the iteration. +c +c info is an integer variable. +c On entry info is unspecified. +c On exit info = 0 for normal return, +c = nonzero for abnormal return +c when the matrix K is ill-conditioned. +c +c Subprograms called: +c +c Linpack dtrsl. +c +c +c References: +c +c [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited +c memory algorithm for bound constrained optimization'', +c SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208. +c +c +c +c * * * +c +c NEOS, November 1994. (Latest revision June 1996.) +c Optimization Technology Center. +c Argonne National Laboratory and Northwestern University. +c Written by +c Ciyou Zhu +c in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal. +c +c +c ************ + + logical temp1_updated + integer pointr,m2,col2,ibd,jy,js,i,j,k + double precision alpha,dk,temp1,temp2 + double precision one,zero + parameter (one=1.0d0,zero=0.0d0) + + if (nsub .le. 0) return + if (iprint .ge. 99) write (6,1001) + +c Compute wv = W'Zd. + + pointr = head + do 20 i = 1, col + temp1 = zero + temp2 = zero + do 10 j = 1, nsub + k = ind(j) + temp1 = temp1 + wy(k,pointr)*d(j) + temp2 = temp2 + ws(k,pointr)*d(j) + 10 continue + wv(i) = temp1 + wv(col + i) = theta*temp2 + pointr = mod(pointr,m) + 1 + 20 continue + +c Compute wv:=K^(-1)wv. + + m2 = 2*m + col2 = 2*col + call dtrsl(wn,m2,col2,wv,11,info) + if (info .ne. 0) return + do 25 i = 1, col + wv(i) = -wv(i) + 25 continue + call dtrsl(wn,m2,col2,wv,01,info) + if (info .ne. 0) return + +c Compute d = (1/theta)d + (1/theta**2)Z'W wv. + + pointr = head + do 40 jy = 1, col + js = col + jy + do 30 i = 1, nsub + k = ind(i) + d(i) = d(i) + wy(k,pointr)*wv(jy)/theta + + + ws(k,pointr)*wv(js) + 30 continue + pointr = mod(pointr,m) + 1 + 40 continue + do 50 i = 1, nsub + d(i) = d(i)/theta + 50 continue + +c Backtrack to the feasible region. + + alpha = one + temp1 = alpha + do 60 i = 1, nsub + k = ind(i) + dk = d(i) + if (nbd(k) .ne. 0) then + temp1_updated = .false. + if (dk .lt. zero .and. nbd(k) .le. 2) then + temp2 = l(k) - x(k) + if (temp2 .ge. zero) then + temp1 = zero + temp1_updated = .true. + else if (dk*alpha .lt. temp2) then + temp1 = temp2/dk + temp1_updated = .true. + endif + else if (dk .gt. zero .and. nbd(k) .ge. 2) then + temp2 = u(k) - x(k) + if (temp2 .le. zero) then + temp1 = zero + temp1_updated = .true. + else if (dk*alpha .gt. temp2) then + temp1 = temp2/dk + temp1_updated = .true. + endif + endif +cc logical variable temp1_updated added to eliminate unexpected +cc trigger of the if statement due to possible difference between +cc hardware precision and double precision. + if (temp1_updated .and. temp1 .lt. alpha) then + alpha = temp1 + ibd = i + endif + endif + 60 continue + + if (alpha .lt. one) then + dk = d(ibd) + k = ind(ibd) + if (dk .gt. zero) then + x(k) = u(k) + d(ibd) = zero + else if (dk .lt. zero) then + x(k) = l(k) + d(ibd) = zero + endif + endif + do 70 i = 1, nsub + k = ind(i) + x(k) = x(k) + alpha*d(i) + 70 continue + + if (iprint .ge. 99) then + if (alpha .lt. one) then + write (6,1002) alpha + else + write (6,*) 'SM solution inside the box' + end if + if (iprint .gt.100) write (6,1003) (x(i),i=1,n) + endif + + if (alpha .lt. one) then + iword = 1 + else + iword = 0 + endif + if (iprint .ge. 99) write (6,1004) + + 1001 format (/,'----------------SUBSM entered-----------------',/) + 1002 format ( 'ALPHA = ',f7.5,' backtrack to the BOX') + 1003 format ('Subspace solution X = ',/,(4x,1p,6(1x,d11.4))) + 1004 format (/,'----------------exit SUBSM --------------------',/) + + return + + end + +c====================== The end of subsm =============================== + + subroutine dcsrch(f,g,stp,ftol,gtol,xtol,stpmin,stpmax, + + task,isave,dsave) + character*(*) task + integer isave(2) + double precision f,g,stp,ftol,gtol,xtol,stpmin,stpmax + double precision dsave(13) +c ********** +c +c Subroutine dcsrch +c +c This subroutine finds a step that satisfies a sufficient +c decrease condition and a curvature condition. +c +c Each call of the subroutine updates an interval with +c endpoints stx and sty. The interval is initially chosen +c so that it contains a minimizer of the modified function +c +c psi(stp) = f(stp) - f(0) - ftol*stp*f'(0). +c +c If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the +c interval is chosen so that it contains a minimizer of f. +c +c The algorithm is designed to find a step that satisfies +c the sufficient decrease condition +c +c f(stp) <= f(0) + ftol*stp*f'(0), +c +c and the curvature condition +c +c abs(f'(stp)) <= gtol*abs(f'(0)). +c +c If ftol is less than gtol and if, for example, the function +c is bounded below, then there is always a step which satisfies +c both conditions. +c +c If no step can be found that satisfies both conditions, then +c the algorithm stops with a warning. In this case stp only +c satisfies the sufficient decrease condition. +c +c A typical invocation of dcsrch has the following outline: +c +c task = 'START' +c 10 continue +c call dcsrch( ... ) +c if (task .eq. 'FG') then +c Evaluate the function and the gradient at stp +c goto 10 +c end if +c +c NOTE: The user must no alter work arrays between calls. +c +c The subroutine statement is +c +c subroutine dcsrch(f,g,stp,ftol,gtol,xtol,stpmin,stpmax, +c task,isave,dsave) +c where +c +c f is a double precision variable. +c On initial entry f is the value of the function at 0. +c On subsequent entries f is the value of the +c function at stp. +c On exit f is the value of the function at stp. +c +c g is a double precision variable. +c On initial entry g is the derivative of the function at 0. +c On subsequent entries g is the derivative of the +c function at stp. +c On exit g is the derivative of the function at stp. +c +c stp is a double precision variable. +c On entry stp is the current estimate of a satisfactory +c step. On initial entry, a positive initial estimate +c must be provided. +c On exit stp is the current estimate of a satisfactory step +c if task = 'FG'. If task = 'CONV' then stp satisfies +c the sufficient decrease and curvature condition. +c +c ftol is a double precision variable. +c On entry ftol specifies a nonnegative tolerance for the +c sufficient decrease condition. +c On exit ftol is unchanged. +c +c gtol is a double precision variable. +c On entry gtol specifies a nonnegative tolerance for the +c curvature condition. +c On exit gtol is unchanged. +c +c xtol is a double precision variable. +c On entry xtol specifies a nonnegative relative tolerance +c for an acceptable step. The subroutine exits with a +c warning if the relative difference between sty and stx +c is less than xtol. +c On exit xtol is unchanged. +c +c stpmin is a double precision variable. +c On entry stpmin is a nonnegative lower bound for the step. +c On exit stpmin is unchanged. +c +c stpmax is a double precision variable. +c On entry stpmax is a nonnegative upper bound for the step. +c On exit stpmax is unchanged. +c +c task is a character variable of length at least 60. +c On initial entry task must be set to 'START'. +c On exit task indicates the required action: +c +c If task(1:2) = 'FG' then evaluate the function and +c derivative at stp and call dcsrch again. +c +c If task(1:4) = 'CONV' then the search is successful. +c +c If task(1:4) = 'WARN' then the subroutine is not able +c to satisfy the convergence conditions. The exit value of +c stp contains the best point found during the search. +c +c If task(1:5) = 'ERROR' then there is an error in the +c input arguments. +c +c On exit with convergence, a warning or an error, the +c variable task contains additional information. +c +c isave is an integer work array of dimension 2. +c +c dsave is a double precision work array of dimension 13. +c +c Subprograms called +c +c MINPACK-2 ... dcstep +c +c MINPACK-1 Project. June 1983. +c Argonne National Laboratory. +c Jorge J. More' and David J. Thuente. +c +c MINPACK-2 Project. October 1993. +c Argonne National Laboratory and University of Minnesota. +c Brett M. Averick, Richard G. Carter, and Jorge J. More'. +c +c ********** + double precision zero,p5,p66 + parameter(zero=0.0d0,p5=0.5d0,p66=0.66d0) + double precision xtrapl,xtrapu + parameter(xtrapl=1.1d0,xtrapu=4.0d0) + + logical brackt + integer stage + double precision finit,ftest,fm,fx,fxm,fy,fym,ginit,gtest, + + gm,gx,gxm,gy,gym,stx,sty,stmin,stmax,width,width1 + +c Initialization block. + + if (task(1:5) .eq. 'START') then + +c Check the input arguments for errors. + + if (stp .lt. stpmin) task = 'ERROR: STP .LT. STPMIN' + if (stp .gt. stpmax) task = 'ERROR: STP .GT. STPMAX' + if (g .ge. zero) task = 'ERROR: INITIAL G .GE. ZERO' + if (ftol .lt. zero) task = 'ERROR: FTOL .LT. ZERO' + if (gtol .lt. zero) task = 'ERROR: GTOL .LT. ZERO' + if (xtol .lt. zero) task = 'ERROR: XTOL .LT. ZERO' + if (stpmin .lt. zero) task = 'ERROR: STPMIN .LT. ZERO' + if (stpmax .lt. stpmin) task = 'ERROR: STPMAX .LT. STPMIN' + +c Exit if there are errors on input. + + if (task(1:5) .eq. 'ERROR') return + +c Initialize local variables. + + brackt = .false. + stage = 1 + finit = f + ginit = g + gtest = ftol*ginit + width = stpmax - stpmin + width1 = width/p5 + +c The variables stx, fx, gx contain the values of the step, +c function, and derivative at the best step. +c The variables sty, fy, gy contain the value of the step, +c function, and derivative at sty. +c The variables stp, f, g contain the values of the step, +c function, and derivative at stp. + + stx = zero + fx = finit + gx = ginit + sty = zero + fy = finit + gy = ginit + stmin = zero + stmax = stp + xtrapu*stp + task = 'FG' + + goto 1000 + + else + +c Restore local variables. + + if (isave(1) .eq. 1) then + brackt = .true. + else + brackt = .false. + endif + stage = isave(2) + ginit = dsave(1) + gtest = dsave(2) + gx = dsave(3) + gy = dsave(4) + finit = dsave(5) + fx = dsave(6) + fy = dsave(7) + stx = dsave(8) + sty = dsave(9) + stmin = dsave(10) + stmax = dsave(11) + width = dsave(12) + width1 = dsave(13) + + endif + +c If psi(stp) <= 0 and f'(stp) >= 0 for some step, then the +c algorithm enters the second stage. + + ftest = finit + stp*gtest + if (stage .eq. 1 .and. f .le. ftest .and. g .ge. zero) + + stage = 2 + +c Test for warnings. + + if (brackt .and. (stp .le. stmin .or. stp .ge. stmax)) + + task = 'WARNING: ROUNDING ERRORS PREVENT PROGRESS' + if (brackt .and. stmax - stmin .le. xtol*stmax) + + task = 'WARNING: XTOL TEST SATISFIED' + if (stp .eq. stpmax .and. f .le. ftest .and. g .le. gtest) + + task = 'WARNING: STP = STPMAX' + if (stp .eq. stpmin .and. (f .gt. ftest .or. g .ge. gtest)) + + task = 'WARNING: STP = STPMIN' +cc New warning statement added to eliminate the unexpected case +cc of stp=stx due to possible difference between hardware precision +cc and double precision. + if (stp .eq. stx) + + task = 'WARNING: STP = STX' + +c Test for convergence. + + if (f .le. ftest .and. abs(g) .le. gtol*(-ginit)) + + task = 'CONVERGENCE' + +c Test for termination. + + if (task(1:4) .eq. 'WARN' .or. task(1:4) .eq. 'CONV') goto 1000 + +c A modified function is used to predict the step during the +c first stage if a lower function value has been obtained but +c the decrease is not sufficient. + + if (stage .eq. 1 .and. f .le. fx .and. f .gt. ftest) then + +c Define the modified function and derivative values. + + fm = f - stp*gtest + fxm = fx - stx*gtest + fym = fy - sty*gtest + gm = g - gtest + gxm = gx - gtest + gym = gy - gtest + +c Call dcstep to update stx, sty, and to compute the new step. + + call dcstep(stx,fxm,gxm,sty,fym,gym,stp,fm,gm, + + brackt,stmin,stmax) + +c Reset the function and derivative values for f. + + fx = fxm + stx*gtest + fy = fym + sty*gtest + gx = gxm + gtest + gy = gym + gtest + + else + +c Call dcstep to update stx, sty, and to compute the new step. + + call dcstep(stx,fx,gx,sty,fy,gy,stp,f,g, + + brackt,stmin,stmax) + + endif + +c Decide if a bisection step is needed. + + if (brackt) then + if (abs(sty-stx) .ge. p66*width1) stp = stx + p5*(sty - stx) + width1 = width + width = abs(sty-stx) + endif + +c Set the minimum and maximum steps allowed for stp. + + if (brackt) then + stmin = min(stx,sty) + stmax = max(stx,sty) + else + stmin = stp + xtrapl*(stp - stx) + stmax = stp + xtrapu*(stp - stx) + endif + +c Force the step to be within the bounds stpmax and stpmin. + + stp = max(stp,stpmin) + stp = min(stp,stpmax) + +c If further progress is not possible, let stp be the best +c point obtained during the search. + + if (brackt .and. (stp .le. stmin .or. stp .ge. stmax) + + .or. (brackt .and. stmax-stmin .le. xtol*stmax)) stp = stx + +c Obtain another function and derivative. + + task = 'FG' + + 1000 continue + +c Save local variables. + + if (brackt) then + isave(1) = 1 + else + isave(1) = 0 + endif + isave(2) = stage + dsave(1) = ginit + dsave(2) = gtest + dsave(3) = gx + dsave(4) = gy + dsave(5) = finit + dsave(6) = fx + dsave(7) = fy + dsave(8) = stx + dsave(9) = sty + dsave(10) = stmin + dsave(11) = stmax + dsave(12) = width + dsave(13) = width1 + + end + +c====================== The end of dcsrch ============================== + + subroutine dcstep(stx,fx,dx,sty,fy,dy,stp,fp,dp,brackt, + + stpmin,stpmax) + logical brackt + double precision stx,fx,dx,sty,fy,dy,stp,fp,dp,stpmin,stpmax +c ********** +c +c Subroutine dcstep +c +c This subroutine computes a safeguarded step for a search +c procedure and updates an interval that contains a step that +c satisfies a sufficient decrease and a curvature condition. +c +c The parameter stx contains the step with the least function +c value. If brackt is set to .true. then a minimizer has +c been bracketed in an interval with endpoints stx and sty. +c The parameter stp contains the current step. +c The subroutine assumes that if brackt is set to .true. then +c +c min(stx,sty) < stp < max(stx,sty), +c +c and that the derivative at stx is negative in the direction +c of the step. +c +c The subroutine statement is +c +c subroutine dcstep(stx,fx,dx,sty,fy,dy,stp,fp,dp,brackt, +c stpmin,stpmax) +c +c where +c +c stx is a double precision variable. +c On entry stx is the best step obtained so far and is an +c endpoint of the interval that contains the minimizer. +c On exit stx is the updated best step. +c +c fx is a double precision variable. +c On entry fx is the function at stx. +c On exit fx is the function at stx. +c +c dx is a double precision variable. +c On entry dx is the derivative of the function at +c stx. The derivative must be negative in the direction of +c the step, that is, dx and stp - stx must have opposite +c signs. +c On exit dx is the derivative of the function at stx. +c +c sty is a double precision variable. +c On entry sty is the second endpoint of the interval that +c contains the minimizer. +c On exit sty is the updated endpoint of the interval that +c contains the minimizer. +c +c fy is a double precision variable. +c On entry fy is the function at sty. +c On exit fy is the function at sty. +c +c dy is a double precision variable. +c On entry dy is the derivative of the function at sty. +c On exit dy is the derivative of the function at the exit sty. +c +c stp is a double precision variable. +c On entry stp is the current step. If brackt is set to .true. +c then on input stp must be between stx and sty. +c On exit stp is a new trial step. +c +c fp is a double precision variable. +c On entry fp is the function at stp +c On exit fp is unchanged. +c +c dp is a double precision variable. +c On entry dp is the the derivative of the function at stp. +c On exit dp is unchanged. +c +c brackt is an logical variable. +c On entry brackt specifies if a minimizer has been bracketed. +c Initially brackt must be set to .false. +c On exit brackt specifies if a minimizer has been bracketed. +c When a minimizer is bracketed brackt is set to .true. +c +c stpmin is a double precision variable. +c On entry stpmin is a lower bound for the step. +c On exit stpmin is unchanged. +c +c stpmax is a double precision variable. +c On entry stpmax is an upper bound for the step. +c On exit stpmax is unchanged. +c +c MINPACK-1 Project. June 1983 +c Argonne National Laboratory. +c Jorge J. More' and David J. Thuente. +c +c MINPACK-2 Project. October 1993. +c Argonne National Laboratory and University of Minnesota. +c Brett M. Averick and Jorge J. More'. +c +c ********** + double precision zero,p66,two,three + parameter(zero=0.0d0,p66=0.66d0,two=2.0d0,three=3.0d0) + + double precision gamma,p,q,r,s,sgnd,stpc,stpf,stpq,theta + + sgnd = dp*(dx/abs(dx)) + +c First case: A higher function value. The minimum is bracketed. +c If the cubic step is closer to stx than the quadratic step, the +c cubic step is taken, otherwise the average of the cubic and +c quadratic steps is taken. + + if (fp .gt. fx) then + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dx/s)*(dp/s)) + if (stp .lt. stx) gamma = -gamma + p = (gamma - dx) + theta + q = ((gamma - dx) + gamma) + dp + r = p/q + stpc = stx + r*(stp - stx) + stpq = stx + ((dx/((fx - fp)/(stp - stx) + dx))/two)* + + (stp - stx) + if (abs(stpc-stx) .lt. abs(stpq-stx)) then + stpf = stpc + else + stpf = stpc + (stpq - stpc)/two + endif + brackt = .true. + +c Second case: A lower function value and derivatives of opposite +c sign. The minimum is bracketed. If the cubic step is farther from +c stp than the secant step, the cubic step is taken, otherwise the +c secant step is taken. + + else if (sgnd .lt. zero) then + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dx/s)*(dp/s)) + if (stp .gt. stx) gamma = -gamma + p = (gamma - dp) + theta + q = ((gamma - dp) + gamma) + dx + r = p/q + stpc = stp + r*(stx - stp) + stpq = stp + (dp/(dp - dx))*(stx - stp) + if (abs(stpc-stp) .gt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + brackt = .true. + +c Third case: A lower function value, derivatives of the same sign, +c and the magnitude of the derivative decreases. + + else if (abs(dp) .lt. abs(dx)) then + +c The cubic step is computed only if the cubic tends to infinity +c in the direction of the step or if the minimum of the cubic +c is beyond stp. Otherwise the cubic step is defined to be the +c secant step. + + theta = three*(fx - fp)/(stp - stx) + dx + dp + s = max(abs(theta),abs(dx),abs(dp)) + +c The case gamma = 0 only arises if the cubic does not tend +c to infinity in the direction of the step. + + gamma = s*sqrt(max(zero,(theta/s)**2-(dx/s)*(dp/s))) + if (stp .gt. stx) gamma = -gamma + p = (gamma - dp) + theta + q = (gamma + (dx - dp)) + gamma + r = p/q + if (r .lt. zero .and. gamma .ne. zero) then + stpc = stp + r*(stx - stp) + else if (stp .gt. stx) then + stpc = stpmax + else + stpc = stpmin + endif + stpq = stp + (dp/(dp - dx))*(stx - stp) + + if (brackt) then + +c A minimizer has been bracketed. If the cubic step is +c closer to stp than the secant step, the cubic step is +c taken, otherwise the secant step is taken. + + if (abs(stpc-stp) .lt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + if (stp .gt. stx) then + stpf = min(stp+p66*(sty-stp),stpf) + else + stpf = max(stp+p66*(sty-stp),stpf) + endif + else + +c A minimizer has not been bracketed. If the cubic step is +c farther from stp than the secant step, the cubic step is +c taken, otherwise the secant step is taken. + + if (abs(stpc-stp) .gt. abs(stpq-stp)) then + stpf = stpc + else + stpf = stpq + endif + stpf = min(stpmax,stpf) + stpf = max(stpmin,stpf) + endif + +c Fourth case: A lower function value, derivatives of the +c same sign, and the magnitude of the derivative does not +c decrease. If the minimum is not bracketed, the step is either +c stpmin or stpmax, otherwise the cubic step is taken. + + else + if (brackt) then + theta = three*(fp - fy)/(sty - stp) + dy + dp + s = max(abs(theta),abs(dy),abs(dp)) + gamma = s*sqrt((theta/s)**2 - (dy/s)*(dp/s)) + if (stp .gt. sty) gamma = -gamma + p = (gamma - dp) + theta + q = ((gamma - dp) + gamma) + dy + r = p/q + stpc = stp + r*(sty - stp) + stpf = stpc + else if (stp .gt. stx) then + stpf = stpmax + else + stpf = stpmin + endif + endif + +c Update the interval which contains a minimizer. + + if (fp .gt. fx) then + sty = stp + fy = fp + dy = dp + else + if (sgnd .lt. zero) then + sty = stx + fy = fx + dy = dx + endif + stx = stp + fx = fp + dx = dp + endif + +c Compute the new step. + + stp = stpf + + end + +c====================== The end of dcstep ============================== + + subroutine timer(ttime) + double precision ttime +c ********* +c +c Subroutine timer +c +c This subroutine is used to determine user time. In a typical +c application, the user time for a code segment requires calls +c to subroutine timer to determine the initial and final time. +c +c The subroutine statement is +c +c subroutine timer(ttime) +c +c where +c +c ttime is an output variable which specifies the user time. +c +c Argonne National Laboratory and University of Minnesota. +c MINPACK-2 Project. +c +c Modified October 1990 by Brett M. Averick. +c +c ********** + real temp + real tarray(2) + real etime + +c The first element of the array tarray specifies user time + + temp = etime(tarray) + + ttime = dble(tarray(1)) + + return + + end + +c====================== The end of timer =============================== + + double precision function dnrm2(n,x,incx) + integer n,incx + double precision x(n) +c ********** +c +c Function dnrm2 +c +c Given a vector x of length n, this function calculates the +c Euclidean norm of x with stride incx. +c +c The function statement is +c +c double precision function dnrm2(n,x,incx) +c +c where +c +c n is a positive integer input variable. +c +c x is an input array of length n. +c +c incx is a positive integer variable that specifies the +c stride of the vector. +c +c Subprograms called +c +c FORTRAN-supplied ... abs, max, sqrt +c +c MINPACK-2 Project. February 1991. +c Argonne National Laboratory. +c Brett M. Averick. +c +c ********** + integer i + double precision scale + + dnrm2 = 0.0d0 + scale = 0.0d0 + + do 10 i = 1, n, incx + scale = max(scale, abs(x(i))) + 10 continue + + if (scale .eq. 0.0d0) return + + do 20 i = 1, n, incx + dnrm2 = dnrm2 + (x(i)/scale)**2 + 20 continue + + dnrm2 = scale*sqrt(dnrm2) + + + return + + end + +c====================== The end of dnrm2 =============================== + + double precision function dpmeps() +c ********** +c +c Subroutine dpeps +c +c This subroutine computes the machine precision parameter +c dpmeps as the smallest floating point number such that +c 1 + dpmeps differs from 1. +c +c This subroutine is based on the subroutine machar described in +c +c W. J. Cody, +c MACHAR: A subroutine to dynamically determine machine parameters, +c ACM Trans. Math. Soft., 14, 1988, pages 303-311. +c +c The subroutine statement is: +c +c subroutine dpeps(dpmeps) +c +c where +c +c dpmeps is a double precision variable. +c On entry dpmeps need not be specified. +c On exit dpmeps is the machine precision. +c +c MINPACK-2 Project. February 1991. +c Argonne National Laboratory and University of Minnesota. +c Brett M. Averick. +c +c ******* + integer i,ibeta,irnd,it,itemp,negep + double precision a,b,beta,betain,betah,temp,tempa,temp1, + + zero,one,two + data zero,one,two /0.0d0,1.0d0,2.0d0/ + +c determine ibeta, beta ala malcolm. + + a = one + b = one + 10 continue + a = a + a + temp = a + one + temp1 = temp - a + if (temp1 - one .eq. zero) go to 10 + 20 continue + b = b + b + temp = a + b + itemp = int(temp - a) + if (itemp .eq. 0) go to 20 + ibeta = itemp + beta = dble(ibeta) + +c determine it, irnd. + + it = 0 + b = one + 30 continue + it = it + 1 + b = b * beta + temp = b + one + temp1 = temp - b + if (temp1 - one .eq. zero) go to 30 + irnd = 0 + betah = beta/two + temp = a + betah + if (temp - a .ne. zero) irnd = 1 + tempa = a + beta + temp = tempa + betah + if ((irnd .eq. 0) .and. (temp - tempa .ne. zero)) irnd = 2 + +c determine dpmeps. + + negep = it + 3 + betain = one/beta + a = one + do 40 i = 1, negep + a = a*betain + 40 continue + 50 continue + temp = one + a + if (temp - one .ne. zero) go to 60 + a = a*beta + go to 50 + 60 continue + dpmeps = a + if ((ibeta .eq. 2) .or. (irnd .eq. 0)) go to 70 + a = (a*(one + a))/two + temp = one + a + if (temp - one .ne. zero) dpmeps = a + + 70 return + + end + +c====================== The end of dpmeps ============================== + + subroutine daxpy(n,da,dx,incx,dy,incy) +c +c constant times a vector plus a vector. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c + double precision dx(*),dy(*),da + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if (da .eq. 0.0d0) return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dy(iy) + da*dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,4) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dy(i) + da*dx(i) + 30 continue + if( n .lt. 4 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,4 + dy(i) = dy(i) + da*dx(i) + dy(i + 1) = dy(i + 1) + da*dx(i + 1) + dy(i + 2) = dy(i + 2) + da*dx(i + 2) + dy(i + 3) = dy(i + 3) + da*dx(i + 3) + 50 continue + return + end + +c====================== The end of daxpy =============================== + + subroutine dcopy(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end + +c====================== The end of dcopy =============================== + + double precision function ddot(n,dx,incx,dy,incy) +c +c forms the dot product of two vectors. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddot = dtemp + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + 50 continue + 60 ddot = dtemp + return + end + +c====================== The end of ddot ================================ + + subroutine dpofa(a,lda,n,info) + integer lda,n,info + double precision a(lda,*) +c +c dpofa factors a double precision symmetric positive definite +c matrix. +c +c dpofa is usually called by dpoco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for dpoco) = (1 + 18/n)*(time for dpofa) . +c +c on entry +c +c a double precision(lda, n) +c the symmetric matrix to be factored. only the +c diagonal and upper triangle are used. +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 r so that a = trans(r)*r +c where trans(r) is the transpose. +c the strict lower triangle is unaltered. +c if info .ne. 0 , the factorization is not complete. +c +c info integer +c = 0 for normal return. +c = k signals an error condition. the leading minor +c of order k is not positive definite. +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 ddot +c fortran sqrt +c +c internal variables +c + double precision ddot,t + double precision s + integer j,jm1,k +c begin block with ...exits to 40 +c +c + do 30 j = 1, n + info = j + s = 0.0d0 + jm1 = j - 1 + if (jm1 .lt. 1) go to 20 + do 10 k = 1, jm1 + t = a(k,j) - ddot(k-1,a(1,k),1,a(1,j),1) + t = t/a(k,k) + a(k,j) = t + s = s + t*t + 10 continue + 20 continue + s = a(j,j) - s +c ......exit + if (s .le. 0.0d0) go to 40 + a(j,j) = sqrt(s) + 30 continue + info = 0 + 40 continue + return + end + +c====================== The end of dpofa =============================== + + subroutine dscal(n,da,dx,incx) +c +c scales a vector by a constant. +c uses unrolled loops for increment equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c + double precision da,dx(*) + integer i,incx,m,mp1,n,nincx +c + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dx(i) = da*dx(i) + 10 continue + return +c +c code for increment equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dx(i) = da*dx(i) + 30 continue + if( n .lt. 5 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dx(i) = da*dx(i) + dx(i + 1) = da*dx(i + 1) + dx(i + 2) = da*dx(i + 2) + dx(i + 3) = da*dx(i + 3) + dx(i + 4) = da*dx(i + 4) + 50 continue + return + end + +c====================== The end of dscal =============================== + + subroutine dtrsl(t,ldt,n,b,job,info) + integer ldt,n,job,info + double precision t(ldt,*),b(*) +c +c +c dtrsl solves systems of the form +c +c t * x = b +c or +c trans(t) * x = b +c +c where t is a triangular matrix of order n. here trans(t) +c denotes the transpose of the matrix t. +c +c on entry +c +c t double precision(ldt,n) +c t contains the matrix of the system. the zero +c elements of the matrix are not referenced, and +c the corresponding elements of the array can be +c used to store other information. +c +c ldt integer +c ldt is the leading dimension of the array t. +c +c n integer +c n is the order of the system. +c +c b double precision(n). +c b contains the right hand side of the system. +c +c job integer +c job specifies what kind of system is to be solved. +c if job is +c +c 00 solve t*x=b, t lower triangular, +c 01 solve t*x=b, t upper triangular, +c 10 solve trans(t)*x=b, t lower triangular, +c 11 solve trans(t)*x=b, t upper triangular. +c +c on return +c +c b b contains the solution, if info .eq. 0. +c otherwise b is unaltered. +c +c info integer +c info contains zero if the system is nonsingular. +c otherwise info contains the index of +c the first zero diagonal element of t. +c +c linpack. this version dated 08/14/78 . +c g. w. stewart, university of maryland, argonne national lab. +c +c subroutines and functions +c +c blas daxpy,ddot +c fortran mod +c +c internal variables +c + double precision ddot,temp + integer case,j,jj +c +c begin block permitting ...exits to 150 +c +c check for zero diagonal elements. +c + do 10 info = 1, n +c ......exit + if (t(info,info) .eq. 0.0d0) go to 150 + 10 continue + info = 0 +c +c determine the task and go to it. +c + case = 1 + if (mod(job,10) .ne. 0) case = 2 + if (mod(job,100)/10 .ne. 0) case = case + 2 + go to (20,50,80,110), case +c +c solve t*x=b for t lower triangular +c + 20 continue + b(1) = b(1)/t(1,1) + if (n .lt. 2) go to 40 + do 30 j = 2, n + temp = -b(j-1) + call daxpy(n-j+1,temp,t(j,j-1),1,b(j),1) + b(j) = b(j)/t(j,j) + 30 continue + 40 continue + go to 140 +c +c solve t*x=b for t upper triangular. +c + 50 continue + b(n) = b(n)/t(n,n) + if (n .lt. 2) go to 70 + do 60 jj = 2, n + j = n - jj + 1 + temp = -b(j+1) + call daxpy(j,temp,t(1,j+1),1,b(1),1) + b(j) = b(j)/t(j,j) + 60 continue + 70 continue + go to 140 +c +c solve trans(t)*x=b for t lower triangular. +c + 80 continue + b(n) = b(n)/t(n,n) + if (n .lt. 2) go to 100 + do 90 jj = 2, n + j = n - jj + 1 + b(j) = b(j) - ddot(jj-1,t(j+1,j),1,b(j+1),1) + b(j) = b(j)/t(j,j) + 90 continue + 100 continue + go to 140 +c +c solve trans(t)*x=b for t upper triangular. +c + 110 continue + b(1) = b(1)/t(1,1) + if (n .lt. 2) go to 130 + do 120 j = 2, n + b(j) = b(j) - ddot(j-1,t(1,j),1,b(1),1) + b(j) = b(j)/t(j,j) + 120 continue + 130 continue + 140 continue + 150 continue + return + end + +c====================== The end of dtrsl =============================== + diff --git a/dataassim/math/optimization/leastdistance.h b/dataassim/math/optimization/leastdistance.h new file mode 100644 index 0000000..fef3301 --- /dev/null +++ b/dataassim/math/optimization/leastdistance.h @@ -0,0 +1,10 @@ +!------------------CommonBlock----------------------------- + integer maxmy,maxnx,maxnparams + parameter(maxmy=10,maxnx=10,maxnparams=30) + integer my,iknowder,nparams + double precision targetx(maxnx),targety(maxmy), + & params(maxnparams) + common /distcom/targetx,targety,params, + & my,iknowder,nparams + save /distcom/ +!---------------------------------------------------------- diff --git a/dataassim/math/optimization/nongradopt.f b/dataassim/math/optimization/nongradopt.f new file mode 100644 index 0000000..2bb037d --- /dev/null +++ b/dataassim/math/optimization/nongradopt.f @@ -0,0 +1,412 @@ + subroutine nongradopt(ndim,funkmin,f1dim,beta, + & bmin,bmax,ftol,fatbeta) + implicit none +! This subroutine minimizes function funkmin to estimate ndim parameters +! using non-gradient based methods +! + integer ndim + double precision beta(1:ndim),bmin(1:ndim), + & bmax(1:ndim),ftol,fatbeta +! +! ------------------ Inputs ----------------------------- +! ndim: the total number of parameters to be estimated +! bmax: the maximum possible value of beta, used to determine the distance scaling factor +! bmin: the minimum possible value of beta, used to determine the distance scaling factor +! beta: initial guess, overwritten upon return +! ftol: tolerance for convergence +! fatbeta: the cost function valuate at beta, overwritten upon return +! funkmin is the name of the subroutine that computes the cost function +! f1dim: the one dimensional cost function + +! ------------------ Outputs ---------------------------- +! beta: The best parameters obtained +! fatbeta: the cost function value at beta + + integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX, + & icycle + parameter(maxredo=10,ITMAX=10000) + double precision fbest,xbest(1:ndim),term, + & xinidir(1:ndim,1:ndim),xbest0(1:ndim), + & pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1) + external funkmin,f1dim +! End of declaration of variables +!--------------------------------------------------------------- + icycle=0 +1 iredo=0 +3 do n=1,ndim + xbest(n)=beta(n) + do nn=1,ndim + xinidir(n,nn)=0.0d0 + enddo + xinidir(n,n)=1.0d0 + enddo + fbest=fatbeta + call powell(beta,xinidir(1:ndim,1:ndim),ndim,ndim, + & ftol,fatbeta,bmin,bmax,funkmin,f1dim,ITMAX) + if(fatbeta.gt.fbest)then + do n=1,ndim + beta(n)=xbest(n) + enddo + fatbeta=fbest + goto 10 + endif + if((fbest-fatbeta).gt.ftol)then + if(iredo.gt.maxredo)goto 10 + iredo=iredo+1 + goto 3 + endif +10 iredo=0 +20 do n=1,ndim + xbest(n)=beta(n) + enddo + fbest=fatbeta + do nn=1,ndim + pamoeba(1,nn)=beta(nn) + enddo + famoeba(1)=fatbeta + do n=2,ndim+1 + do nn=1,ndim + pamoeba(n,nn)=beta(nn) + enddo + if((bmax(n-1)-pamoeba(n,n-1)) + & .gt.(pamoeba(n,n-1)-bmin(n-1)))then + pamoeba(n,n-1)=pamoeba(n,n-1)+ + & (bmax(n-1)-pamoeba(n,n-1))*0.1d0 + else + pamoeba(n,n-1)=pamoeba(n,n-1)- + & (pamoeba(n,n-1)-bmin(n-1))*0.1d0 + endif + do nn=1,ndim + xbest0(nn)=pamoeba(n,nn) + enddo + call funkmin(ndim,xbest0,famoeba(n)) + enddo + mpamoeba=ndim+1 + npamoeba=ndim + fatbeta=1.0d+100 + term=1.0d0 +30 nn=ITMAX/20 + call amebsa(pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1), + &mpamoeba,npamoeba,ndim,beta,fatbeta,ftol,funkmin,nn,term) + if(fatbeta.lt.fbest)then + if((fbest-fatbeta).gt.ftol*100.0d0.and.term.gt.1.0d-2)then + term=term/3.0d0 + fbest=fatbeta + goto 30 + endif + do n=1,ndim + xbest(n)=beta(n) + enddo + fbest=fatbeta + else + do n=1,ndim + beta(n)=xbest(n) + enddo + fatbeta=fbest + endif + do nn=1,ndim + pamoeba(1,nn)=beta(nn) + enddo + famoeba(1)=fatbeta + do n=2,ndim+1 + do nn=1,ndim + pamoeba(n,nn)=beta(nn) + enddo + if((bmax(n-1)-pamoeba(n,n-1)) + & .gt.(pamoeba(n,n-1)-bmin(n-1)))then + pamoeba(n,n-1)=pamoeba(n,n-1)+ + & (bmax(n-1)-pamoeba(n,n-1))*0.1d0 + else + pamoeba(n,n-1)=pamoeba(n,n-1)- + & (pamoeba(n,n-1)-bmin(n-1))*0.1d0 + endif + do nn=1,ndim + xbest0(nn)=pamoeba(n,nn) + enddo + call funkmin(ndim,xbest0,famoeba(n)) + enddo + mpamoeba=ndim+1 + npamoeba=ndim + call guamoeba(pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1), + &mpamoeba,npamoeba,ndim,ftol,funkmin,ITMAX/20) + nn=1 + do n=2,ndim+1 + if(famoeba(n).lt.famoeba(nn))nn=n + enddo + fatbeta=famoeba(nn) + do n=1,ndim + beta(n)=pamoeba(nn,n) + if(beta(n).lt.bmin(n).or.beta(n).gt.bmax(n))then + do nn=1,ndim + beta(nn)=xbest(nn) + enddo + fatbeta=fbest + return + endif + enddo + if((fbest-fatbeta).gt.ftol)then + if(iredo.gt.maxredo)then + if(icycle.lt.maxredo)then + icycle=icycle+1 + goto 1 + else + return + endif + endif + iredo=iredo+1 + goto 20 + endif + return + end subroutine nongradopt +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + SUBROUTINE guamoeba(p,y,mp,np,ndim,ftol,funkmin,ITMAX) + implicit none + INTEGER iter,mp,ndim,np,NMAX,ITMAX + double precision ftol,p(mp,np),y(mp),TINY + PARAMETER (TINY=1.0d-10) + external funkmin +CU USES guamotry,funkmin + INTEGER i,ihi,ilo,inhi,j,m,n + double precision rtol,sum,swap,ysave,ytry,psum(ndim), + & guamotry,degen + iter=0 +1 do 12 n=1,ndim + sum=0.0d0 + do 11 m=1,ndim+1 + sum=sum+p(m,n) +11 continue + psum(n)=sum +12 continue +2 ilo=1 + if (y(1).gt.y(2)) then + ihi=1 + inhi=2 + else + ihi=2 + inhi=1 + endif + do 13 i=1,ndim+1 + if(y(i).le.y(ilo)) ilo=i + if(y(i).gt.y(ihi)) then + inhi=ihi + ihi=i + else if(y(i).gt.y(inhi)) then + if(i.ne.ihi) inhi=i + endif +13 continue + rtol=2.0d0*dabs(y(ihi)-y(ilo))/ + & (dabs(y(ihi))+dabs(y(ilo))+TINY) + if (rtol.lt.ftol) then + swap=y(1) + y(1)=y(ilo) + y(ilo)=swap + do 14 n=1,ndim + swap=p(1,n) + p(1,n)=p(ilo,n) + p(ilo,n)=swap +14 continue + return + endif + +! check to see if the simplex is degenerate; if so, stop + degen=0.0d0 + do i=1,mp + do m=i+1,mp + do n=1,np + if(dabs(p(m,n)-p(i,n)).gt.degen)then + degen=dabs(p(m,n)-p(i,n)) + endif + enddo + enddo + enddo + if(degen.lt.ftol*ftol)then + swap=y(1) + y(1)=y(ilo) + y(ilo)=swap + do n=1,ndim + swap=p(1,n) + p(1,n)=p(ilo,n) + p(ilo,n)=swap + enddo + return + endif + if(iter.ge.ITMAX)return + iter=iter+2 + ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,-1.0d0) + if (ytry.le.y(ilo))then + ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,2.0d0) + else if (ytry.ge.y(inhi)) then + ysave=y(ihi) + ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,0.5d0) + if (ytry.ge.ysave) then + do 16 i=1,ndim+1 + if(i.ne.ilo)then + do 15 j=1,ndim + psum(j)=0.5d0*(p(i,j)+p(ilo,j)) + p(i,j)=psum(j) +15 continue + call funkmin(ndim,psum,y(i)) + endif +16 continue + iter=iter+ndim + goto 1 + endif + else + iter=iter-1 + endif + goto 2 + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + DOUBLE PRECISION FUNCTION guamotry(p,y,psum, + & mp,np,ndim,funkmin,ihi,fac) + implicit none + INTEGER ihi,mp,ndim,np + double precision fac,p(mp,np),psum(np),y(mp) + EXTERNAL funkmin +CU USES funkmin + INTEGER j + double precision fac1,fac2,ytry,ptry(ndim) + fac1=(1.0d0-fac)/dble(ndim) + fac2=fac1-fac + do 11 j=1,ndim + ptry(j)=psum(j)*fac1-p(ihi,j)*fac2 +11 continue + call funkmin(ndim,ptry,ytry) + if (ytry.lt.y(ihi)) then + y(ihi)=ytry + do 12 j=1,ndim + psum(j)=psum(j)-p(ihi,j)+ptry(j) + p(ihi,j)=ptry(j) +12 continue + endif + guamotry=ytry + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + +c####################################################################### + + SUBROUTINE amebsa(p,y,mp,np,ndim,pb,yb,ftol,funkmin,iter,temptr) + implicit none + INTEGER iter,mp,ndim,np + double precision ftol,temptr,yb,p(mp,np),pb(np),y(mp) + EXTERNAL funkmin +CU USES amotsa,funkmin,ran1 + INTEGER i,idum,ihi,ilo,inhi,j,m,n + double precision rtol,sum,swap,tt,yhi,ylo,ynhi,ysave,yt,ytry, + &psum(ndim),amotsa,ran1 + COMMON /ambsa/ tt,idum + tt=-temptr +1 do 12 n=1,ndim + sum=0.0d0 + do 11 m=1,ndim+1 + sum=sum+p(m,n) +11 continue + psum(n)=sum +12 continue +2 ilo=1 + inhi=1 + ihi=2 + ylo=y(1)+tt*dlog(ran1(idum)) + ynhi=ylo + yhi=y(2)+tt*dlog(ran1(idum)) + if (ylo.gt.yhi) then + ihi=1 + inhi=2 + ilo=2 + ynhi=yhi + yhi=ylo + ylo=ynhi + endif + do 13 i=3,ndim+1 + yt=y(i)+tt*dlog(ran1(idum)) + if(yt.le.ylo) then + ilo=i + ylo=yt + endif + if(yt.gt.yhi) then + inhi=ihi + ynhi=yhi + ihi=i + yhi=yt + else if(yt.gt.ynhi) then + inhi=i + ynhi=yt + endif +13 continue + rtol=2.0d0*dabs(yhi-ylo)/(dabs(yhi)+dabs(ylo)) + if(rtol.lt.ftol.or.iter.lt.0) then + swap=y(1) + y(1)=y(ilo) + y(ilo)=swap + do 14 n=1,ndim + swap=p(1,n) + p(1,n)=p(ilo,n) + p(ilo,n)=swap +14 continue + return + endif + iter=iter-2 + ytry=amotsa(p(1:mp,1:np), + &y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,-1.0d0) + if (ytry.le.ylo) then + ytry=amotsa(p(1:mp,1:np), + &y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,2.0d0) + else if (ytry.ge.ynhi) then + ysave=yhi + ytry=amotsa(p(1:mp,1:np), + &y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,0.5d0) + if (ytry.ge.ysave) then + do 16 i=1,ndim+1 + if(i.ne.ilo)then + do 15 j=1,ndim + psum(j)=0.5d0*(p(i,j)+p(ilo,j)) + p(i,j)=psum(j) +15 continue + call funkmin(ndim,psum,y(i)) + endif +16 continue + iter=iter-ndim + goto 1 + endif + else + iter=iter+1 + endif + goto 2 + END + + double precision FUNCTION amotsa + &(p,y,psum,mp,np,ndim,pb,yb,funkmin,ihi,yhi,fac) + implicit none + INTEGER ihi,mp,ndim,np + double precision fac,yb,yhi,p(mp,np),pb(np),psum(ndim),y(mp) + EXTERNAL funkmin +CU USES funkmin,ran1 + INTEGER idum,j + double precision fac1,fac2,tt,yflu,ytry,ptry(ndim),ran1 + COMMON /ambsa/ tt,idum + fac1=(1.0d0-fac)/dble(ndim) + fac2=fac1-fac + do 11 j=1,ndim + ptry(j)=psum(j)*fac1-p(ihi,j)*fac2 +11 continue + call funkmin(ndim,ptry,ytry) + if (ytry.le.yb) then + do 12 j=1,ndim + pb(j)=ptry(j) +12 continue + yb=ytry + endif + yflu=ytry-tt*log(ran1(idum)) + if (yflu.lt.yhi) then + y(ihi)=ytry + yhi=yflu + do 13 j=1,ndim + psum(j)=psum(j)-p(ihi,j)+ptry(j) + p(ihi,j)=ptry(j) +13 continue + endif + amotsa=yflu + return + END diff --git a/dataassim/math/optimization/odr_leastsquare.f b/dataassim/math/optimization/odr_leastsquare.f new file mode 100644 index 0000000..f9d6371 --- /dev/null +++ b/dataassim/math/optimization/odr_leastsquare.f @@ -0,0 +1,249 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine odr_leastsquare(NP,FCN,BETA,N,X,M,Y,NQ, + &weitx,weity,iderivative,shortx,shorty,fvalue,INFO) + implicit none +!if derivatives are provided, set iderivative to 1, otherwise set it to 0. +!for ordinary least square regression, set INFO to 0. +!for explicit orthorgonal distance regression, set INFO to 1. +!the content of INFO is destroyed on return +C ODRPACK ARGUMENT DEFINITIONS +C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE +C ==> N NUMBER OF OBSERVATIONS +C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C <==> BETA FUNCTION PARAMETERS +C ==> Y RESPONSE VARIABLE +C ==> X EXPLANATORY VARIABLE +C ==> LWORK DIMENSION OF VECTOR WORK +C ==> LIWORK DIMENSION OF VECTOR IWORK +C <== INFO STOPPING CONDITION + +C VARIABLE DECLARATIONS + INTEGER INFO,M,N,NP,NQ,iderivative,LWORK,LIWORK + double precision weity(N,NQ),weitx(N,M),shorty(N,NQ), + &shortx(N,M),fvalue,BETA(NP),X(N,M),Y(N,NQ) + EXTERNAL FCN + + LWORK=18+11*NP+NP**2+M+M**2+4*N*NQ+6*N*M+2*N*NQ*NP+ + &2*N*NQ*M+NQ**2+5*NQ+NQ*(NP+M)+N*1*NQ + LIWORK=20+NP+NQ*(NP+M) + call odr_interface(NP,FCN,BETA,N,X(1:N,1:M),M,Y(1:N,1:NQ),NQ, + &LWORK,LIWORK,weitx(1:N,1:M),weity(1:N,1:NQ),iderivative, + &shortx(1:N,1:M),shorty(1:N,1:NQ),fvalue,INFO) + return + end subroutine odr_leastsquare +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ + subroutine odr_interface(NP,FCN,BETA,N,X,M,Y,NQ,LWORK, + &LIWORK,weitx,weity,iderivative,shortx,shorty,fvalue,INFO) + implicit none +!if derivatives are provided, set iderivative to 1, otherwise set it to 0. +!for ordinary least square regression, set INFO to 0. +!for explicit orthorgonal distance regression, set INFO to 1. +!the content of INFO is destroyed on return +C ODRPACK ARGUMENT DEFINITIONS +C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE +C ==> N NUMBER OF OBSERVATIONS +C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C <==> BETA FUNCTION PARAMETERS +C ==> Y RESPONSE VARIABLE +C ==> LDY LEADING DIMENSION OF ARRAY Y +C ==> X EXPLANATORY VARIABLE +C ==> LDX LEADING DIMENSION OF ARRAY X +C ==> WE "EPSILON" WEIGHTS +C ==> LDWE LEADING DIMENSION OF ARRAY WE +C ==> LD2WE SECOND DIMENSION OF ARRAY WE +C ==> WD "DELTA" WEIGHTS +C ==> LDWD LEADING DIMENSION OF ARRAY WD +C ==> LD2WD SECOND DIMENSION OF ARRAY WD +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> JOB TASK TO BE PERFORMED +C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS +C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR +C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION +C ==> PARTOL PARAMETER CONVERGENCE CRITERION +C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS +C ==> IPRINT PRINT CONTROL +C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS +C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS +C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA +C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA +C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD +C ==> SCLB SCALE VALUES FOR PARAMETERS BETA +C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE +C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD +C <==> WORK DOUBLE PRECISION WORK VECTOR +C ==> LWORK DIMENSION OF VECTOR WORK +C <== IWORK INTEGER WORK VECTOR +C ==> LIWORK DIMENSION OF VECTOR IWORK +C <== INFO STOPPING CONDITION + +C PARAMETER DECLARATIONS AND SPECIFICATIONS + INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWORK,LWORK +C VARIABLE DECLARATIONS + INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N, + + NDIGIT,NP,NQ + INTEGER IFIXB(NP),IFIXX(N,M),IWORK(LIWORK) + DOUBLE PRECISION PARTOL,SSTOL,TAUFAC + DOUBLE PRECISION BETA(NP),SCLB(NP),SCLD(1,M), + + STPB(NP),STPD(1,M), + + WD(N,1,M),WE(N,1,NQ), + + WORK(LWORK),X(N,M),Y(N,NQ) +!------------For using information in WORK---------------------------- + LOGICAL + + ISODR + INTEGER + + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN +c + integer i1,i2,i3,i4,i5,iderivative + double precision weity(N,NQ),weitx(N,M),shorty(N,NQ), + &shortx(N,M),fvalue + EXTERNAL FCN +c +C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS + + LDY=N + LDX=N + LDWE=N + LD2WE=1 + LDWD=N + LD2WD=1 + LDIFX=N + LDSTPD=1 + LDSCLD=1 + + WE(1,1,1) = -1.0D0 + WD(1,1,1) = -1.0D0 + IFIXB(1) = -1 +! IFIXX(1,1) = -1 + + if(INFO.eq.0)then +!explicit ordinary least square fitting + ISODR=.false. + if(iderivative.eq.0)then +!no derivatives provided, using central finite difference + JOB=13 + else +!don't check derivatives + JOB=43 +!check derivatives +! JOB=23 + endif + endif + if(INFO.eq.1)then +!explicit orthogonal distance regression + ISODR=.true. + if(iderivative.eq.0)then +!no derivatives provided, using central finite difference + JOB=10 + else +!don't check derivatives + JOB=40 +!check derivatives +! JOB=20 + endif + endif + if(INFO.eq.-1)then +!implicit orthogonal distance regression + ISODR=.true. + if(iderivative.eq.0)then +!no derivatives provided, using central finite difference + JOB=11 + else +!don't check derivatives + JOB=31 +!check derivatives +! JOB=21 + endif + endif + NDIGIT = -1 + TAUFAC = -1.0D0 + SSTOL = -1.0D0 + PARTOL = -1.0D0 + MAXIT = -1 + IPRINT = -1 + IPRINT=0 + LUNERR = -1 + LUNRPT = -1 + STPB(1) = -1.0D0 + STPD(1,1) = -1.0D0 + SCLB(1) = -1.0D0 + SCLD(1,1) = -1.0D0 + + MAXIT = 200000 +C SET UP ODRPACK REPORT FILES + LUNERR = 107 + LUNRPT = 108 + LWKMN=LWORK +c + do I=1,N + do i1=1,M + WD(I,1,i1)=weitx(I,i1) + enddo + do i1=1,NQ + WE(I,1,i1)=weity(I,i1) + enddo + enddo +C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX + DO 10 I=1,N + DO 15 J=1, M + IFIXX(I,J) = 1 +15 CONTINUE +10 CONTINUE +60 CALL DODRC(FCN, + + N,M,NP,NQ, + + BETA, + + Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, + + SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, + + SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + i1=mod(INFO,10) + i2=(mod(INFO,100)-i1)/10 + i3=(mod(INFO,1000)-mod(INFO,100))/100 + i4=(mod(INFO,10000)-mod(INFO,1000))/1000 + i5=(INFO-mod(INFO,10000))/10000 + CALL DWINF + + (N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) + fvalue=0.0d0 + do I=1,N + do J=1,M + shortx(I,J)=WORK(XPLUSI-1+I+(J-1)*N) + fvalue=fvalue+weitx(I,J)*WORK(DELTAI-1+I+(J-1)*N) + + *WORK(DELTAI-1+I+(J-1)*N) + enddo + do J=1,NQ + shorty(I,J)=WORK(FNI-1+I+(J-1)*N) + fvalue=fvalue+weity(I,J)*WORK(EPSI-1+I+(J-1)*N) + +*WORK(EPSI-1+I+(J-1)*N) + enddo + enddo + return + END diff --git a/dataassim/math/optimization/odrpack.f b/dataassim/math/optimization/odrpack.f new file mode 100644 index 0000000..82c2b84 --- /dev/null +++ b/dataassim/math/optimization/odrpack.f @@ -0,0 +1,13600 @@ +! This file contains subroutines from ODRPACK and Numerical Recipes. +! Note that machine precision is now computed within the program so +! there is no need to set machine dependent constants. +! Lianhong Gu, Oak Ridge National Laboratory + +*DMPREC + DOUBLE PRECISION FUNCTION DMPREC() + implicit none + integer ibeta,it,irnd,ngrd,machep,negep,iexp,minexp, + *maxexp + double precision eps,epsneg,xmin,xmax + +C***BEGIN PROLOGUE DPREC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE DETERMINE MACHINE PRECISION FOR TARGET MACHINE AND COMPILER +C ASSUMING FLOATING-POINT NUMBERS ARE REPRESENTED IN THE +C T-DIGIT, BASE-B FORM +C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, AND +C 0 .LT. X(1). +C TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE, +C EITHER +C ACTIVATE THE DESIRED SET OF DATA STATEMENTS BY +C REMOVING THE C FROM COLUMN 1 +C OR +C SET B, TD AND TS USING I1MACH BY ACTIVATING +C THE DECLARATION STATEMENTS FOR I1MACH +C AND THE STATEMENTS PRECEEDING THE FIRST +C EXECUTABLE STATEMENT BELOW. +C***END PROLOGUE DPREC + +C...LOCAL SCALARS +C DOUBLE PRECISION +C + B +C INTEGER +C + TD,TS + +C...EXTERNAL FUNCTIONS +c INTEGER +c + I1MACH +c EXTERNAL +c + I1MACH + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) + +C DOUBLE PRECISION B +C THE BASE OF THE TARGET MACHINE. +C (MAY BE DEFINED USING I1MACH(10).) +C INTEGER TD +C THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION. +C (MAY BE DEFINED USING I1MACH(14).) +C INTEGER TS +C THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION. +C (MAY BE DEFINED USING I1MACH(11).) + + +C MACHINE CONSTANTS FOR COMPUTERS FOLLOWING IEEE ARITHMETIC STANDARD +C (E.G., MOTOROLA 68000 BASED MACHINES SUCH AS SUN AND SPARC +C WORKSTATIONS, AND AT&T PC 7300; AND 8087 BASED MICROS SUCH AS THE +C IBM PC AND THE AT&T 6300). +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 53 / + +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 60 / + +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C THE BURROUGHS 6700/7700 SYSTEMS +C DATA B / 8 / +C DATA TS / 13 / +C DATA TD / 26 / + +C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN5 COMPILER) +C THE CYBER 170/180 SERIES UNDER NOS +C DATA B / 2 / +C DATA TS / 48 / +C DATA TD / 96 / + +C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN COMPILER) +C THE CYBER 170/180 SERIES UNDER NOS/VE +C THE CYBER 200 SERIES +C DATA B / 2 / +C DATA TS / 47 / +C DATA TD / 94 / + +C MACHINE CONSTANTS FOR THE CRAY +C DATA B / 2 / +C DATA TS / 47 / +C DATA TD / 94 / + +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + +C MACHINE CONSTANTS FOR THE HARRIS COMPUTER +C DATA B / 2 / +C DATA TS / 23 / +C DATA TD / 38 / + +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 +C THE HONEYWELL 600/6000 SERIES +C DATA B / 2 / +C DATA TS / 27 / +C DATA TD / 63 / + +C MACHINE CONSTANTS FOR THE HP 2100 +C (3 WORD DOUBLE PRECISION OPTION WITH FTN4) +C DATA B / 2 / +C DATA TS / 23 / +C DATA TD / 39 / + +C MACHINE CONSTANTS FOR THE HP 2100 +C (4 WORD DOUBLE PRECISION OPTION WITH FTN4) +C DATA B / 2 / +C DATA TS / 23 / +C DATA TD / 55 / + +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + +C MACHINE CONSTANTS FOR THE IBM PC +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 53 / + +C MACHINE CONSTANTS FOR THE INTERDATA (PERKIN ELMER) 7/32 +C INTERDATA (PERKIN ELMER) 8/32 +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). +C DATA B / 2 / +C DATA TS / 27 / +C DATA TD / 54 / + +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). +C DATA B / 2 / +C DATA TS / 27 / +C DATA TD / 62 / + +C MACHINE CONSTANTS FOR THE PDP-11 SYSTEM +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 56 / + +C MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230 +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + +C MACHINE CONSTANTS FOR THE PRIME 850 AND PRIME 4050 +C DATA B / 2 / +C DATA TS / 23 / +C DATA TD / 47 / + +C MACHINE CONSTANTS FOR THE SEL SYSTEMS 85/86 +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + +C MACHINE CONSTANTS FOR SUN AND SPARC WORKSTATIONS +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 53 / + +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES +C DATA B / 2 / +C DATA TS / 27 / +C DATA TD / 60 / + +C MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS COMPILER +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 56 / + +C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITHOUT G_FLOATING +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 56 / + +C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITH G_FLOATING +C DATA B / 2 / +C DATA TS / 24 / +C DATA TD / 53 / + +C MACHINE CONSTANTS FOR THE XEROX SIGMA 5/7/9 +C DATA B / 16 / +C DATA TS / 6 / +C DATA TD / 14 / + + +C***FIRST EXECUTABLE STATEMENT DMPREC + + +c B = I1MACH(10) +c TS = I1MACH(11) +c TD = I1MACH(14) + +c DMPREC = B ** (1-TD) + + call machar_odr(ibeta,it,irnd,ngrd,machep,negep,iexp, + *minexp, maxexp,eps,epsneg,xmin,xmax) + DMPREC=eps + RETURN + + END + + SUBROUTINE machar_odr(ibeta,it,irnd,ngrd,machep,negep, + *iexp,minexp, maxexp,eps,epsneg,xmin,xmax) + implicit none + INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd + double precision eps,epsneg,xmax,xmin + INTEGER i,itemp,iz,j,k,mx,nxres + double precision a,b,beta,betah,betain,one,t,temp,temp1,tempa, + &two,y,z,zero, CONV + CONV(i)=dble(i) + one=CONV(1) + two=one+one + zero=one-one + a=one +1 continue + a=a+a + temp=a+one + temp1=temp-a + if (temp1-one.eq.zero) goto 1 + b=one +2 continue + b=b+b + temp=a+b + itemp=int(temp-a) + if (itemp.eq.0) goto 2 + ibeta=itemp + beta=CONV(ibeta) + it=0 + b=one +3 continue + it=it+1 + b=b*beta + temp=b+one + temp1=temp-b + if (temp1-one.eq.zero) goto 3 + irnd=0 + betah=beta/two + temp=a+betah + if (temp-a.ne.zero) irnd=1 + tempa=a+beta + temp=tempa+betah + if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2 + negep=it+3 + betain=one/beta + a=one + do 11 i=1, negep + a=a*betain +11 continue + b=a +4 continue + temp=one-a + if (temp-one.ne.zero) goto 5 + a=a*beta + negep=negep-1 + goto 4 +5 negep=-negep + epsneg=a + machep=-it-3 + a=b +6 continue + temp=one+a + if (temp-one.ne.zero) goto 7 + a=a*beta + machep=machep+1 + goto 6 +7 eps=a + ngrd=0 + temp=one+eps + if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1 + i=0 + k=1 + z=betain + t=one+eps + nxres=0 +8 continue + y=z + z=y*y + a=z*one + temp=z*t + if ((a+a.eq.zero).or.(dabs(z).ge.y)) goto 9 + temp1=temp*betain + if (temp1*beta.eq.z) goto 9 + i=i+1 + k=k+k + goto 8 +9 if (ibeta.ne.10) then + iexp=i+1 + mx=k+k + else + iexp=2 + iz=ibeta +10 if (k.ge.iz) then + iz=iz*ibeta + iexp=iexp+1 + goto 10 + endif + mx=iz+iz-1 + endif +20 xmin=y + y=y*betain + a=y*one + temp=y*t + if (((a+a).ne.zero).and.(dabs(y).lt.xmin)) then + k=k+1 + temp1=temp*betain + if ((temp1*beta.ne.y).or.(temp.eq.y)) then + goto 20 + else + nxres=3 + xmin=y + endif + endif + minexp=-k + if ((mx.le.k+k-3).and.(ibeta.ne.10)) then + mx=mx+mx + iexp=iexp+1 + endif + maxexp=mx+minexp + irnd=irnd+nxres + if (irnd.ge.2) maxexp=maxexp-2 + i=maxexp+minexp + if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1 + if (i.gt.20) maxexp=maxexp-1 + if (a.ne.y) maxexp=maxexp-2 + xmax=one-epsneg + if (xmax*one.ne.xmax) xmax=one-beta*epsneg + xmax=xmax/(beta*beta*beta*xmin) + i=maxexp+minexp+3 + do 12 j=1,i + if (ibeta.eq.2) xmax=xmax+xmax + if (ibeta.ne.2) xmax=xmax*beta +12 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + +*DODR + SUBROUTINE DODR + + (FCN, + + N,M,NP,NQ, + + BETA, + + Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + JOB, + + IPRINT,LUNERR,LUNRPT, + + WORK,LWORK,IWORK,LIWORK, + + INFO) +C***BEGIN PROLOGUE DODR +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***CATEGORY NO. G2E,I1B1 +C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, +C NONLINEAR LEAST SQUARES, +C MEASUREMENT ERROR MODELS, +C ERRORS IN VARIABLES +C***AUTHOR BOGGS, PAUL T. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C GAITHERSBURG, MD 20899 +C BYRD, RICHARD H. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C ROGERS, JANET E. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C SCHNABEL, ROBERT B. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C AND +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION (SHORT CALL STATEMENT) +C***DESCRIPTION +C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. +C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND +C R. B. SCHNABEL (1989), +C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED +C ORTHOGONAL DISTANCE REGRESSION," +C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. +C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND +C R. B. SCHNABEL (1992), +C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, +C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C INTERNAL REPORT NUMBER 92-4834. +C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), +C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR +C ORTHOGONAL DISTANCE REGRESSION," +C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. +C***ROUTINES CALLED DODCNT +C***END PROLOGUE DODR + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,LIWORK,LWORK, + + M,N,NDIGIT,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + NEGONE,PARTOL,SSTOL,TAUFAC,ZERO + INTEGER + + IPRINT,LDIFX,LDSCLD,LDSTPD,LUNERR,LUNRPT,MAXIT + LOGICAL + + SHORT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + SCLB(1),SCLD(1,1),STPB(1),STPD(1,1),WD1(1,1,1) + INTEGER + + IFIXB(1),IFIXX(1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODCNT + +C...DATA STATEMENTS + DATA + + NEGONE,ZERO + + /-1.0D0,0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C N: THE NUMBER OF OBSERVATIONS. +C NEGONE: THE VALUE -1.0D0. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C WD: THE DELTA WEIGHTS. +C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODR + + +C INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES + + IFIXB(1) = -1 + IFIXX(1,1) = -1 + LDIFX = 1 + NDIGIT = -1 + TAUFAC = NEGONE + SSTOL = NEGONE + PARTOL = NEGONE + MAXIT = -1 + STPB(1) = NEGONE + STPD(1,1) = NEGONE + LDSTPD = 1 + SCLB(1) = NEGONE + SCLD(1,1) = NEGONE + LDSCLD = 1 + + SHORT = .TRUE. + IF (WD(1,1,1).NE.ZERO) THEN + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + ELSE + WD1(1,1,1) = NEGONE + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + END IF + RETURN + + END +*DODRC + SUBROUTINE DODRC + + (FCN, + + N,M,NP,NQ, + + BETA, + + Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, + + SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, + + SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) +C***BEGIN PROLOGUE DODRC +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***CATEGORY NO. G2E,I1B1 +C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, +C NONLINEAR LEAST SQUARES, +C MEASUREMENT ERROR MODELS, +C ERRORS IN VARIABLES +C***AUTHOR BOGGS, PAUL T. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C GAITHERSBURG, MD 20899 +C BYRD, RICHARD H. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C ROGERS, JANET E. +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C SCHNABEL, ROBERT B. +C DEPARTMENT OF COMPUTER SCIENCE +C UNIVERSITY OF COLORADO, BOULDER, CO 80309 +C AND +C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C BOULDER, CO 80303-3328 +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION (LONG CALL STATEMENT) +C***DESCRIPTION +C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. +C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND +C R. B. SCHNABEL (1989), +C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED +C ORTHOGONAL DISTANCE REGRESSION," +C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. +C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND +C R. B. SCHNABEL (1992), +C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, +C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," +C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY +C INTERNAL REPORT NUMBER 92-4834. +C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), +C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR +C ORTHOGONAL DISTANCE REGRESSION," +C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. +C***ROUTINES CALLED DODCNT +C***END PROLOGUE DODRC + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + NEGONE,ZERO + LOGICAL + + SHORT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + WD1(1,1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODCNT + +C...DATA STATEMENTS + DATA + + NEGONE,ZERO + + /-1.0D0,0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C WD: THE DELTA WEIGHTS. +C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODRC + + SHORT = .FALSE. + IF (WD(1,1,1).NE.ZERO) THEN + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + ELSE + WD1(1,1,1) = NEGONE + CALL DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + END IF + RETURN + + END +*DACCES + SUBROUTINE DACCES + + (N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) +C***BEGIN PROLOGUE DACCES +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DIWINF,DWINF +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE ACCESS OR STORE VALUES IN THE WORK ARRAYS +C***END PROLOGUE DACESS + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRS,ALPHA,ETA,OLMAVG,PARTOL,PNORM,PRERS,RCOND, + + RNORMS,RVAR,SSTOL,TAU,TAUFAC + INTEGER + + IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOP,ISTOPI,JOB,JPVT, + + LDWE,LD2WE,LIWORK,LUNRPT,LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV, + + NNZW,NP,NPP,NQ,OMEGA,QRAUX,SD,U,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 + LOGICAL + + ACCESS,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + WORK(LWORK),WSS(3) + INTEGER + + IWORK(LIWORK) + +C...LOCAL SCALARS + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I, + + DELTAI,DELTNI,DELTSI,DIFFI,EPSI, + + EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT, + + IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI, + + MSGB,MSGD,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI, + + NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + WSSI,WSSDEI,WSSEPI,XPLUSI +C...EXTERNAL SUBROUTINES + EXTERNAL + + DIWINF,DWINF + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE +C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN +C THEM (ACCESS=FALSE). +C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IDFI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS. +C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. +C IPR1: THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE INITIAL SUMMARY REPORT. +C IPR2: THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE ITERATION REPORTS. +C IPR2F: THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. +C IPR3: THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FINAL SUMMARY REPORT. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS TO BE +C FOUND BY ODR (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C JPVT: THE PIVOT VECTOR. +C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE JPVT. +C LDTTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITER: THE NUMBER OF ITERATIONS TAKEN. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS ACTUALLY ESTIMATED. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. +C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER +C ITERATION. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGA: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERS: THE SAVED PREDICTED RELATIVE REDUCTION IN THE +C SUM-OF-SQUARES. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORMS: THE NORM OF THE SAVED WEIGHTED EPSILONS AND DELTAS. +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVAR: THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SCLB: THE SCALING VALUES USED FOR BETA. +C SCLD: THE SCALING VALUES USED FOR DELTA. +C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG- +C CALL (SHORT=FALSE). +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSS: THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. +C WSSI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(1). +C WSSDEI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(2). +C WSSEPI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(3). +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. + + +C***FIRST EXECUTABLE STATEMENT DACCES + + +C FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE + + CALL DIWINF(M,NP,NQ, + + MSGB,MSGD,JPVTI,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) + +C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE + + CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) + + IF (ACCESS) THEN + +C SET STARTING LOCATIONS FOR WORK VECTORS + + JPVT = JPVTI + OMEGA = OMEGAI + QRAUX = QRAUXI + SD = SDI + VCV = VCVI + U = UI + WRK1 = WRK1I + WRK2 = WRK2I + WRK3 = WRK3I + WRK4 = WRK4I + WRK5 = WRK5I + WRK6 = WRK6I + +C ACCESS VALUES FROM THE WORK VECTORS + + ACTRS = WORK(ACTRSI) + ALPHA = WORK(ALPHAI) + ETA = WORK(ETAI) + OLMAVG = WORK(OLMAVI) + PARTOL = WORK(PARTLI) + PNORM = WORK(PNORMI) + PRERS = WORK(PRERSI) + RCOND = WORK(RCONDI) + WSS(1) = WORK(WSSI) + WSS(2) = WORK(WSSDEI) + WSS(3) = WORK(WSSEPI) + RVAR = WORK(RVARI) + RNORMS = WORK(RNORSI) + SSTOL = WORK(SSTOLI) + TAU = WORK(TAUI) + TAUFAC = WORK(TAUFCI) + + NETA = IWORK(NETAI) + IRANK = IWORK(IRANKI) + JOB = IWORK(JOBI) + LUNRPT = IWORK(LUNRPI) + MAXIT = IWORK(MAXITI) + NFEV = IWORK(NFEVI) + NITER = IWORK(NITERI) + NJEV = IWORK(NJEVI) + NNZW = IWORK(NNZWI) + NPP = IWORK(NPPI) + IDF = IWORK(IDFI) + INT2 = IWORK(INT2I) + +C SET UP PRINT CONTROL VARIABLES + + IPRINT = IWORK(IPRINI) + + IPR1 = MOD(IPRINT,10000)/1000 + IPR2 = MOD(IPRINT,1000)/100 + IPR2F = MOD(IPRINT,100)/10 + IPR3 = MOD(IPRINT,10) + + ELSE + +C STORE VALUES INTO THE WORK VECTORS + + WORK(ACTRSI) = ACTRS + WORK(ALPHAI) = ALPHA + WORK(OLMAVI) = OLMAVG + WORK(PARTLI) = PARTOL + WORK(PNORMI) = PNORM + WORK(PRERSI) = PRERS + WORK(RCONDI) = RCOND + WORK(WSSI) = WSS(1) + WORK(WSSDEI) = WSS(2) + WORK(WSSEPI) = WSS(3) + WORK(RVARI) = RVAR + WORK(RNORSI) = RNORMS + WORK(SSTOLI) = SSTOL + WORK(TAUI) = TAU + + IWORK(IRANKI) = IRANK + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IWORK(NITERI) = NITER + IWORK(NJEVI) = NJEV + IWORK(IDFI) = IDF + IWORK(INT2I) = INT2 + END IF + + RETURN + END +*DESUBI + SUBROUTINE DESUBI + + (N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,E) +C***BEGIN PROLOGUE DESUBI +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE E = WD + ALPHA*TT**2 +C***END PROLOGUE DESUBI + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA + INTEGER + + LDTT,LDWD,LD2WD,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + E(M,M),TT(LDTT,M),WD(LDWD,LD2WD,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J,J1,J2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C E: THE VALUE OF THE ARRAY E = WD + ALPHA*TT**2 +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C J1: AN INDEXING VARIABLE. +C J2: AN INDEXING VARIABLE. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF RESPONSES PER OBSERVATION. +C TT: THE SCALING VALUES USED FOR DELTA. +C WD: THE SQUARED DELTA WEIGHTS, D**2. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DESUBI + + +C N.B. THE LOCATIONS OF WD AND TT ACCESSED DEPEND ON THE VALUE +C OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSIONS +C OF THE MULTIPLY SUBSCRIPTED ARRAYS. + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (WD(1,1,1).GE.ZERO) THEN + IF (LDWD.GE.N) THEN +C THE ELEMENTS OF WD HAVE BEEN INDIVIDUALLY SPECIFIED + + IF (LD2WD.EQ.1) THEN +C THE ARRAYS STORED IN WD ARE DIAGONAL + CALL DZERO(M,M,E,M) + DO 10 J=1,M + E(J,J) = WD(I,1,J) + 10 CONTINUE + ELSE +C THE ARRAYS STORED IN WD ARE FULL POSITIVE SEMIDEFINITE MATRICES + DO 30 J1=1,M + DO 20 J2=1,M + E(J1,J2) = WD(I,J1,J2) + 20 CONTINUE + 30 CONTINUE + END IF + + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 110 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 + 110 CONTINUE + ELSE + DO 120 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 + 120 CONTINUE + END IF + ELSE + DO 130 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 + 130 CONTINUE + END IF + ELSE +C WD IS AN M BY M MATRIX + + IF (LD2WD.EQ.1) THEN +C THE ARRAY STORED IN WD IS DIAGONAL + CALL DZERO(M,M,E,M) + DO 140 J=1,M + E(J,J) = WD(1,1,J) + 140 CONTINUE + ELSE +C THE ARRAY STORED IN WD IS A FULL POSITIVE SEMIDEFINITE MATRICES + DO 160 J1=1,M + DO 150 J2=1,M + E(J1,J2) = WD(1,J1,J2) + 150 CONTINUE + 160 CONTINUE + END IF + + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 210 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 + 210 CONTINUE + ELSE + DO 220 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 + 220 CONTINUE + END IF + ELSE + DO 230 J=1,M + E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 + 230 CONTINUE + END IF + END IF + ELSE +C WD IS A DIAGONAL MATRIX WITH ELEMENTS ABS(WD(1,1,1)) + CALL DZERO(M,M,E,M) + IF (TT(1,1).GT.ZERO) THEN + IF (LDTT.GE.N) THEN + DO 310 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(I,J)**2 + 310 CONTINUE + ELSE + DO 320 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,J)**2 + 320 CONTINUE + END IF + ELSE + DO 330 J=1,M + E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,1)**2 + 330 CONTINUE + END IF + END IF + + RETURN + END +*DETAF + SUBROUTINE DETAF + + (FCN, + + N,M,NP,NQ, + + XPLUSD,BETA,EPSMAC,NROW, + + PARTMP,PV0, + + IFIXB,IFIXX,LDIFX, + + ISTOP,NFEV,ETA,NETA, + + WRK1,WRK2,WRK6,WRK7) +C***BEGIN PROLOGUE DETAF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS +C (ADAPTED FROM STARPAC SUBROUTINE ETAFUN) +C***END PROLOGUE DETAF + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSMAC,ETA + INTEGER + + ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),PARTMP(NP),PV0(N,NQ), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),WRK7(-2:2,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + A,B,FAC,HUNDRD,ONE,P1,P2,P5,STP,TWO,ZERO + INTEGER + + J,K,L + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,INT,LOG10,MAX,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P1,P2,P5,ONE,TWO,HUNDRD + + /0.0D0,0.1D0,0.2D0,0.5D0,1.0D0,2.0D0,1.0D2/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: PARAMETERS OF THE LOCAL FIT. +C B: PARAMETERS OF THE LOCAL FIT. +C BETA: THE FUNCTION PARAMETERS. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE NOISE IN THE MODEL RESULTS. +C FAC: A FACTOR USED IN THE COMPUTATIONS. +C HUNDRD: THE VALUE 1.0D2. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEX VARIABLE. +C K: AN INDEX VARIABLE. +C L: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C P1: THE VALUE 0.1D0. +C P2: THE VALUE 0.2D0. +C P5: THE VALUE 0.5D0. +C PARTMP: THE MODEL PARAMETERS. +C PV0: THE ORIGINAL PREDICTED VALUES. +C STP: A SMALL VALUE USED TO PERTURB THE PARAMETERS. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C WRK7: A WORK ARRAY OF (5 BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DETAF + + + STP = HUNDRD*EPSMAC + ETA = EPSMAC + + DO 40 J=-2,2 + IF (J.EQ.0) THEN + DO 10 L=1,NQ + WRK7(J,L) = PV0(NROW,L) + 10 CONTINUE + ELSE + DO 20 K=1,NP + IF (IFIXB(1).LT.0) THEN + PARTMP(K) = BETA(K) + J*STP*BETA(K) + ELSE IF (IFIXB(K).NE.0) THEN + PARTMP(K) = BETA(K) + J*STP*BETA(K) + ELSE + PARTMP(K) = BETA(K) + END IF + 20 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + PARTMP,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1,ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + DO 30 L=1,NQ + WRK7(J,L) = WRK2(NROW,L) + 30 CONTINUE + END IF + 40 CONTINUE + + DO 100 L=1,NQ + A = ZERO + B = ZERO + DO 50 J=-2,2 + A = A + WRK7(J,L) + B = B + J*WRK7(J,L) + 50 CONTINUE + A = P2*A + B = P1*B + IF ((WRK7(0,L).NE.ZERO) .AND. + + (ABS(WRK7(1,L)+WRK7(-1,L)).GT.HUNDRD*EPSMAC)) THEN + FAC = ONE/ABS(WRK7(0,L)) + ELSE + FAC = ONE + END IF + DO 60 J=-2,2 + WRK7(J,L) = ABS((WRK7(J,L)-(A+J*B))*FAC) + ETA = MAX(WRK7(J,L),ETA) + 60 CONTINUE + 100 CONTINUE + NETA = MAX(TWO,P5-LOG10(ETA)) + + RETURN + END +*DEVJAC + SUBROUTINE DEVJAC + + (FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN, + + STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) +C***BEGIN PROLOGUE DEVJAC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DDOT_odr,DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA +C***END PROLOGUE DEVJAC + +C...SCALAR ARGUMENTS + INTEGER + + INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDWE,LDX,LD2WE, + + M,N,NETA,NFEV,NJEV,NP,NQ + LOGICAL + + ANAJAC,CDJAC,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),BETAC(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + FN(N,NQ),SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WE1(LDWE,LD2WE,NQ),WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP), + + WRK6(N,NP,NQ),X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + INTEGER + + IDEVAL,J,K,K1,L + DOUBLE PRECISION + + ZERO + LOGICAL + + ERROR + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr + EXTERNAL + + DDOT_odr + +C...DATA STATEMENTS + DATA ZERO + + /0.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C DELTA: THE ESTIMATED VALUES OF DELTA. +C ERROR: THE VARIABLE DESIGNATING WHETHER ODRPACK DETECTED NONZERO +C VALUES IN ARRAY DELTA IN THE OLS CASE, AND THUS WHETHER +C THE USER MAY HAVE OVERWRITTEN IMPORTANT INFORMATION +C BY COMPUTING FJACD IN THE OLS CASE. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT POINT. +C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE +C PERFORMED BY USER-SUPPLIED SUBROUTINE FCN. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF DELTA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISTOP: THE VARIABLE DESIGNATING THAT THE USER WISHES THE +C COMPUTATIONS STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C K1: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWE: THE LEADING DIMENSION OF ARRAYS WE AND WE1. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LD2WE: THE SECOND DIMENSION OF ARRAYS WE AND WE1. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C SSF: THE SCALE USED FOR THE BETA'S. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C WE1: THE SQUARE ROOTS OF THE EPSILON WEIGHTS IN ARRAY WE. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C X: THE INDEPENDENT VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + +C***FIRST EXECUTABLE STATEMENT DEVJAC +C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA + CALL DUNPAC(NP,BETAC,BETA,IFIXB) +C COMPUTE XPLUSD = X + DELTA + CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND +C THE JACOBIAN WRT DELTA (FJACD) + ISTOP = 0 + IF (ISODR) THEN + IDEVAL = 110 + ELSE + IDEVAL = 010 + END IF + IF (ANAJAC) THEN + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,WRK2,FJACB,FJACD, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV+1 + END IF +C MAKE SURE FIXED ELEMENTS OF FJACD ARE ZERO + IF (ISODR) THEN + DO 10 L=1,NQ + CALL DIFIX(N,M,IFIXX,LDIFX,FJACD(1,1,L),N,FJACD(1,1,L),N) + 10 CONTINUE + END IF + ELSE IF (CDJAC) THEN + CALL DJACCD(FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) + ELSE + CALL DJACFD(FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) + END IF + IF (ISTOP.LT.0) THEN + RETURN + ELSE IF (.NOT.ISODR) THEN +C TRY TO DETECT WHETHER THE USER HAS COMPUTED JFACD +C WITHIN FCN IN THE OLS CASE + ERROR = DDOT_odr(N*M,DELTA,1,DELTA,1).NE.ZERO + IF (ERROR) THEN + INFO = 50300 + RETURN + END IF + END IF +C WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS + + IF (IFIXB(1).LT.0) THEN + DO 20 K=1,NP + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACB(1,K,1),N*NP,FJACB(1,K,1),N*NP) + 20 CONTINUE + ELSE + K1 = 0 + DO 30 K=1,NP + IF (IFIXB(K).GE.1) THEN + K1 = K1 + 1 + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACB(1,K,1),N*NP,FJACB(1,K1,1),N*NP) + END IF + 30 CONTINUE + END IF + +C WEIGHT THE JACOBIAN'S WRT DELTA AS APPROPRIATE + + IF (ISODR) THEN + DO 40 J=1,M + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + + FJACD(1,J,1),N*M,FJACD(1,J,1),N*M) + 40 CONTINUE + END IF + RETURN + END +*DFCTR + SUBROUTINE DFCTR(OKSEMI,A,LDA,N,INFO) +C***BEGIN PROLOGUE DFCTR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DDOT_odr +C***DATE WRITTEN 910706 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE FACTOR THE POSITIVE (SEMI)DEFINITE MATRIX A USING A +C MODIFIED CHOLESKY FACTORIZATION +C (ADAPTED FROM LINPACK SUBROUTINE DPOFA) +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***END PROLOGUE DFCTR + +C...SCALAR ARGUMENTS + INTEGER INFO,LDA,N + LOGICAL OKSEMI + +C...ARRAY ARGUMENTS + DOUBLE PRECISION A(LDA,N) + +C...LOCAL SCALARS + DOUBLE PRECISION XI,S,T,TEN,ZERO + INTEGER J,K + +C...EXTERNAL FUNCTIONS + EXTERNAL DMPREC,DDOT_odr + DOUBLE PRECISION DMPREC,DDOT_odr + +C...INTRINSIC FUNCTIONS + INTRINSIC SQRT + +C...DATA STATEMENTS + DATA + + ZERO,TEN + + /0.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: THE ARRAY TO BE FACTORED. UPON RETURN, A CONTAINS THE +C UPPER TRIANGULAR MATRIX R SO THAT A = TRANS(R)*R +C WHERE THE STRICT LOWER TRIANGLE IS SET TO ZERO +C IF INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE. +C I: AN INDEXING VARIABLE. +C INFO: AN IDICATOR VARIABLE, WHERE IF +C INFO = 0 THEN FACTORIZATION WAS COMPLETED +C INFO = K SIGNALS AN ERROR CONDITION. THE LEADING MINOR +C OF ORDER K IS NOT POSITIVE (SEMI)DEFINITE. +C J: AN INDEXING VARIABLE. +C LDA: THE LEADING DIMENSION OF ARRAY A. +C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY A. +C OKSEMI: THE INDICATING WHETHER THE FACTORED ARRAY CAN BE POSITIVE +C SEMIDEFINITE (OKSEMI=TRUE) OR WHETHER IT MUST BE FOUND TO +C BE POSITIVE DEFINITE (OKSEMI=FALSE). +C TEN: THE VALUE 10.0D0. +C XI: A VALUE USED TO TEST FOR NON POSITIVE SEMIDEFINITENESS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DFCTR + + +C SET RELATIVE TOLERANCE FOR DETECTING NON POSITIVE SEMIDEFINITENESS. + XI = -TEN*DMPREC() + +C COMPUTE FACTORIZATION, STORING IN UPPER TRIANGULAR PORTION OF A + DO 20 J=1,N + INFO = J + S = ZERO + DO 10 K=1,J-1 + IF (A(K,K).EQ.ZERO) THEN + T = ZERO + ELSE + T = A(K,J) - DDOT_odr(K-1,A(1,K),1,A(1,J),1) + T = T/A(K,K) + END IF + A(K,J) = T + S = S + T*T + 10 CONTINUE + S = A(J,J) - S +C ......EXIT + IF (A(J,J).LT.ZERO .OR. S.LT.XI*ABS(A(J,J))) THEN + RETURN + ELSE IF (.NOT.OKSEMI .AND. S.LE.ZERO) THEN + RETURN + ELSE IF (S.LE.ZERO) THEN + A(J,J) = ZERO + ELSE + A(J,J) = SQRT(S) + END IF + 20 CONTINUE + INFO = 0 + +C ZERO OUT LOWER PORTION OF A + DO 40 J=2,N + DO 30 K=1,J-1 + A(J,K) = ZERO + 30 CONTINUE + 40 CONTINUE + + RETURN + END +*DFCTRW + SUBROUTINE DFCTRW + + (N,M,NQ,NPP, + + ISODR, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + WRK0,WRK4, + + WE1,NNZW,INFO) +C***BEGIN PROLOGUE DFCTRW +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFCTR +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING +C NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE +C ODRPACK REFERENCE GUIDE +C***END PROLOGUE DFCTRW + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDWD,LDWE,LD2WD,LD2WE, + + M,N,NNZW,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M), + + WRK0(NQ,NQ),WRK4(M,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,INF,J,J1,J2,L,L1,L2 + LOGICAL + + NOTZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DFCTR + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C J1: AN INDEXING VARIABLE. +C J2: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C L1: AN INDEXING VARIABLE. +C L2: AN INDEXING VARIABLE. +C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NOTZRO: THE VARIABLE DESIGNATING WHETHER A GIVEN COMPONENT OF THE +C WEIGHT ARRAY WE CONTAINS A NONZERO ELEMENT (NOTZRO=FALSE) +C OR NOT (NOTZRO=TRUE). +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. +C WE: THE (SQUARED) EPSILON WEIGHTS. +C WE1: THE FACTORED EPSILON WEIGHTS, S.T. TRANS(WE1)*WE1 = WE. +C WD: THE (SQUARED) DELTA WEIGHTS. +C WRK0: A WORK ARRAY OF (NQ BY NQ) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DFCTRW + + +C CHECK EPSILON WEIGHTS, AND STORE FACTORIZATION IN WE1 + + IF (WE(1,1,1).LT.ZERO) THEN +C WE CONTAINS A SCALAR + WE1(1,1,1) = -SQRT(ABS(WE(1,1,1))) + NNZW = N + + ELSE + NNZW = 0 + + IF (LDWE.EQ.1) THEN + + IF (LD2WE.EQ.1) THEN +C WE CONTAINS A DIAGONAL MATRIX + DO 110 L=1,NQ + IF (WE(1,1,L).GT.ZERO) THEN + NNZW = N + WE1(1,1,L) = SQRT(WE(1,1,L)) + ELSE IF (WE(1,1,L).LT.ZERO) THEN + INFO = 30010 + GO TO 300 + END IF + 110 CONTINUE + ELSE + +C WE CONTAINS A FULL NQ BY NQ SEMIDEFINITE MATRIX + DO 130 L1=1,NQ + DO 120 L2=L1,NQ + WRK0(L1,L2) = WE(1,L1,L2) + 120 CONTINUE + 130 CONTINUE + CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) + IF (INF.NE.0) THEN + INFO = 30010 + GO TO 300 + ELSE + DO 150 L1=1,NQ + DO 140 L2=1,NQ + WE1(1,L1,L2) = WRK0(L1,L2) + 140 CONTINUE + IF (WE1(1,L1,L1).NE.ZERO) THEN + NNZW = N + END IF + 150 CONTINUE + END IF + END IF + + ELSE + + IF (LD2WE.EQ.1) THEN +C WE CONTAINS AN ARRAY OF DIAGONAL MATRIX + DO 220 I=1,N + NOTZRO = .FALSE. + DO 210 L=1,NQ + IF (WE(I,1,L).GT.ZERO) THEN + NOTZRO = .TRUE. + WE1(I,1,L) = SQRT(WE(I,1,L)) + ELSE IF (WE(I,1,L).LT.ZERO) THEN + INFO = 30010 + GO TO 300 + END IF + 210 CONTINUE + IF (NOTZRO) THEN + NNZW = NNZW + 1 + END IF + 220 CONTINUE + ELSE + +C WE CONTAINS AN ARRAY OF FULL NQ BY NQ SEMIDEFINITE MATRICES + DO 270 I=1,N + DO 240 L1=1,NQ + DO 230 L2=L1,NQ + WRK0(L1,L2) = WE(I,L1,L2) + 230 CONTINUE + 240 CONTINUE + CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) + IF (INF.NE.0) THEN + INFO = 30010 + GO TO 300 + ELSE + NOTZRO = .FALSE. + DO 260 L1=1,NQ + DO 250 L2=1,NQ + WE1(I,L1,L2) = WRK0(L1,L2) + 250 CONTINUE + IF (WE1(I,L1,L1).NE.ZERO) THEN + NOTZRO = .TRUE. + END IF + 260 CONTINUE + END IF + IF (NOTZRO) THEN + NNZW = NNZW + 1 + END IF + 270 CONTINUE + END IF + END IF + END IF + +C CHECK FOR A SUFFICIENT NUMBER OF NONZERO EPSILON WEIGHTS + + IF (NNZW.LT.NPP) THEN + INFO = 30020 + END IF + + +C CHECK DELTA WEIGHTS + + 300 CONTINUE + IF (.NOT.ISODR .OR. WD(1,1,1).LT.ZERO) THEN +C PROBLEM IS NOT ODR, OR WD CONTAINS A SCALAR + RETURN + + ELSE + + IF (LDWD.EQ.1) THEN + + IF (LD2WD.EQ.1) THEN +C WD CONTAINS A DIAGONAL MATRIX + DO 310 J=1,M + IF (WD(1,1,J).LE.ZERO) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 310 CONTINUE + ELSE + +C WD CONTAINS A FULL M BY M POSITIVE DEFINITE MATRIX + DO 330 J1=1,M + DO 320 J2=J1,M + WRK4(J1,J2) = WD(1,J1,J2) + 320 CONTINUE + 330 CONTINUE + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + END IF + + ELSE + + IF (LD2WD.EQ.1) THEN +C WD CONTAINS AN ARRAY OF DIAGONAL MATRICES + DO 420 I=1,N + DO 410 J=1,M + IF (WD(I,1,J).LE.ZERO) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 410 CONTINUE + 420 CONTINUE + ELSE + +C WD CONTAINS AN ARRAY OF FULL M BY M POSITIVE DEFINITE MATRICES + DO 470 I=1,N + DO 440 J1=1,M + DO 430 J2=J1,M + WRK4(J1,J2) = WD(I,J1,J2) + 430 CONTINUE + 440 CONTINUE + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + INFO = MAX(30001,INFO+1) + RETURN + END IF + 470 CONTINUE + END IF + END IF + END IF + + RETURN + END +*DFLAGS + SUBROUTINE DFLAGS + + (JOB,RESTRT,INITD,DOVCV,REDOJ,ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) +C***BEGIN PROLOGUE DFLAGS +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB +C***END PROLOGUE DFLAGS + +C...SCALAR ARGUMENTS + INTEGER + + JOB + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...LOCAL SCALARS + INTEGER + + J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE FIRST N BY M ELEMENTS OF +C ARRAY WORK (INITD=FALSE). +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: THE VALUE OF A SPECIFIC DIGIT OF JOB. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). + + +C***FIRST EXECUTABLE STATEMENT DFLAGS + + + IF (JOB.GE.0) THEN + + RESTRT= JOB.GE.10000 + + INITD = MOD(JOB,10000)/1000.EQ.0 + + J = MOD(JOB,1000)/100 + IF (J.EQ.0) THEN + DOVCV = .TRUE. + REDOJ = .TRUE. + ELSE IF (J.EQ.1) THEN + DOVCV = .TRUE. + REDOJ = .FALSE. + ELSE + DOVCV = .FALSE. + REDOJ = .FALSE. + END IF + + J = MOD(JOB,100)/10 + IF (J.EQ.0) THEN + ANAJAC = .FALSE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + ELSE IF (J.EQ.1) THEN + ANAJAC = .FALSE. + CDJAC = .TRUE. + CHKJAC = .FALSE. + ELSE IF (J.EQ.2) THEN + ANAJAC = .TRUE. + CDJAC = .FALSE. + CHKJAC = .TRUE. + ELSE + ANAJAC = .TRUE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + END IF + + J = MOD(JOB,10) + IF (J.EQ.0) THEN + ISODR = .TRUE. + IMPLCT = .FALSE. + ELSE IF (J.EQ.1) THEN + ISODR = .TRUE. + IMPLCT = .TRUE. + ELSE + ISODR = .FALSE. + IMPLCT = .FALSE. + END IF + + ELSE + + RESTRT = .FALSE. + INITD = .TRUE. + DOVCV = .TRUE. + REDOJ = .TRUE. + ANAJAC = .FALSE. + CDJAC = .FALSE. + CHKJAC = .FALSE. + ISODR = .TRUE. + IMPLCT = .FALSE. + + END IF + + RETURN + END +*DHSTEP + DOUBLE PRECISION FUNCTION DHSTEP + + (ITYPE,NETA,I,J,STP,LDSTP) +C***BEGIN PROLOGUE DHSTEP +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET RELATIVE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES +C***END PROLOGUE DHSTEP + +C...SCALAR ARGUMENTS + INTEGER + + I,ITYPE,J,LDSTP,NETA + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + STP(LDSTP,J) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEN,THREE,TWO,ZERO + +C...DATA STATEMENTS + DATA + + ZERO,TWO,THREE,TEN + + /0.0D0,2.0D0,3.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. +C ITYPE: THE FINITE DIFFERENCE METHOD BEING USED, WHERE +C ITYPE = 0 INDICATES FORWARD FINITE DIFFERENCES, AND +C ITYPE = 1 INDICATES CENTRAL FINITE DIFFERENCES. +C J: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. +C LDSTP: THE LEADING DIMENSION OF ARRAY STP. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TEN: THE VALUE 10.0D0. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C ZERO: THE VALUE 0.0D0. + + + +C***FIRST EXECUTABLE STATEMENT DHSTEP + + +C SET DHSTEP TO RELATIVE FINITE DIFFERENCE STEP SIZE + + IF (STP(1,1).LE.ZERO) THEN + + IF (ITYPE.EQ.0) THEN +C USE DEFAULT FORWARD FINITE DIFFERENCE STEP SIZE + DHSTEP = TEN**(-ABS(NETA)/TWO - TWO) + + ELSE +C USE DEFAULT CENTRAL FINITE DIFFERENCE STEP SIZE + DHSTEP = TEN**(-ABS(NETA)/THREE) + END IF + + ELSE IF (LDSTP.EQ.1) THEN + DHSTEP = STP(1,J) + + ELSE + DHSTEP = STP(I,J) + END IF + + RETURN + END +*DIFIX + SUBROUTINE DIFIX + + (N,M,IFIX,LDIFIX,T,LDT,TFIX,LDTFIX) +C***BEGIN PROLOGUE DIFIX +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 910612 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET ELEMENTS OF T TO ZERO ACCORDING TO IFIX +C***END PROLOGUE DIFIX + +C...SCALAR ARGUMENTS + INTEGER + + LDIFIX,LDT,LDTFIX,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),TFIX(LDTFIX,M) + INTEGER + + IFIX(LDIFIX,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE ARRAY DESIGNATING WHETHER AN ELEMENT OF T IS TO BE +C SET TO ZERO. +C J: AN INDEXING VARIABLE. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C LDIFIX: THE LEADING DIMENSION OF ARRAY IFIX. +C LDTFIX: THE LEADING DIMENSION OF ARRAY TFIX. +C M: THE NUMBER OF COLUMNS OF DATA IN THE ARRAY. +C N: THE NUMBER OF ROWS OF DATA IN THE ARRAY. +C T: THE ARRAY BEING SET TO ZERO ACCORDING TO THE ELEMENTS +C OF IFIX. +C TFIX: THE RESULTING ARRAY. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DIFIX + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (IFIX(1,1).GE.ZERO) THEN + IF (LDIFIX.GE.N) THEN + DO 20 J=1,M + DO 10 I=1,N + IF (IFIX(I,J).EQ.0) THEN + TFIX(I,J) = ZERO + ELSE + TFIX(I,J) = T(I,J) + END IF + 10 CONTINUE + 20 CONTINUE + ELSE + DO 100 J=1,M + IF (IFIX(1,J).EQ.0) THEN + DO 30 I=1,N + TFIX(I,J) = ZERO + 30 CONTINUE + ELSE + DO 90 I=1,N + TFIX(I,J) = T(I,J) + 90 CONTINUE + END IF + 100 CONTINUE + END IF + END IF + + RETURN + END +*DINIWK + SUBROUTINE DINIWK + + (N,M,NP,WORK,LWORK,IWORK,LIWORK, + + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + + BETA,SCLB, + + SSTOL,PARTOL,MAXIT,TAUFAC, + + JOB,IPRINT,LUNERR,LUNRPT, + + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + SSFI,TTI,LDTTI,DELTAI) +C***BEGIN PROLOGUE DINIWK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFLAGS,DMPREC,DSCLB,DSCLD,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE INITIALIZE WORK VECTORS AS NECESSARY +C***END PROLOGUE DINIWK + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX, + + LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M, + + MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M) + INTEGER + + IFIXX(LDIFX,M),IWORK(LIWORK) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,THREE,TWO,ZERO + INTEGER + + I,J + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DMPREC + EXTERNAL + + DMPREC + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY_odr,DFLAGS,DSCLB,DSCLD,DZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TWO,THREE + + /0.0D0,1.0D0,2.0D0,3.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C I: AN INDEXING VARIABLE. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED +C AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C IWORK: THE INTEGER WORK SPACE. +C J: AN INDEXING VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDTTI: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING CRITERIA. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C THREE: THE VALUE 3.0D0. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF THE ARRAY TT. +C TWO: THE VALUE 2.0D0. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE INDEPENDENT VARIABLE. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DINIWK + + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + +C STORE VALUE OF MACHINE PRECISION IN WORK VECTOR + + WORK(EPSMAI) = DMPREC() + +C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE +C PARAMETERS (SEE ALSO SUBPROGRAM DODCNT) + + IF (PARTOL.LT.ZERO) THEN + WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE) + ELSE + WORK(PARTLI) = MIN(PARTOL, ONE) + END IF + +C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE +C SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS + + IF (SSTOL.LT.ZERO) THEN + WORK(SSTOLI) = SQRT(WORK(EPSMAI)) + ELSE + WORK(SSTOLI) = MIN(SSTOL, ONE) + END IF + +C SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION + + IF (TAUFAC.LE.ZERO) THEN + WORK(TAUFCI) = ONE + ELSE + WORK(TAUFCI) = MIN(TAUFAC, ONE) + END IF + +C SET MAXIMUM NUMBER OF ITERATIONS + + IF (MAXIT.LT.0) THEN + IWORK(MAXITI) = 50 + ELSE + IWORK(MAXITI) = MAXIT + END IF + +C STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL +C VARIABLE + + IF (JOB.LE.0) THEN + IWORK(JOBI) = 0 + ELSE + IWORK(JOBI) = JOB + END IF + +C SET PRINT CONTROL + + IF (IPRINT.LT.0) THEN + IWORK(IPRINI) = 2001 + ELSE + IWORK(IPRINI) = IPRINT + END IF + +C SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES + + IF (LUNERR.LT.0) THEN + IWORK(LUNERI) = 6 + ELSE + IWORK(LUNERI) = LUNERR + END IF + +C SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS + + IF (LUNRPT.LT.0) THEN + IWORK(LUNRPI) = 6 + ELSE + IWORK(LUNRPI) = LUNRPT + END IF + +C COMPUTE SCALING FOR BETA'S AND DELTA'S + + IF (SCLB(1).LE.ZERO) THEN + CALL DSCLB(NP,BETA,WORK(SSFI)) + ELSE + CALL DCOPY_odr(NP,SCLB,1,WORK(SSFI),1) + END IF + IF (ISODR) THEN + IF (SCLD(1,1).LE.ZERO) THEN + IWORK(LDTTI) = N + CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI)) + ELSE + IF (LDSCLD.EQ.1) THEN + IWORK(LDTTI) = 1 + CALL DCOPY_odr(M,SCLD(1,1),1,WORK(TTI),1) + ELSE + IWORK(LDTTI) = N + DO 10 J=1,M + CALL DCOPY_odr(N,SCLD(1,J),1, + + WORK(TTI+(J-1)*IWORK(LDTTI)),1) + 10 CONTINUE + END IF + END IF + END IF + +C INITIALIZE DELTA'S AS NECESSARY + + IF (ISODR) THEN + IF (INITD) THEN + CALL DZERO(N,M,WORK(DELTAI),N) + ELSE + IF (IFIXX(1,1).GE.0) THEN + IF (LDIFX.EQ.1) THEN + DO 20 J=1,M + IF (IFIXX(1,J).EQ.0) THEN + CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N) + END IF + 20 CONTINUE + ELSE + DO 40 J=1,M + DO 30 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + WORK(DELTAI-1+I+(J-1)*N) = ZERO + END IF + 30 CONTINUE + 40 CONTINUE + END IF + END IF + END IF + ELSE + CALL DZERO(N,M,WORK(DELTAI),N) + END IF + + RETURN + END +*DIWINF + SUBROUTINE DIWINF + + (M,NP,NQ, + + MSGBI,MSGDI,IFIX2I,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) +C***BEGIN PROLOGUE DIWINF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE +C***END PROLOGUE DIWINF + +C...SCALAR ARGUMENTS + INTEGER + + IDFI,INT2I,IPRINI,IRANKI,ISTOPI,JOBI,IFIX2I,LDTTI,LIWKMN, + + LUNERI,LUNRPI,M,MAXITI,MSGBI,MSGDI,NETAI,NFEVI,NITERI,NJEVI, + + NNZWI,NP,NPPI,NQ,NROWI,NTOLI + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C IFIX2I: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY IFIX2. +C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGBI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGDI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABEL NITER. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. + + +C***FIRST EXECUTABLE STATEMENT DIWINF + + + IF (NP.GE.1 .AND. M.GE.1) THEN + MSGBI = 1 + MSGDI = MSGBI + NQ*NP+1 + IFIX2I = MSGDI + NQ*M+1 + ISTOPI = IFIX2I + NP + NNZWI = ISTOPI + 1 + NPPI = NNZWI + 1 + IDFI = NPPI + 1 + JOBI = IDFI + 1 + IPRINI = JOBI + 1 + LUNERI = IPRINI + 1 + LUNRPI = LUNERI + 1 + NROWI = LUNRPI + 1 + NTOLI = NROWI + 1 + NETAI = NTOLI + 1 + MAXITI = NETAI + 1 + NITERI = MAXITI + 1 + NFEVI = NITERI + 1 + NJEVI = NFEVI + 1 + INT2I = NJEVI + 1 + IRANKI = INT2I + 1 + LDTTI = IRANKI + 1 + LIWKMN = LDTTI + ELSE + MSGBI = 1 + MSGDI = 1 + IFIX2I = 1 + ISTOPI = 1 + NNZWI = 1 + NPPI = 1 + IDFI = 1 + JOBI = 1 + IPRINI = 1 + LUNERI = 1 + LUNRPI = 1 + NROWI = 1 + NTOLI = 1 + NETAI = 1 + MAXITI = 1 + NITERI = 1 + NFEVI = 1 + NJEVI = 1 + INT2I = 1 + IRANKI = 1 + LDTTI = 1 + LIWKMN = 1 + END IF + + RETURN + END +*DJACCD + SUBROUTINE DJACCD + + (FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) +C***BEGIN PROLOGUE DJACCD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE CENTRAL DIFFERENCE APPROXIMATIONS TO THE +C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS +C***END PROLOGUE DJACCD + +C...SCALAR ARGUMENTS + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + + X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAK,ONE,TYPJ,ZERO + INTEGER + + I,J,K,L + LOGICAL + + DOIT,SETZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAK: THE K-TH FUNCTION PARAMETER. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A GIVEN +C BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT +C (DOIT=FALSE). +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED +C AT THEIR INPUT VALUES OR NOT. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME +C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT +C (SETZRO=FALSE). +C SSF: THE SCALING VALUES USED FOR BETA. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJACCD + + +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS + + DO 60 K=1,NP + IF (IFIXB(1).GE.0) THEN + IF (IFIXB(K).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + ELSE + DOIT = .TRUE. + END IF + IF (.NOT.DOIT) THEN + DO 10 L=1,NQ + CALL DZERO(N,1,FJACB(1,K,L),N) + 10 CONTINUE + ELSE + BETAK = BETA(K) + IF (BETAK.EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(K) + END IF + ELSE + TYPJ = ABS(BETAK) + END IF + WRK3(K) = BETAK + + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(1,NETA,1,K,STPB,1) + WRK3(K) = WRK3(K) - BETAK + + BETA(K) = BETAK + WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 30 L=1,NQ + DO 20 I=1,N + FJACB(I,K,L) = WRK2(I,L) + 20 CONTINUE + 30 CONTINUE + END IF + + BETA(K) = BETAK - WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + + DO 50 L=1,NQ + DO 40 I=1,N + FJACB(I,K,L) = (FJACB(I,K,L)-WRK2(I,L))/(2*WRK3(K)) + 40 CONTINUE + 50 CONTINUE + BETA(K) = BETAK + END IF + 60 CONTINUE + +C COMPUTE THE JACOBIAN WRT THE X'S + + IF (ISODR) THEN + DO 220 J=1,M + IF (IFIXX(1,1).LT.0) THEN + DOIT = .TRUE. + SETZRO = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + SETZRO = .FALSE. + ELSE + DOIT = .FALSE. + SETZRO = .FALSE. + DO 100 I=1,N + IF (IFIXX(I,J).NE.0) THEN + DOIT = .TRUE. + ELSE + SETZRO = .TRUE. + END IF + 100 CONTINUE + END IF + IF (.NOT.DOIT) THEN + DO 110 L=1,NQ + CALL DZERO(N,1,FJACD(1,J,L),N) + 110 CONTINUE + ELSE + DO 120 I=1,N + IF (XPLUSD(I,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(I,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(I,J)) + END IF + STP(I) = XPLUSD(I,J) + + + SIGN(ONE,XPLUSD(I,J)) + + *TYPJ*DHSTEP(1,NETA,I,J,STPD,LDSTPD) + STP(I) = STP(I) - XPLUSD(I,J) + XPLUSD(I,J) = XPLUSD(I,J) + STP(I) + 120 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 140 L=1,NQ + DO 130 I=1,N + FJACD(I,J,L) = WRK2(I,L) + 130 CONTINUE + 140 CONTINUE + END IF + + DO 150 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) - STP(I) + 150 CONTINUE + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + + IF (SETZRO) THEN + DO 180 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + DO 160 L=1,NQ + FJACD(I,J,L) = ZERO + 160 CONTINUE + ELSE + DO 170 L=1,NQ + FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + + (2*STP(I)) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE + DO 200 L=1,NQ + DO 190 I=1,N + FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + + (2*STP(I)) + 190 CONTINUE + 200 CONTINUE + END IF + DO 210 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) + 210 CONTINUE + END IF + 220 CONTINUE + END IF + + RETURN + END +*DJACFD + SUBROUTINE DJACFD + + (FCN, + + N,M,NP,NQ, + + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + + STPB,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + + FJACB,ISODR,FJACD,NFEV,ISTOP) +C***BEGIN PROLOGUE DJACFD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE FORWARD DIFFERENCE APPROXIMATIONS TO THE +C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS +C***END PROLOGUE DJACFD + +C...SCALAR ARGUMENTS + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ), + + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + + X(LDX,M),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAK,ONE,TYPJ,ZERO + INTEGER + + I,J,K,L + LOGICAL + + DOIT,SETZRO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DZERO + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAK: THE K-TH FUNCTION PARAMETER. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A +C GIVEN BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) +C OR NOT (DOIT=FALSE). +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME +C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT +C (SETZRO=FALSE). +C SSF: THE SCALE USED FOR THE BETA'S. +C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJACFD + + +C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS + + DO 40 K=1,NP + IF (IFIXB(1).GE.0) THEN + IF (IFIXB(K).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + ELSE + DOIT = .TRUE. + END IF + IF (.NOT.DOIT) THEN + DO 10 L=1,NQ + CALL DZERO(N,1,FJACB(1,K,L),N) + 10 CONTINUE + ELSE + BETAK = BETA(K) + IF (BETAK.EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(K) + END IF + ELSE + TYPJ = ABS(BETAK) + END IF + WRK3(K) = BETAK + + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(0,NETA,1,K,STPB,1) + WRK3(K) = WRK3(K) - BETAK + BETA(K) = BETAK + WRK3(K) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + END IF + DO 30 L=1,NQ + DO 20 I=1,N + FJACB(I,K,L) = (WRK2(I,L)-FN(I,L))/WRK3(K) + 20 CONTINUE + 30 CONTINUE + BETA(K) = BETAK + END IF + 40 CONTINUE + +C COMPUTE THE JACOBIAN WRT THE X'S + + IF (ISODR) THEN + DO 220 J=1,M + IF (IFIXX(1,1).LT.0) THEN + DOIT = .TRUE. + SETZRO = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + DOIT = .FALSE. + ELSE + DOIT = .TRUE. + END IF + SETZRO = .FALSE. + ELSE + DOIT = .FALSE. + SETZRO = .FALSE. + DO 100 I=1,N + IF (IFIXX(I,J).NE.0) THEN + DOIT = .TRUE. + ELSE + SETZRO = .TRUE. + END IF + 100 CONTINUE + END IF + IF (.NOT.DOIT) THEN + DO 110 L=1,NQ + CALL DZERO(N,1,FJACD(1,J,L),N) + 110 CONTINUE + ELSE + DO 120 I=1,N + IF (XPLUSD(I,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(I,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(I,J)) + END IF + + STP(I) = XPLUSD(I,J) + + + SIGN(ONE,XPLUSD(I,J)) + + *TYPJ*DHSTEP(0,NETA,I,J,STPD,LDSTPD) + STP(I) = STP(I) - XPLUSD(I,J) + XPLUSD(I,J) = XPLUSD(I,J) + STP(I) + 120 CONTINUE + + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 001,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NFEV = NFEV + 1 + DO 140 L=1,NQ + DO 130 I=1,N + FJACD(I,J,L) = WRK2(I,L) + 130 CONTINUE + 140 CONTINUE + + END IF + + IF (SETZRO) THEN + DO 180 I=1,N + IF (IFIXX(I,J).EQ.0) THEN + DO 160 L=1,NQ + FJACD(I,J,L) = ZERO + 160 CONTINUE + ELSE + DO 170 L=1,NQ + FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE + DO 200 L=1,NQ + DO 190 I=1,N + FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) + 190 CONTINUE + 200 CONTINUE + END IF + DO 210 I=1,N + XPLUSD(I,J) = X(I,J) + DELTA(I,J) + 210 CONTINUE + END IF + 220 CONTINUE + END IF + + RETURN + END +*DJCK + SUBROUTINE DJCK + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + + SSF,TT,LDTT, + + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + + PV0,FJACB,FJACD, + + MSGB,MSGD,DIFF,ISTOP,NFEV,NJEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DHSTEP,DJCKM +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS +C (ADAPTED FROM STARPAC SUBROUTINE DCKCNT) +C***END PROLOGUE DJCK + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSMAC,ETA + INTEGER + + ISTOP,LDIFX,LDSTPD,LDTT, + + M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + PV0(N,NQ),SSF(NP),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(1+NQ*NP),MSGD(1+NQ*M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO + INTEGER + + IDEVAL,J,LQ,MSGB1,MSGD1 + LOGICAL + + ISFIXD,ISWRTB + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKM + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,INT,LOG10 + +C...DATA STATEMENTS + DATA + + ZERO,P5,ONE + + /0.0D0,0.5D0,1.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE +C PERFORMED BY USER SUPPLIED SUBROUTINE FCN. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISFIXD: THE VARIABLE DESIGNATING WHETHER THE PARAMETER IS FIXED +C (ISFIXD=TRUE) OR NOT (ISFIXD=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA (ISWRTB=FALSE) ARE BEING CHECKED. +C J: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER +C SET BY THE USER OR COMPUTED BY DETAF. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. +C ONE: THE VALUE 1.0D0. +C P5: THE VALUE 0.5D0. +C PV: THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR +C ROW NROW IS STORED. +C PV0: THE PREDICTED VALUES USING THE CURRENT PARAMETER ESTIMATES. +C SSF: THE SCALING VALUES USED FOR BETA. +C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. +C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. +C TOL: THE AGREEMENT TOLERANCE. +C TT: THE SCALING VALUES USED FOR DELTA. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCK + + +C SET TOLERANCE FOR CHECKING DERIVATIVES + + TOL = ETA**(0.25D0) + NTOL = MAX(ONE,P5-LOG10(TOL)) + + +C COMPUTE USER SUPPLIED DERIVATIVE VALUES + + ISTOP = 0 + IF (ISODR) THEN + IDEVAL = 110 + ELSE + IDEVAL = 010 + END IF + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,WRK2,FJACB,FJACD, + + ISTOP) + IF (ISTOP.NE.0) THEN + RETURN + ELSE + NJEV = NJEV + 1 + END IF + +C CHECK DERIVATIVES WRT BETA FOR EACH RESPONSE OF OBSERVATION NROW + + MSGB1 = 0 + MSGD1 = 0 + + DO 30 LQ=1,NQ + +C SET PREDICTED VALUE OF MODEL AT CURRENT PARAMETER ESTIMATES + PV = PV0(NROW,LQ) + + ISWRTB = .TRUE. + DO 10 J=1,NP + + IF (IFIXB(1).LT.0) THEN + ISFIXD = .FALSE. + ELSE IF (IFIXB(J).EQ.0) THEN + ISFIXD = .TRUE. + ELSE + ISFIXD = .FALSE. + END IF + + IF (ISFIXD) THEN + MSGB(1+LQ+(J-1)*NQ) = -1 + ELSE + IF (BETA(J).EQ.ZERO) THEN + IF (SSF(1).LT.ZERO) THEN + TYPJ = ONE/ABS(SSF(1)) + ELSE + TYPJ = ONE/SSF(J) + END IF + ELSE + TYPJ = ABS(BETA(J)) + END IF + + H0 = DHSTEP(0,NETA,1,J,STPB,1) + HC0 = H0 + +C CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW + + CALL DJCKM(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,FJACB(NROW,J,LQ), + + DIFFJ,MSGB1,MSGB(2),ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + MSGB(1) = -1 + RETURN + ELSE + DIFF(LQ,J) = DIFFJ + END IF + END IF + + 10 CONTINUE + +C CHECK DERIVATIVES WRT X FOR EACH RESPONSE OF OBSERVATION NROW + + IF (ISODR) THEN + ISWRTB = .FALSE. + DO 20 J=1,M + + IF (IFIXX(1,1).LT.0) THEN + ISFIXD = .FALSE. + ELSE IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + ISFIXD = .TRUE. + ELSE + ISFIXD = .FALSE. + END IF + ELSE + ISFIXD = .FALSE. + END IF + + IF (ISFIXD) THEN + MSGD(1+LQ+(J-1)*NQ) = -1 + ELSE + + IF (XPLUSD(NROW,J).EQ.ZERO) THEN + IF (TT(1,1).LT.ZERO) THEN + TYPJ = ONE/ABS(TT(1,1)) + ELSE IF (LDTT.EQ.1) THEN + TYPJ = ONE/TT(1,J) + ELSE + TYPJ = ONE/TT(NROW,J) + END IF + ELSE + TYPJ = ABS(XPLUSD(NROW,J)) + END IF + + H0 = DHSTEP(0,NETA,NROW,J,STPD,LDSTPD) + HC0 = DHSTEP(1,NETA,NROW,J,STPD,LDSTPD) + +C CHECK DERIVATIVE WRT THE J-TH COLUMN OF DELTA AT ROW NROW + + CALL DJCKM(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,FJACD(NROW,J,LQ), + + DIFFJ,MSGD1,MSGD(2),ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + MSGD(1) = -1 + RETURN + ELSE + DIFF(LQ,NP+J) = DIFFJ + END IF + END IF + + 20 CONTINUE + END IF + 30 CONTINUE + MSGB(1) = MSGB1 + MSGD(1) = MSGD1 + + RETURN + END +*DJCKC + SUBROUTINE DJCKC + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + + FD,TYPJ,PVPSTP,STP0, + + PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DJCKF,DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE +C DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKCRV) +C***END PROLOGUE DJCKC + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,ETA,FD,HC,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO + + double precision guterm + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKF,DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SIGN + +C...DATA STATEMENTS + DATA + + P01,ONE,TWO,TEN + + /0.01D0,1.0D0,2.0D0,10.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE MODEL +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C HC: THE RELATIVE STEP SIZE FOR CENTRAL FINITE DIFFERENCES. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE OF THE MODEL FOR ROW NROW . +C PVMCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV. +C PVPCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV. +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P01: THE VALUE 0.01D0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C STP: A STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C STPCRV: THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL. +C TEN: THE VALUE 10.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TWO: THE VALUE 2.0D0. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DJCKC + + + IF (ISWRTB) THEN + +C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT BETA + + STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STPCRV, + + ISTOP,NFEV,PVPCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STPCRV, + + ISTOP,NFEV,PVMCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + ELSE + +C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT DELTA + + STPCRV = (HC*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STPCRV, + + ISTOP,NFEV,PVPCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STPCRV, + + ISTOP,NFEV,PVMCRV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + END IF + +C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL + + CURVE = ABS((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV) + CURVE = CURVE + + + ETA*(ABS(PVPCRV)+ABS(PVMCRV)+TWO*ABS(PV)) / (STPCRV**2) + + +C CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT. + CALL DJCKF(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,J,LQ,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + IF (MSG(LQ,J).EQ.0) THEN + RETURN + END IF + +C CHECK IF HIGH CURVATURE COULD BE THE PROBLEM. + + STP = TWO*MAX(TOL*ABS(D)/CURVE,EPSMAC) + IF (STP.LT.ABS(TEN*STP0)) THEN + STP = MIN(STP,P01*ABS(STP0)) + END IF + + guterm=STP + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + STP = (STP*SIGN(ONE,BETA(J)) + BETA(J)) - BETA(J) + + if(STP.eq.0.0d0)then + STP=guterm*SIGN(ONE,BETA(J)) + endif + + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + + if(STP.eq.0.0d0)then + STP=guterm*SIGN(ONE,XPLUSD(NROW,J)) + endif + + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + IF (ISTOP.NE.0) THEN + RETURN + END IF + END IF + +C COMPUTE THE NEW NUMERICAL DERIVATIVE + + FD = (PVPSTP-PV)/STP + DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) + +C CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK + IF (ABS(FD-D).LE.TOL*ABS(D)) THEN + MSG(LQ,J) = 0 + +C CHECK IF FINITE PRECISION MAY BE THE CULPRIT (FUDGE FACTOR = 2) + ELSE IF (ABS(STP*(FD-D)).LT.TWO*ETA*(ABS(PV)+ABS(PVPSTP)) + + + CURVE*(EPSMAC*TYPJ)**2) THEN + MSG(LQ,J) = 5 + END IF + + RETURN + END +*DJCKF + SUBROUTINE DJCKF + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,J,LQ,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE +C CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKFPA) +C***END PROLOGUE DJCKF + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + CURVE,D,DIFFJ,ETA,FD,PV,PVPSTP,STP0,TOL,TYPJ + + double precision holder + + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + HUNDRD,ONE,P1,STP,TWO + LOGICAL + + LARGE + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SIGN + +C...DATA STATEMENTS + DATA + + P1,ONE,TWO,HUNDRD + + /0.1D0,1.0D0,2.0D0,100.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C ETA: THE RELATIVE NOISE IN THE MODEL +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C HUNDRD: THE VALUE 100.0D0. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LARGE: THE VALUE DESIGNATING WHETHER THE RECOMMENDED INCREASE IN +C THE STEP SIZE WOULD BE GREATER THAN TYPJ. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FOR ROW NROW . +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P1: THE VALUE 0.1D0. +C STP0: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TOL: THE AGREEMENT TOLERANCE. +C TWO: THE VALUE 2.0D0. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DJCKF + + +C FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM. +C TRY A LARGER STEP SIZE BASED ON ESTIMATE OF CONDITION ERROR + + STP = ETA*(ABS(PV)+ABS(PVPSTP))/(TOL*ABS(D)) + + IF (STP.GT.ABS(P1*STP0)) THEN + STP = MAX(STP,HUNDRD*ABS(STP0)) + END IF + IF (STP.GT.TYPJ) THEN + STP = TYPJ + LARGE = .TRUE. + ELSE + LARGE = .FALSE. + END IF + + holder=STP + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + STP = (STP*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + + if(STP.eq.0.0d0)then + STP=holder*SIGN(ONE,BETA(J)) + endif + + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + + STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + + XPLUSD(NROW,J) + + if(STP.eq.0.0d0)then + STP=holder*SIGN(ONE,XPLUSD(NROW,J)) + endif + + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + FD = (PVPSTP-PV)/STP + + DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) + +C CHECK FOR AGREEMENT + + IF ((ABS(FD-D)).LE.TOL*ABS(D)) THEN +C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE. + MSG(LQ,J) = 0 + + ELSE IF ((ABS(FD-D).LE.ABS(TWO*CURVE*STP)) .OR. LARGE) THEN +C CURVATURE MAY BE THE CULPRIT (FUDGE FACTOR = 2) + IF (LARGE) THEN + MSG(LQ,J) = 4 + ELSE + MSG(LQ,J) = 5 + END IF + END IF + + RETURN + END +*DJCKM + SUBROUTINE DJCKM + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + + ISWRTB,PV,D, + + DIFFJ,MSG1,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKM +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DJCKC,DJCKZ,DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK USER SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL +C DERIVATIVES +C (ADAPTED FROM STARPAC SUBROUTINE DCKMN) +C***END PROLOGUE DJCKM + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,ETA,H0,HC0,PV,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,MSG1,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0, + + TEN,THREE,TOL2,TWO,ZERO + INTEGER + + I + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DJCKC,DJCKZ,DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,SIGN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD + + /0.0D0,0.01D0,0.1D0,1.0D0,2.0D0,3.0D0,1.0D1,1.0D2/ + DATA + + BIG,TOL2 + + /1.0D19,5.0D-2/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BIG: A BIG VALUE, USED TO INITIALIZE DIFFJ. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C H: THE RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C H1: THE DEFAULT RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. +C HC: THE RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HC1: THE DEFAULT RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. +C HUNDRD: THE VALUE 100.0D0. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR DELTAS (ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C MSG1: THE ERROR CHECKING RESULTS SUMMARY. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE JTH +C PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C P01: THE VALUE 0.01D0. +C P1: THE VALUE 0.1D0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C TEN: THE VALUE 10.0D0. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TOL2: A MINIMUM AGREEMENT TOLERANCE. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCKM + + +C CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE +C QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES + + H1 = SQRT(ETA) + HC1 = ETA**(ONE/THREE) + + MSG(LQ,J) = 7 + DIFFJ = BIG + + DO 10 I=1,3 + + IF (I.EQ.1) THEN +C TRY INITIAL RELATIVE STEP SIZE + H = H0 + HC = HC0 + + ELSE IF (I.EQ.2) THEN +C TRY LARGER RELATIVE STEP SIZE + H = MAX(TEN*H1, MIN(HUNDRD*H0, ONE)) + HC = MAX(TEN*HC1,MIN(HUNDRD*HC0,ONE)) + + ELSE IF (I.EQ.3) THEN +C TRY SMALLER RELATIVE STEP SIZE + H = MIN(P1*H1, MAX(P01*H,TWO*EPSMAC)) + HC = MIN(P1*HC1,MAX(P01*HC,TWO*EPSMAC)) + END IF + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + + STP0 = (H*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP0, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + + STP0 = (H*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) + + - XPLUSD(NROW,J) + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP0, + + ISTOP,NFEV,PVPSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + FD = (PVPSTP-PV)/STP0 + +C CHECK FOR AGREEMENT + + IF (ABS(FD-D).LE.TOL*ABS(D)) THEN +C NUMERICAL AND ANALYTIC DERIVATIVES AGREE + +C SET RELATIVE DIFFERENCE FOR DERIVATIVE CHECKING REPORT + IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN + DIFFJ = ABS(FD-D) + ELSE + DIFFJ = ABS(FD-D)/ABS(D) + END IF + +C SET MSG FLAG. + IF (D.EQ.ZERO) THEN + +C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH ZERO. + MSG(LQ,J) = 1 + + ELSE +C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH NONZERO. + MSG(LQ,J) = 0 + END IF + + ELSE + +C NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE. CHECK WHY + IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN + CALL DJCKZ(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,EPSMAC,J,LQ,ISWRTB, + + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + ELSE + CALL DJCKC(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + + FD,TYPJ,PVPSTP,STP0,PV,D, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) + END IF + IF (MSG(LQ,J).LE.2) THEN + GO TO 20 + END IF + END IF + 10 CONTINUE + +C SET SUMMARY FLAG TO INDICATE QUESTIONABLE RESULTS + 20 CONTINUE + IF ((MSG(LQ,J).GE.7) .AND. (DIFFJ.LE.TOL2)) MSG(LQ,J) = 6 + IF ((MSG(LQ,J).GE.1) .AND. (MSG(LQ,J).LE.6)) THEN + MSG1 = MAX(MSG1,1) + ELSE IF (MSG(LQ,J).GE.7) THEN + MSG1 = 2 + END IF + + RETURN + END +*DJCKZ + SUBROUTINE DJCKZ + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,EPSMAC,J,LQ,ISWRTB, + + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + + DIFFJ,MSG,ISTOP,NFEV, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DJCKZ +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPVB,DPVD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE +C DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC +C DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO +C (ADAPTED FROM STARPAC SUBROUTINE DCKZRO) +C***END PROLOGUE DJCKZ + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + D,DIFFJ,EPSMAC,FD,PV,PVPSTP,STP0,TOL,TYPJ + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + LOGICAL + + ISWRTB + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CD,ONE,PVMSTP,THREE,TWO,ZERO + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPVB,DPVD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TWO,THREE + + /0.0D0,1.0D0,2.0D0,3.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CD: THE CENTRAL DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. +C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING +C CHECKED. +C EPSMAC: THE VALUE OF MACHINE PRECISION. +C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA +C (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSG: THE ERROR CHECKING RESULTS. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH +C THE DERIVATIVE IS TO BE CHECKED. +C ONE: THE VALUE 1.0D0. +C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . +C PVMSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) - STP0. +C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL +C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE +C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. +C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C TOL: THE AGREEMENT TOLERANCE. +C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. +C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. +C XPLUSD: THE VALUES OF X + DELTA. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DJCKZ + + +C RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP +C SIZE OF 2*STP0 + + IF (ISWRTB) THEN + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA + + CALL DPVB(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STP0, + + ISTOP,NFEV,PVMSTP, + + WRK1,WRK2,WRK6) + ELSE + +C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA + + CALL DPVD(FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,-STP0, + + ISTOP,NFEV,PVMSTP, + + WRK1,WRK2,WRK6) + END IF + IF (ISTOP.NE.0) THEN + RETURN + END IF + + CD = (PVPSTP-PVMSTP)/(TWO*STP0) + DIFFJ = MIN(ABS(CD-D),ABS(FD-D)) + +C CHECK FOR AGREEMENT + + IF (DIFFJ.LE.TOL*ABS(D)) THEN + +C FINITE DIFFERENCE AND ANALYTIC DERIVATIVES NOW AGREE. + IF (D.EQ.ZERO) THEN + MSG(LQ,J) = 1 + ELSE + MSG(LQ,J) = 0 + END IF + + ELSE IF (DIFFJ*TYPJ.LE.ABS(PV*EPSMAC**(ONE/THREE))) THEN +C DERIVATIVES ARE BOTH CLOSE TO ZERO + MSG(LQ,J) = 2 + + ELSE +C DERIVATIVES ARE NOT BOTH CLOSE TO ZERO + MSG(LQ,J) = 3 + END IF + + RETURN + END +*DODCHK + SUBROUTINE DODCHK + + (N,M,NP,NQ, + + ISODR,ANAJAC,IMPLCT, + + IFIXB, + + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LDY, + + LWORK,LWKMN,LIWORK,LIWKMN, + + SCLB,SCLD,STPB,STPD, + + INFO) +C***BEGIN PROLOGUE DODCHK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING +C NONZERO VALUES OF ARGUMENT INFO +C***END PROLOGUE DODCHK + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWKMN,LIWORK,LWKMN,LWORK,M,N,NP,NQ + LOGICAL + + ANAJAC,IMPLCT,ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M) + INTEGER + + IFIXB(NP) + +C...LOCAL SCALARS + INTEGER + + I,J,K,LAST,NPP + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY X. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUE FOR DELTA. +C STPB: THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT BETA. +C STPD: THE STEP FOR THE FINITE DIFFERENCE DERIVITIVE WRT DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODCHK + + +C FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED + + IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN + NPP = NP + ELSE + NPP = 0 + DO 10 K=1,NP + IF (IFIXB(K).NE.0) THEN + NPP = NPP + 1 + END IF + 10 CONTINUE + END IF + +C CHECK PROBLEM SPECIFICATION PARAMETERS + + IF (N.LE.0 .OR. + + M.LE.0 .OR. + + (NPP.LE.0 .OR. NPP.GT.N) .OR. + + (NQ.LE.0)) THEN + + INFO = 10000 + IF (N.LE.0) THEN + INFO = INFO + 1000 + END IF + IF (M.LE.0) THEN + INFO = INFO + 100 + END IF + IF (NPP.LE.0 .OR. NPP.GT.N) THEN + INFO = INFO + 10 + END IF + IF (NQ.LE.0) THEN + INFO = INFO + 1 + END IF + + RETURN + + END IF + +C CHECK DIMENSION SPECIFICATION PARAMETERS + + IF ((.NOT.IMPLCT .AND. LDY.LT.N) .OR. + + (LDX.LT.N) .OR. + + (LDWE.NE.1 .AND. LDWE.LT.N) .OR. + + (LD2WE.NE.1 .AND. LD2WE.LT.NQ) .OR. + + (ISODR .AND. (LDWD.NE.1 .AND. LDWD.LT.N)) .OR. + + (ISODR .AND. (LD2WD.NE.1 .AND. LD2WD.LT.M)) .OR. + + (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) .OR. + + (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) .OR. + + (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) .OR. + + (LWORK.LT.LWKMN) .OR. + + (LIWORK.LT.LIWKMN)) THEN + + INFO = 20000 + IF (.NOT.IMPLCT .AND. LDY.LT.N) THEN + INFO = INFO + 1000 + END IF + IF (LDX.LT.N) THEN + INFO = INFO + 2000 + END IF + + IF ((LDWE.NE.1 .AND. LDWE.LT.N) .OR. + + (LD2WE.NE.1 .AND. LD2WE.LT.NQ)) THEN + INFO = INFO + 100 + END IF + IF (ISODR .AND. ((LDWD.NE.1 .AND. LDWD.LT.N) .OR. + + (LD2WD.NE.1 .AND. LD2WD.LT.M))) THEN + INFO = INFO + 200 + END IF + + IF (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) THEN + INFO = INFO + 10 + END IF + IF (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) THEN + INFO = INFO + 20 + END IF + IF (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) THEN + INFO = INFO + 40 + END IF + + IF (LWORK.LT.LWKMN) THEN + INFO = INFO + 1 + END IF + IF (LIWORK.LT.LIWKMN) THEN + INFO = INFO + 2 + END IF + RETURN + + END IF + +C CHECK DELTA SCALING + + IF (ISODR .AND. SCLD(1,1).GT.0) THEN + IF (LDSCLD.GE.N) THEN + LAST = N + ELSE + LAST = 1 + END IF + DO 120 J=1,M + DO 110 I=1,LAST + IF (SCLD(I,J).LE.0) THEN + INFO = 30200 + GO TO 130 + END IF + 110 CONTINUE + 120 CONTINUE + END IF + 130 CONTINUE + +C CHECK BETA SCALING + + IF (SCLB(1).GT.0) THEN + DO 210 K=1,NP + IF (SCLB(K).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 30100 + ELSE + INFO = INFO + 100 + END IF + GO TO 220 + END IF + 210 CONTINUE + END IF + 220 CONTINUE + +C CHECK DELTA FINITE DIFFERENCE STEP SIZES + + IF (ANAJAC .AND. ISODR .AND. STPD(1,1).GT.0) THEN + IF (LDSTPD.GE.N) THEN + LAST = N + ELSE + LAST = 1 + END IF + DO 320 J=1,M + DO 310 I=1,LAST + IF (STPD(I,J).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 32000 + ELSE + INFO = INFO + 2000 + END IF + GO TO 330 + END IF + 310 CONTINUE + 320 CONTINUE + END IF + 330 CONTINUE + +C CHECK BETA FINITE DIFFERENCE STEP SIZES + + IF (ANAJAC .AND. STPB(1).GT.0) THEN + DO 410 K=1,NP + IF (STPB(K).LE.0) THEN + IF (INFO.EQ.0) THEN + INFO = 31000 + ELSE + INFO = INFO + 1000 + END IF + GO TO 420 + END IF + 410 CONTINUE + END IF + 420 CONTINUE + + RETURN + END +*DODCNT + SUBROUTINE DODCNT + + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) +C***BEGIN PROLOGUE DODCNT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DODDRV +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING +C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE +C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST +C SQUARES (OLS) SOLUTION +C***END PROLOGUE DODCNT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ + LOGICAL + + SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + CNVTOL,ONE,PCHECK,PFAC,PSTART,THREE,TSTIMP,ZERO + INTEGER + + IPRNTI,IPR1,IPR2,IPR2F,IPR3,JOBI,JOB1,JOB2,JOB3,JOB4,JOB5, + + MAXITI,MAXIT1 + LOGICAL + + DONE,FSTITR,HEAD,IMPLCT,PRTPEN + +C...LOCAL ARRAYS + DOUBLE PRECISION + + PNLTY(1,1,1) + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODDRV + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DMPREC + EXTERNAL + + DMPREC + +C...DATA STATEMENTS + DATA + + PCHECK,PSTART,PFAC,ZERO,ONE,THREE + + /1.0D3,1.0D1,1.0D1,0.0D0,1.0D0,3.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C CNVTOL: THE CONVERGENCE TOLERANCE FOR IMPLICIT MODELS. +C DONE: THE VARIABLE DESIGNATING WHETHER THE INPLICIT SOLUTION HAS +C BEEN FOUND (DONE=TRUE) OR NOT (DONE=FALSE). +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPRINT: THE PRINT CONTROL VARIABLES. +C IPRNTI: THE PRINT CONTROL VARIABLES. +C IPR1: THE 1ST DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR2: THE 2ND DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR3: THE 3RD DIGIT OF THE PRINT CONTROL VARIABLE. +C IPR4: THE 4TH DIGIT OF THE PRINT CONTROL VARIABLE. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOB1: THE 1ST DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB2: THE 2ND DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB3: THE 3RD DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB4: THE 4TH DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C JOB5: THE 5TH DIGIT OF THE VARIABLE CONTROLING PROBLEM +C INITIALIZATION AND COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXITI: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR +C THE CURRENT PENALTY PARAMETER VALUE. +C MAXIT1: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR +C THE NEXT PENALTY PARAMETER VALUE. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C ONE: THE VALUE 1.0D0. +C PARTOL: THE USER SUPPLIED PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PCHECK: THE VALUE DESIGNATING THE MINIMUM PENALTY PARAMETER ALLOWED +C BEFORE THE IMPLICIT PROBLEM CAN BE CONSIDERED SOLVED. +C PFAC: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO BE +C PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C PSTART: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C THREE: THE VALUE 3.0D0. +C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL +C VALUES AND THE SOLUTION. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C X: THE INDEPENDENT VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODCNT + + + IMPLCT = MOD(JOB,10).EQ.1 + FSTITR = .TRUE. + HEAD = .TRUE. + PRTPEN = .FALSE. + + IF (IMPLCT) THEN + +C SET UP FOR IMPLICIT PROBLEM + + IF (IPRINT.GE.0) THEN + IPR1 = MOD(IPRINT,10000)/1000 + IPR2 = MOD(IPRINT,1000)/100 + IPR2F = MOD(IPRINT,100)/10 + IPR3 = MOD(IPRINT,10) + ELSE + IPR1 = 2 + IPR2 = 0 + IPR2F = 0 + IPR3 = 1 + END IF + IPRNTI = IPR1*1000 + IPR2*100 + IPR2F*10 + + JOB5 = MOD(JOB,100000)/10000 + JOB4 = MOD(JOB,10000)/1000 + JOB3 = MOD(JOB,1000)/100 + JOB2 = MOD(JOB,100)/10 + JOB1 = MOD(JOB,10) + JOBI = JOB5*10000 + JOB4*1000 + JOB3*100 + JOB2*10 + JOB1 + + IF (WE(1,1,1).LE.ZERO) THEN + PNLTY(1,1,1) = -PSTART + ELSE + PNLTY(1,1,1) = -WE(1,1,1) + END IF + + IF (PARTOL.LT.ZERO) THEN + CNVTOL = DMPREC()**(ONE/THREE) + ELSE + CNVTOL = MIN(PARTOL,ONE) + END IF + + IF (MAXIT.GE.1) THEN + MAXITI = MAXIT + ELSE + MAXITI = 100 + END IF + + DONE = MAXITI.EQ.0 + PRTPEN = .TRUE. + + 10 CONTINUE + CALL DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + PNLTY,1,1,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOBI,NDIGIT,TAUFAC, SSTOL,CNVTOL,MAXITI, + + IPRNTI,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + MAXIT1,TSTIMP, INFO) + IF (DONE) THEN + RETURN + ELSE + DONE = MAXIT1.LE.0 .OR. + + (ABS(PNLTY(1,1,1)).GE.PCHECK .AND. + + TSTIMP.LE.CNVTOL) + END IF + + IF (DONE) THEN + IF (TSTIMP.LE.CNVTOL) THEN + INFO = (INFO/10)*10 + 2 + ELSE + INFO = (INFO/10)*10 + 4 + END IF + JOBI = 10000 + 1000 + JOB3*100 + JOB2*10 + JOB1 + MAXITI = 0 + IPRNTI = IPR3 + ELSE + PRTPEN = .TRUE. + PNLTY(1,1,1) = PFAC*PNLTY(1,1,1) + JOBI = 10000 + 1000 + 000 + JOB2*10 + JOB1 + MAXITI = MAXIT1 + IPRNTI = 0000 + IPR2*100 + IPR2F*10 + END IF + GO TO 10 + ELSE + CALL DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + MAXIT1,TSTIMP, INFO) + END IF + + RETURN + + END +*DODDRV + SUBROUTINE DODDRV + + (SHORT,HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + MAXIT1,TSTIMP, INFO) +C***BEGIN PROLOGUE DODDRV +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DCOPY_odr,DDOT_odr,DETAF,DFCTRW,DFLAGS, +C DINIWK,DIWINF,DJCK,DNRM2_odr,DODCHK,DODMN, +C DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN +C PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION +C (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) +C***END PROLOGUE DODDRV + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,SSTOL,TAUFAC,TSTIMP + INTEGER + + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,MAXIT1, + + N,NDIGIT,NP,NQ + LOGICAL + + FSTITR,HEAD,PRTPEN,SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + + WE(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),WORK(LWORK), + + X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + EPSMAC,ETA,P5,ONE,TEN,ZERO + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + + DIFFI,EPSMAI,ETAI,FI,FJACBI,FJACDI,FNI,FSI,I,IDFI,INT2I,IPRINI, + + IRANKI,ISTOP,ISTOPI,JOBI,JPVTI,K,LDTT,LDTTI,LIWKMN, + + LUNERI,LUNRPI,LWKMN,LWRK,MAXITI,MSGB,MSGD,NETA,NETAI, + + NFEV,NFEVI,NITERI,NJEV,NJEVI,NNZW,NNZWI,NPP,NPPI,NROW,NROWI, + + NTOL,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,WRK, + + WSSI,WSSDEI,WSSEPI,XPLUSI + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr,DNRM2_odr + EXTERNAL + + DDOT_odr,DNRM2_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY_odr,DETAF,DFCTRW,DFLAGS,DINIWK,DIWINF,DJCK,DODCHK, + + DODMN,DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY + +C...DATA STATEMENTS + DATA + + ZERO,P5,ONE,TEN + + /0.0D0,0.5D0,1.0D0,10.0D0/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT +C (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE +C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY F. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C I: AN INDEX VARIABLE. +C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED +C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C INT2I: THE IN ARRAY IWORK OF VARIABLE INT2. +C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. +C IPRINT: THE PRINT CONTROL VARIABLE. +C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. +C IWORK: THE INTEGER WORK SPACE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. +C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY JPVT. +C K: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LWORK: THE LENGTH OF VECTOR WORK. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MAXIT1: FOR IMPLICIT MODELS, THE ITERATIONS ALLOWED FOR THE NEXT +C PENALTY PARAMETER VALUE. +C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. +C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. +C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. +C N: THE NUMBER OF OBSERVATIONS. +C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS +C SUPPLIED BY THE USER. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. +C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. +C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. +C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. +C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, +C SET BY DJCK. +C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C ONE: THE VALUE 1.0D0. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C P5: THE VALUE 0.5D0. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SCLB: THE SCALING VALUES FOR BETA. +C SCLD: THE SCALING VALUES FOR DELTA. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-CALL +C (SHORT=FALSE). +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. +C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TEN: THE VALUE 10.0D0. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL +C VALUES AND THE SOLUTION. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WRK: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. +C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. +C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. +C X: THE EXPLANATORY VARIABLE. +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODDRV + + +C INITIALIZE NECESSARY VARIABLES + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + +C SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE +C (INVALID VALUES OF M, NP AND/OR NQ ARE HANDLED REASONABLY BY DIWINF) + + CALL DIWINF(M,NP,NQ, + + MSGB,MSGD,JPVTI,ISTOPI, + + NNZWI,NPPI,IDFI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + NROWI,NTOLI,NETAI, + + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + + LIWKMN) + +C SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE +C (INVALID VALUES OF N, M, NP, NQ, LDWE AND/OR LD2WE +C ARE HANDLED REASONABLY BY DWINF) + + CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,FI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) + IF (ISODR) THEN + WRK = WRK1I + LWRK = N*M*NQ + N*NQ + ELSE + WRK = WRK2I + LWRK = N*NQ + END IF + +C UPDATE THE PENALTY PARAMETERS +C (WE(1,1,1) IS NOT A USER SUPPLIED ARRAY IN THIS CASE) + IF (RESTRT .AND. IMPLCT) THEN + WE(1,1,1) = MAX(WORK(WE1I)**2,ABS(WE(1,1,1))) + WORK(WE1I) = -SQRT(ABS(WE(1,1,1))) + END IF + + IF (RESTRT) THEN + +C RESET MAXIMUM NUMBER OF ITERATIONS + + IF (MAXIT.GE.0) THEN + IWORK(MAXITI) = IWORK(NITERI) + MAXIT + ELSE + IWORK(MAXITI) = IWORK(NITERI) + 10 + END IF + + IF (IWORK(NITERI).LT.IWORK(MAXITI)) THEN + INFO = 0 + END IF + + IF (JOB.GE.0) IWORK(JOBI) = JOB + IF (IPRINT.GE.0) IWORK(IPRINI) = IPRINT + IF (PARTOL.GE.ZERO .AND. PARTOL.LT.ONE) WORK(PARTLI) = PARTOL + IF (SSTOL.GE.ZERO .AND. SSTOL.LT.ONE) WORK(SSTOLI) = SSTOL + + WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI) + + IF (IMPLCT) THEN + CALL DCOPY_odr(N*NQ,WORK(FNI),1,WORK(FI),1) + ELSE + CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) + END IF + CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) + WORK(WSSEPI) = DDOT_odr(N*NQ,WORK(FI),1,WORK(FI),1) + WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) + + ELSE + +C PERFORM ERROR CHECKING + + INFO = 0 + + CALL DODCHK(N,M,NP,NQ, + + ISODR,ANAJAC,IMPLCT, + + IFIXB, + + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LDY, + + LWORK,LWKMN,LIWORK,LIWKMN, + + SCLB,SCLD,STPB,STPD, + + INFO) + IF (INFO.GT.0) THEN + GO TO 50 + END IF + +C INITIALIZE WORK VECTORS AS NECESSARY + + DO 10 I=N*M+N*NQ+1,LWORK + WORK(I) = ZERO + 10 CONTINUE + DO 20 I=1,LIWORK + IWORK(I) = 0 + 20 CONTINUE + + CALL DINIWK(N,M,NP, + + WORK,LWORK,IWORK,LIWORK, + + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + + BETA,SCLB, + + SSTOL,PARTOL,MAXIT,TAUFAC, + + JOB,IPRINT,LUNERR,LUNRPT, + + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + + JOBI,IPRINI,LUNERI,LUNRPI, + + SSFI,TTI,LDTTI,DELTAI) + IWORK(MSGB) = -1 + IWORK(MSGD) = -1 + WORK(TAUI) = -WORK(TAUFCI) + +C SET UP FOR PARAMETER ESTIMATION - +C PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES +C AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY + + CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB) + CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB) + NPP = IWORK(NPPI) + +C CHECK THAT WD IS POSITIVE DEFINITE AND WE IS POSITIVE SEMIDEFINITE, +C SAVING FACTORIZATION OF WE, AND COUNTING NUMBER OF NONZERO WEIGHTS + + CALL DFCTRW(N,M,NQ,NPP, + + ISODR, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + WORK(WRK2I),WORK(WRK4I), + + WORK(WE1I),NNZW,INFO) + IWORK(NNZWI) = NNZW + + IF (INFO.NE.0) THEN + GO TO 50 + END IF +C EVALUATE THE PREDICTED VALUES AND +C WEIGHTED EPSILONS AT THE STARTING POINT + CALL DUNPAC(NP,WORK(BETACI),BETA,IFIXB) + CALL DXPY(N,M,X,LDX,WORK(DELTAI),N,WORK(XPLUSI),N) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,WORK(XPLUSI), + + IFIXB,IFIXX,LDIFX, + + 002,WORK(FNI),WORK(WRK6I),WORK(WRK1I), + + ISTOP) + IWORK(ISTOPI) = ISTOP + IF (ISTOP.EQ.0) THEN + IWORK(NFEVI) = IWORK(NFEVI) + 1 + IF (IMPLCT) THEN + CALL DCOPY_odr(N*NQ,WORK(FNI),1,WORK(FI),1) + ELSE + CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) + END IF + CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) + ELSE + INFO = 52000 + GO TO 50 + END IF + +C COMPUTE NORM OF THE INITIAL ESTIMATES + + CALL DWGHT(NPP,1,WORK(SSI),NPP,1,WORK(BETACI),NPP, + + WORK(WRK),NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,WORK(TTI),IWORK(LDTTI),1,WORK(DELTAI),N, + + WORK(WRK+NPP),N) + WORK(PNORMI) = DNRM2_odr(NPP+N*M,WORK(WRK),1) + ELSE + WORK(PNORMI) = DNRM2_odr(NPP,WORK(WRK),1) + END IF + +C COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS + + WORK(WSSEPI) = DDOT_odr(N*NQ,WORK(FI),1,WORK(FI),1) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,WORK(DELTAI),N,WORK(WRK),N) + WORK(WSSDEI) = DDOT_odr(N*M,WORK(DELTAI),1,WORK(WRK),1) + ELSE + WORK(WSSDEI) = ZERO + END IF + WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) + +C SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS + + NROW = -1 + CALL DSETN(N,M,WORK(XPLUSI),N,NROW) + IWORK(NROWI) = NROW + +C SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS + + EPSMAC = WORK(EPSMAI) + IF (NDIGIT.LT.2) THEN + IWORK(NETAI) = -1 + NFEV = IWORK(NFEVI) + CALL DETAF(FCN, + + N,M,NP,NQ, + + WORK(XPLUSI),BETA,EPSMAC,NROW, + + WORK(BETANI),WORK(FNI), + + IFIXB,IFIXX,LDIFX, + + ISTOP,NFEV,ETA,NETA, + + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I),WORK(WRK7I)) + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IF (ISTOP.NE.0) THEN + INFO = 53000 + IWORK(NETAI) = 0 + WORK(ETAI) = ZERO + GO TO 50 + ELSE + IWORK(NETAI) = -NETA + WORK(ETAI) = ETA + END IF + ELSE + IWORK(NETAI) = MIN(NDIGIT,INT(P5-LOG10(EPSMAC))) + WORK(ETAI) = MAX(EPSMAC,TEN**(-NDIGIT)) + END IF + +C CHECK DERIVATIVES IF NECESSARY + + IF (CHKJAC .AND. ANAJAC) THEN + NTOL = -1 + NFEV = IWORK(NFEVI) + NJEV = IWORK(NJEVI) + NETA = IWORK(NETAI) + LDTT = IWORK(LDTTI) + ETA = WORK(ETAI) + EPSMAC = WORK(EPSMAI) + CALL DJCK(FCN, + + N,M,NP,NQ, + + BETA,WORK(XPLUSI), + + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + + WORK(SSFI),WORK(TTI),LDTT, + + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + + WORK(FNI),WORK(FJACBI),WORK(FJACDI), + + IWORK(MSGB),IWORK(MSGD),WORK(DIFFI), + + ISTOP,NFEV,NJEV, + + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I)) + IWORK(ISTOPI) = ISTOP + IWORK(NFEVI) = NFEV + IWORK(NJEVI) = NJEV + IWORK(NTOLI) = NTOL + IF (ISTOP.NE.0) THEN + INFO = 54000 + ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGD).NE.0) THEN + INFO = 40000 + END IF + ELSE + +C INDICATE USER SUPPLIED DERIVATIVES WERE NOT CHECKED + IWORK(MSGB) = -1 + IWORK(MSGD) = -1 + END IF + +C PRINT APPROPRIATE ERROR MESSAGES + + 50 IF ((INFO.NE.0) .OR. (IWORK(MSGB).NE.-1)) THEN + IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN + CALL DODPER + + (INFO,LUNERR,SHORT, + + N,M,NP,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN, + + WORK(FJACBI),WORK(FJACDI), + + WORK(DIFFI),IWORK(MSGB),ISODR,IWORK(MSGD), + + WORK(XPLUSI),IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI)) + END IF + +C SET INFO TO REFLECT ERRORS IN THE USER SUPPLIED JACOBIANS + + IF (INFO.EQ.40000) THEN + IF (IWORK(MSGB).EQ.2 .OR. IWORK(MSGD).EQ.2) THEN + IF (IWORK(MSGB).EQ.2) THEN + INFO = INFO + 1000 + END IF + IF (IWORK(MSGD).EQ.2) THEN + INFO = INFO + 100 + END IF + ELSE + INFO = 0 + END IF + END IF + IF (INFO.NE.0) THEN + RETURN + END IF + END IF + END IF + +C SAVE THE INITIAL VALUES OF BETA + CALL DCOPY_odr(NP,BETA,1,WORK(BETA0I),1) + +C FIND LEAST SQUARES SOLUTION + + CALL DCOPY_odr(N*NQ,WORK(FNI),1,WORK(FSI),1) + LDTT = IWORK(LDTTI) + CALL DODMN(HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + + WE,WORK(WE1I),LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + WORK(BETACI),WORK(BETANI),WORK(BETASI),WORK(SI), + + WORK(DELTAI),WORK(DELTNI),WORK(DELTSI), + + WORK(TI),WORK(FI),WORK(FNI),WORK(FSI), + + WORK(FJACBI),IWORK(MSGB),WORK(FJACDI),IWORK(MSGD), + + WORK(SSFI),WORK(SSI),WORK(TTI),LDTT, + + STPB,STPD,LDSTPD, + + WORK(XPLUSI),WORK(WRK),LWRK, + + WORK,LWORK,IWORK,LIWORK,INFO) + MAXIT1 = IWORK(MAXITI) - IWORK(NITERI) + TSTIMP = ZERO + DO 100 K=1,NP + IF (BETA(K).EQ.ZERO) THEN + TSTIMP = MAX(TSTIMP, + + ABS(BETA(K)-WORK(BETA0I-1+K))/WORK(SSFI-1+K)) + ELSE + TSTIMP = MAX(TSTIMP, + + ABS(BETA(K)-WORK(BETA0I-1+K))/ABS(BETA(K))) + END IF + 100 CONTINUE + + RETURN + + END +*DODLM + SUBROUTINE DODLM + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA2,TAU,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,NLMS,RCOND,IRANK, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODLM +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DDOT_odr,DNRM2_odr,DODSTP,DSCALE,DWGHT +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T +C USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT +C ALGORITHM +C***END PROLOGUE DODLM + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA2,EPSFCN,RCOND,TAU + INTEGER + + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + + WRK(LWRK),WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M) + INTEGER + + JPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO + INTEGER + + I,IWRK,J,K,L + LOGICAL + + FORVCV + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr,DNRM2_odr + EXTERNAL + + DDOT_odr,DNRM2_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODSTP,DSCALE,DWGHT + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MAX,MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P001,P1 + + /0.0D0,0.001D0,0.1D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHAN: THE NEW LEVENBERG-MARQUARDT PARAMETER. +C ALPHA1: THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER. +C ALPHA2: THE CURRENT LEVENBERG-MARQUARDT PARAMETER. +C BOT: THE LOWER LIMIT FOR SETTING ALPHA. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO SOME NUMERICAL ERROR DETECTED WITHIN +C SUBROUTINE DODSTP. +C IWRK: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C JPVT: THE PIVOT VECTOR. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OMEGA: THE ARRAY (I-FJACD*INV(P)*TRANS(FJACD))**(-1/2) WHERE +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C P001: THE VALUE 0.001D0 +C P1: THE VALUE 0.1D0 +C PHI1: THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C PHI2: THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. +C S: THE STEP FOR BETA. +C SA: THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2). +C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. +C T: THE STEP FOR DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TFJACB: THE ARRAY OMEGA*FJACB. +C TOP: THE UPPER LIMIT FOR SETTING ALPHA. +C TT: THE SCALE USED FOR THE DELTA'S. +C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. +C WD: THE DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODLM + + FORVCV = .FALSE. + ISTOPC = 0 + +C COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0) + + ALPHA1 = ZERO + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA1,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,PHI1,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + +C INITIALIZE TAU IF NECESSARY + + IF (TAU.LT.ZERO) THEN + TAU = ABS(TAU)*PHI1 + END IF + +C CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL + + IF ((PHI1-TAU).LE.P1*TAU) THEN + NLMS = 1 + ALPHA2 = ZERO + RETURN + END IF + +C FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION - +C FIND LOCALLY CONSTRAINED OPTIMAL STEP + + PHI1 = PHI1 - TAU + +C INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA + + BOT = ZERO + + DO 30 K=1,NPP + DO 20 L=1,NQ + DO 10 I=1,N + TFJACB(I,L,K) = FJACB(I,K,L) + 10 CONTINUE + 20 CONTINUE + WRK(K) = DDOT_odr(N*NQ,TFJACB(1,1,K),1,F(1,1),1) + 30 CONTINUE + CALL DSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP) + + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(NPP+1),N) + IWRK = NPP + DO 50 J=1,M + DO 40 I=1,N + IWRK = IWRK + 1 + WRK(IWRK) = WRK(IWRK) + + + DDOT_odr(NQ,FJACD(I,J,1),N*M,F(I,1),N) + 40 CONTINUE + 50 CONTINUE + CALL DSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N) + TOP = DNRM2_odr(NPP+N*M,WRK,1)/TAU + ELSE + TOP = DNRM2_odr(NPP,WRK,1)/TAU + END IF + + IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN + ALPHA2 = P001*TOP + END IF + +C MAIN LOOP + + DO 60 I=1,10 + +C COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR +C CURRENT VALUE OF ALPHA + + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA2,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,JPVT, + + S,T,PHI2,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + PHI2 = PHI2-TAU + +C CHECK WHETHER CURRENT STEP IS OPTIMAL + + IF (ABS(PHI2).LE.P1*TAU .OR. + + (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN + NLMS = I+1 + RETURN + END IF + +C CURRENT STEP IS NOT OPTIMAL + +C UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA + + IF (PHI1-PHI2.EQ.ZERO) THEN + NLMS = 12 + RETURN + END IF + SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2) + IF (PHI2.LT.ZERO) THEN + TOP = MIN(TOP,ALPHA2) + ELSE + BOT = MAX(BOT,ALPHA2) + END IF + IF (PHI1*PHI2.GT.ZERO) THEN + BOT = MAX(BOT,ALPHA2-SA) + ELSE + TOP = MIN(TOP,ALPHA2-SA) + END IF + + ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU + IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN + ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT)) + END IF + +C GET READY FOR NEXT ITERATION + + ALPHA1 = ALPHA2 + ALPHA2 = ALPHAN + PHI1 = PHI2 + 60 CONTINUE + +C SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS + + NLMS = 12 + + RETURN + END +*DODMN + SUBROUTINE DODMN + + (HEAD,FSTITR,PRTPEN, + + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + + WE,WE1,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + BETAC,BETAN,BETAS,S,DELTA,DELTAN,DELTAS, + + T,F,FN,FS,FJACB,MSGB,FJACD,MSGD, + + SSF,SS,TT,LDTT,STPB,STPD,LDSTPD, + + XPLUSD,WRK,LWRK,WORK,LWORK,IWORK,LIWORK,INFO) +C***BEGIN PROLOGUE DODMN +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN,DACCES,DCOPY_odr,DDOT_odr,DEVJAC,DFLAGS,DNRM2_odr,DODLM, +C DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE ITERATIVELY COMPUTE LEAST SQUARES SOLUTION +C***END PROLOGUE DODMN + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWORK,LWORK,LWRK,M,N,NP,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP), + + DELTA(N,M),DELTAN(N,M),DELTAS(N,M), + + F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),FS(N,NQ), + + S(NP),SS(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M), + + T(N,M),TT(LDTT,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ), + + WORK(LWORK),X(LDX,M),XPLUSD(N,M),WRK(LWRK),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK), + + MSGB(NQ*NP+1),MSGD(NQ*M+1) + LOGICAL + + FSTITR,HEAD,PRTPEN + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + ACTRED,ACTRS,ALPHA,DIRDER,ETA,OLMAVG,ONE, + + P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS, + + RATIO,RCOND,RNORM,RNORMN,RNORMS,RSS,RVAR,SSTOL,TAU,TAUFAC, + + TEMP,TEMP1,TEMP2,TSNORM,ZERO + INTEGER + + I,IDF,IFLAG,INT2,IPR,IPR1,IPR2,IPR2F,IPR3,IRANK, + + ISTOP,ISTOPC,IWRK,J,JPVT,L,LOOPED,LUDFLT,LUNR,LUNRPT, + + MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW,NPP,NPR,OMEGA,QRAUX, + + SD,U,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 + LOGICAL + + ACCESS,ANAJAC,CDJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV, + + IMPLCT,INITD,INTDBL,ISODR,LSTEP,REDOJ,RESTRT + +C...LOCAL ARRAYS + DOUBLE PRECISION + + WSS(3) + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr,DNRM2_odr + EXTERNAL + + DDOT_odr,DNRM2_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DACCES,DCOPY_odr,DEVJAC,DFLAGS, + + DODLM,DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN,MOD,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,P0001,P1,P25,P5,P75,ONE + + /0.0D0,0.00010D0,0.10D0,0.250D0, + + 0.50D0,0.750D0,1.0D0/ + DATA + + LUDFLT + + /6/ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE +C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN +C THEM (ACCESS=FALSE). +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. +C BETAN: THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. +C BETAS: THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C CNVPAR: THE VARIABLE DESIGNATING WHETHER PARAMETER CONVERGENCE WAS +C ATTAINED (CNVPAR=TRUE) OR NOT (CNVPAR=FALSE). +C CNVSS: THE VARIABLE DESIGNATING WHETHER SUM-OF-SQUARES CONVERGENCE +C WAS ATTAINED (CNVSS=TRUE) OR NOT (CNVSS=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DELTAN: THE NEW ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DELTAS: THE SAVED ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DIRDER: THE DIRECTIONAL DERIVATIVE. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX +C SHOULD TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. +C FS: THE SAVED PREDICTED VALUES FROM THE FUNCTION. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFLAG: THE VARIABLE DESIGNATING WHICH REPORT IS TO BE PRINTED. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN. +C INTDBL: THE VARIABLE DESIGNATING WHETHER INTERNAL DOUBLING IS TO BE +C USED (INTDBL=TRUE) OR NOT (INTDBL=FALSE). +C IPR: THE VALUES DESIGNATING THE LENGTH OF THE PRINTED REPORT. +C IPR1: THE VALUE OF THE 4TH DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE INITIAL SUMMARY REPORT. +C IPR2: THE VALUE OF THE 3RD DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE ITERATION REPORT. +C IPR2F: THE VALUE OF THE 2ND DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. +C IPR3: THE VALUE OF THE 1ST DIGIT (FROM THE RIGHT) OF IPRINT, +C WHICH CONTROLS THE FINAL SUMMARY REPORT. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO SOME NUMERICAL ERROR WITHIN ROUTINE DODSTP. +C IWORK: THE INTEGER WORK SPACE. +C IWRK: AN INDEX VARIABLE. +C J: AN INDEX VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JPVT: THE STARTING LOCATION IN IWORK OF ARRAY JPVT. +C L: AN INDEX VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE AND WE1. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE AND WE1. +C LIWORK: THE LENGTH OF VECTOR IWORK. +C LOOPED: A COUNTER USED TO DETERMINE HOW MANY TIMES THE SUBLOOP +C HAS BEEN EXECUTED, WHERE IF THE COUNT BECOMES LARGE +C ENOUGH THE COMPUTATIONS WILL BE STOPPED. +C LSTEP: THE VARIABLE DESIGNATING WHETHER A SUCCESSFUL STEP HAS +C BEEN FOUND (LSTEP=TRUE) OR NOT (LSTEP=FALSE). +C LUDFLT: THE DEFAULT LOGICAL UNIT NUMBER, USED FOR COMPUTATION +C REPORTS TO THE SCREEN. +C LUNR: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C LWORK: THE LENGTH OF VECTOR WORK. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS TAKEN. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NPR: THE NUMBER OF TIMES THE REPORT IS TO BE WRITTEN. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER +C ITERATION. +C OMEGA: THE STARTING LOCATION IN WORK OF ARRAY OMEGA. +C ONE: THE VALUE 1.0D0. +C P0001: THE VALUE 0.0001D0. +C P1: THE VALUE 0.1D0. +C P25: THE VALUE 0.25D0. +C P5: THE VALUE 0.5D0. +C P75: THE VALUE 0.75D0. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRERS: THE OLD PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO +C BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RATIO: THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED +C RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RNORM: THE NORM OF THE WEIGHTED ERRORS. +C RNORMN: THE NEW NORM OF THE WEIGHTED ERRORS. +C RNORMS: THE SAVED NORM OF THE WEIGHTED ERRORS. +C RSS: THE RESIDUAL SUM OF SQUARES. +C RVAR: THE RESIDUAL VARIANCE. +C S: THE STEP FOR BETA. +C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. +C SSF: THE SCALING VALUES USED FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO EACH BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C T: THE STEP FOR DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TEMP: A TEMPORARY STORAGE LOCATION. +C TEMP1: A TEMPORARY STORAGE LOCATION. +C TEMP2: A TEMPORARY STORAGE LOCATION. +C TSNORM: THE NORM OF THE SCALED STEP. +C TT: THE SCALING VALUES USED FOR DELTA. +C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE: THE EPSILON WEIGHTS. +C WE1: THE SQUARE ROOT OF THE EPSILON WEIGHTS. +C WD: THE DELTA WEIGHTS. +C WORK: THE DOUBLE PRECISION WORK SPACE. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C WRK: A WORK ARRAY, EQUIVALENCED TO WRK1 AND WRK2 +C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C X: THE EXPLANATORY VARIABLE. +C XPLUSD: THE VALUES OF X + DELTA. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODMN + + +C INITIALIZE NECESSARY VARIABLES + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + ACCESS = .TRUE. + CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) + RNORM = SQRT(WSS(1)) + + DIDVCV = .FALSE. + INTDBL = .FALSE. + LSTEP = .TRUE. + +C PRINT INITIAL SUMMARY IF DESIRED + + IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN + IFLAG = 1 + IF (IPR1.GE.3 .AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR1.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR1,2) + END IF + LUNR = LUNRPT + DO 10 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR1.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 10 CONTINUE + + END IF + +C STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION + + IF (RNORM.EQ.ZERO) THEN + INFO = 1 + OLMAVG = ZERO + ISTOP = 0 + GO TO 150 + END IF + +C STOP IF NUMBER OF ITERATIONS ALREADY EQUALS MAXIMUM PERMITTED + + IF (RESTRT .AND. (NITER.GE.MAXIT)) THEN + ISTOP = 0 + GO TO 150 + ELSE IF (NITER.GE.MAXIT) THEN + INFO = 4 + ISTOP = 0 + GO TO 150 + END IF + +C MAIN LOOP + + 100 CONTINUE + + NITER = NITER + 1 + RNORMS = RNORM + LOOPED = 0 + +C EVALUATE JACOBIAN USING BEST ESTIMATE OF FUNCTION (FS) + + IF ((NITER.EQ.1) .AND. (ANAJAC.AND.CHKJAC)) THEN + ISTOP = 0 + ELSE + CALL DEVJAC(FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FS, + + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) + END IF + IF (ISTOP.NE.0) THEN + INFO = 51000 + GO TO 200 + ELSE IF (INFO.EQ.50300) THEN + GO TO 200 + END IF + +C SUB LOOP FOR +C INTERNAL DOUBLING OR +C COMPUTING NEW STEP WHEN OLD FAILED + + 110 CONTINUE + +C COMPUTE STEPS S AND T + + IF (LOOPED.GT.100) THEN + INFO = 60000 + GO TO 200 + ELSE + LOOPED = LOOPED + 1 + CALL DODLM(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA,TAU,ETA,ISODR, + + WORK(WRK6),WORK(OMEGA), + + WORK(U),WORK(QRAUX),IWORK(JPVT), + + S,T,NLMS,RCOND,IRANK, + + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + + WORK(WRK5),WRK,LWRK,ISTOPC) + END IF + IF (ISTOPC.NE.0) THEN + INFO = ISTOPC + GO TO 200 + END IF + OLMAVG = OLMAVG+NLMS + +C COMPUTE BETAN = BETAC + S +C DELTAN = DELTA + T + + CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP) + IF (ISODR) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N) + +C COMPUTE NORM OF SCALED STEPS S AND T (TSNORM) + + CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) + TSNORM = DNRM2_odr(NPP+N*M,WRK,1) + ELSE + TSNORM = DNRM2_odr(NPP,WRK,1) + END IF + +C COMPUTE SCALED PREDICTED REDUCTION + + IWRK = 0 + DO 130 L=1,NQ + DO 120 I=1,N + IWRK = IWRK + 1 + WRK(IWRK) = DDOT_odr(NPP,FJACB(I,1,L),N,S,1) + IF (ISODR) WRK(IWRK) = WRK(IWRK) + + + DDOT_odr(M,FJACD(I,1,L),N,T(I,1),N) + 120 CONTINUE + 130 CONTINUE + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,T,N,WRK(N*NQ+1),N) + TEMP1 = DDOT_odr(N*NQ,WRK,1,WRK,1) + + + DDOT_odr(N*M,T,1,WRK(N*NQ+1),1) + TEMP1 = SQRT(TEMP1)/RNORM + ELSE + TEMP1 = DNRM2_odr(N*NQ,WRK,1)/RNORM + END IF + TEMP2 = SQRT(ALPHA)*TSNORM/RNORM + PRERED = TEMP1**2+TEMP2**2/P5 + + DIRDER = -(TEMP1**2+TEMP2**2) + +C EVALUATE PREDICTED VALUES AT NEW POINT + + CALL DUNPAC(NP,BETAN,BETA,IFIXB) + CALL DXPY(N,M,X,LDX,DELTAN,N,XPLUSD,N) + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 002,FN,WORK(WRK6),WORK(WRK1), + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + END IF + + IF (ISTOP.LT.0) THEN + +C SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FCN + + INFO = 51000 + GO TO 200 + ELSE IF (ISTOP.GT.0) THEN + +C SET NORM TO INDICATE STEP SHOULD BE REJECTED + + RNORMN = RNORM/(P1*P75) + ELSE + +C COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN) + + IF (IMPLCT) THEN + CALL DCOPY_odr(N*NQ,FN,1,WRK,1) + ELSE + CALL DXMY(N,NQ,FN,N,Y,LDY,WRK,N) + END IF + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,WRK,N,WRK,N) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTAN,N,WRK(N*NQ+1),N) + RNORMN = SQRT(DDOT_odr(N*NQ,WRK,1,WRK,1) + + + DDOT_odr(N*M,DELTAN,1,WRK(N*NQ+1),1)) + ELSE + RNORMN = DNRM2_odr(N*NQ,WRK,1) + END IF + END IF + +C COMPUTE SCALED ACTUAL REDUCTION + + IF (P1*RNORMN.LT.RNORM) THEN + ACTRED = ONE - (RNORMN/RNORM)**2 + ELSE + ACTRED = -ONE + END IF + +C COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION + + IF(PRERED .EQ. ZERO) THEN + RATIO = ZERO + ELSE + RATIO = ACTRED/PRERED + END IF + +C CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE + + IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN + ISTOP = 0 + TAU = TAU*P5 + ALPHA = ALPHA/P5 + CALL DCOPY_odr(NPP,BETAS,1,BETAN,1) + CALL DCOPY_odr(N*M,DELTAS,1,DELTAN,1) + CALL DCOPY_odr(N*NQ,FS,1,FN,1) + ACTRED = ACTRS + PRERED = PRERS + RNORMN = RNORMS + RATIO = P5 + END IF + +C UPDATE STEP BOUND + + INTDBL = .FALSE. + IF (RATIO.LT.P25) THEN + IF (ACTRED.GE.ZERO) THEN + TEMP = P5 + ELSE + TEMP = P5*DIRDER/(DIRDER+P5*ACTRED) + END IF + IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN + TEMP = P1 + END IF + TAU = TEMP*MIN(TAU,TSNORM/P1) + ALPHA = ALPHA/TEMP + + ELSE IF (ALPHA.EQ.ZERO) THEN + TAU = TSNORM/P5 + + ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN + +C STEP QUALIFIES FOR INTERNAL DOUBLING +C - UPDATE TAU AND ALPHA +C - SAVE INFORMATION FOR CURRENT POINT + + INTDBL = .TRUE. + + TAU = TSNORM/P5 + ALPHA = ALPHA*P5 + + CALL DCOPY_odr(NPP,BETAN,1,BETAS,1) + CALL DCOPY_odr(N*M,DELTAN,1,DELTAS,1) + CALL DCOPY_odr(N*NQ,FN,1,FS,1) + ACTRS = ACTRED + PRERS = PRERED + RNORMS = RNORMN + END IF + +C IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS + + IF (INTDBL .AND. TAU.GT.ZERO) THEN + INT2 = INT2+1 + GO TO 110 + END IF + +C CHECK ACCEPTANCE + + IF (RATIO.GE.P0001) THEN + CALL DCOPY_odr(N*NQ,FN,1,FS,1) + IF (IMPLCT) THEN + CALL DCOPY_odr(N*NQ,FS,1,F,1) + ELSE + CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) + END IF + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,F,N) + CALL DCOPY_odr(NPP,BETAN,1,BETAC,1) + CALL DCOPY_odr(N*M,DELTAN,1,DELTA,1) + RNORM = RNORMN + CALL DWGHT(NPP,1,SS,NPP,1,BETAC,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,DELTA,N,WRK(NPP+1),N) + PNORM = DNRM2_odr(NPP+N*M,WRK,1) + ELSE + PNORM = DNRM2_odr(NPP,WRK,1) + END IF + LSTEP = .TRUE. + ELSE + LSTEP = .FALSE. + END IF + +C TEST CONVERGENCE + + INFO = 0 + CNVSS = RNORM.EQ.ZERO + + .OR. + + (ABS(ACTRED).LE.SSTOL .AND. + + PRERED.LE.SSTOL .AND. + + P5*RATIO.LE.ONE) + CNVPAR = (TAU.LE.PARTOL*PNORM) .AND. (.NOT.IMPLCT) + IF (CNVSS) INFO = 1 + IF (CNVPAR) INFO = 2 + IF (CNVSS .AND. CNVPAR) INFO = 3 + +C PRINT ITERATION REPORT + + IF (INFO.NE.0 .OR. LSTEP) THEN + IF (IPR2.NE.0 .AND. IPR2F.NE.0 .AND. LUNRPT.NE.0) THEN + IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN + IFLAG = 2 + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + WSS(1) = RNORM*RNORM + IF (IPR2.GE.3. AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR2.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR2,2) + END IF + LUNR = LUNRPT + DO 140 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR2.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 140 CONTINUE + FSTITR = .FALSE. + PRTPEN = .FALSE. + END IF + END IF + END IF + +C CHECK IF FINISHED + + IF (INFO.EQ.0) THEN + IF (LSTEP) THEN + +C BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET + + IF (NITER.GE.MAXIT) THEN + INFO = 4 + ELSE + GO TO 100 + END IF + ELSE + +C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET + + GO TO 110 + END IF + END IF + + 150 CONTINUE + + IF (ISTOP.GT.0) INFO = INFO + 100 + +C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER + + IF (IMPLCT) THEN + CALL DCOPY_odr(N*NQ,FS,1,F,1) + ELSE + CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) + END IF + CALL DUNPAC(NP,BETAC,BETA,IFIXB) + CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) + +C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS +C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED + + IF (DOVCV .AND. ISTOP.EQ.0) THEN + +C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED +C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED +C TO COMPUTE COVARIANCE MATRIX + + IF (REDOJ) THEN + CALL DEVJAC(FCN, + + ANAJAC,CDJAC, + + N,M,NP,NQ, + + BETAC,BETA,STPB, + + IFIXB,IFIXX,LDIFX, + + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + + SSF,TT,LDTT,NETA,FS, + + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + + NJEV,NFEV,ISTOP,INFO) + + + IF (ISTOP.NE.0) THEN + INFO = 51000 + GO TO 200 + ELSE IF (INFO.EQ.50300) THEN + GO TO 200 + END IF + END IF + + IF (IMPLCT) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) + RSS = DDOT_odr(N*M,DELTA,1,WRK(N*NQ+1),1) + ELSE + RSS = RNORM*RNORM + END IF + IF (REDOJ .OR. NITER.GE.1) THEN + CALL DODVCV(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + + ETA,ISODR, + + WORK(VCV),WORK(SD), + + WORK(WRK6),WORK(OMEGA), + + WORK(U),WORK(QRAUX),IWORK(JPVT), + + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + + WORK(WRK5),WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + INFO = ISTOPC + GO TO 200 + END IF + DIDVCV = .TRUE. + END IF + + END IF + +C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS + + 200 DO 210 I=0,NP-1 + WORK(WRK3+I) = IWORK(JPVT+I) + IWORK(JPVT+I) = -2 + 210 CONTINUE + IF (REDOJ .OR. NITER.GE.1) THEN + DO 220 I=0,NPP-1 + J = WORK(WRK3+I) - 1 + IF (I.LE.NPP-IRANK-1) THEN + IWORK(JPVT+J) = 1 + ELSE + IWORK(JPVT+J) = -1 + END IF + 220 CONTINUE + IF (NPP.LT.NP) THEN + J = NPP-1 + DO 230 I=NP-1,0,-1 + IF (IFIXB(I+1).EQ.0) THEN + IWORK(JPVT+I) = 0 + ELSE + IWORK(JPVT+I) = IWORK(JPVT+J) + J = J - 1 + END IF + 230 CONTINUE + END IF + END IF + +C STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER + + IF (NITER.GE.1) THEN + OLMAVG = OLMAVG/NITER + ELSE + OLMAVG = ZERO + END IF + +C COMPUTE WEIGHTED SUMS OF SQUARES FOR RETURN TO USER + + CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,WRK,N) + WSS(3) = DDOT_odr(N*NQ,WRK,1,WRK,1) + IF (ISODR) THEN + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) + WSS(2) = DDOT_odr(N*M,DELTA,1,WRK(N*NQ+1),1) + ELSE + WSS(2) = ZERO + END IF + WSS(1) = WSS(2) + WSS(3) + + ACCESS = .FALSE. + CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + + WORK,LWORK,IWORK,LIWORK, + + ACCESS,ISODR, + + JPVT,OMEGA,U,QRAUX,SD,VCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + + NNZW,NPP, + + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + + WSS,RVAR,IDF, + + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) + +C ENCODE EXISTANCE OF QUESTIONABLE RESULTS INTO INFO + + IF (INFO.LE.9 .OR. INFO.GE.60000) THEN + IF (MSGB(1).EQ.1 .OR. MSGD(1).EQ.1) THEN + INFO = INFO + 1000 + END IF + IF (ISTOP.NE.0) THEN + INFO = INFO + 100 + END IF + IF (IRANK.GE.1) THEN + IF (NPP.GT.IRANK) THEN + INFO = INFO + 10 + ELSE + INFO = INFO + 20 + END IF + END IF + END IF + +C PRINT FINAL SUMMARY + + IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN + IFLAG = 3 + + IF (IPR3.GE.3. AND. LUNRPT.NE.LUDFLT) THEN + NPR = 2 + ELSE + NPR = 1 + END IF + IF (IPR3.GE.6) THEN + IPR = 2 + ELSE + IPR = 2 - MOD(IPR3,2) + END IF + LUNR = LUNRPT + DO 240 I=1,NPR + CALL DODPCR(IPR,LUNR, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IWORK(JPVT),IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,WORK(SD), + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) + IF (IPR3.GE.5) THEN + IPR = 2 + ELSE + IPR = 1 + END IF + LUNR = LUDFLT + 240 CONTINUE + END IF + + RETURN + + END +*DODPC1 + SUBROUTINE DODPC1 + + (IPR,LUNRPT, + + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + + MSGB1,MSGB,MSGD1,MSGD, + + N,M,NP,NQ,NPP,NNZW, + + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + + Y,LDY,WE,LDWE,LD2WE,PNLTY, + + BETA,IFIXB,SSF,STPB, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,WSSDEL,WSSEPS) +C***BEGIN PROLOGUE DODPC1 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DHSTEP +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE INITIAL SUMMARY REPORT +C***END PROLOGUE DODPC1 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PARTOL,PNLTY,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS + INTEGER + + IPR,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LUNRPT,M,MAXIT,MSGB1,MSGD1,N,NETA,NNZW,NP,NPP,NQ + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),SSF(NP),STPB(NP),STPD(LDSTPD,M), + + TT(LDTT,M),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),X(LDX,M), + + Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ,NP),MSGD(NQ,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP1,TEMP2,TEMP3,ZERO + INTEGER + + I,ITEMP,J,JOB1,JOB2,JOB3,JOB4,JOB5,L + +C...LOCAL ARRAYS + CHARACTER TEMPC0*2,TEMPC1*5,TEMPC2*13 + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DHSTEP + EXTERNAL + + DHSTEP + + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,MIN + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD DIFFERENCES +C (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ITEMP: A TEMPORARY INTEGER VALUE. +C J: AN INDEXING VARIABLE. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C JOB1: THE 1ST DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB2: THE 2ND DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB3: THE 3RD DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB4: THE 4TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C JOB5: THE 5TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. +C L: AN INDEXING VARIABLE. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR THE COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C A NEGATIVE VALUE INDICATES THAT NETA WAS ESTIMATED BY +C ODRPACK. A POSITIVE VALUE INDICTES THE VALUE WAS SUPPLIED +C BY THE USER. +C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C SSF: THE SCALING VALUES FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TEMPC0: A TEMPORARY CHARACTER*2 VALUE. +C TEMPC1: A TEMPORARY CHARACTER*5 VALUE. +C TEMPC2: A TEMPORARY CHARACTER*13 VALUE. +C TEMP1: A TEMPORARY DOUBLE PRECISION VALUE. +C TEMP2: A TEMPORARY DOUBLE PRECISION VALUE. +C TEMP3: A TEMPORARY DOUBLE PRECISION VALUE. +C TT: THE SCALING VALUES FOR DELTA. +C WD: THE DELTA WEIGHTS. +C WE: THE EPSILON WEIGHTS. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. +C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C X: THE EXPLANATORY VARIABLE. +C Y: THE RESPONSE VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODPC1 + + +C PRINT PROBLEM SIZE SPECIFICATION + + WRITE (LUNRPT,1000) N,NNZW,NQ,M,NP,NPP + + +C PRINT CONTROL VALUES + + JOB1 = JOB/10000 + JOB2 = MOD(JOB,10000)/1000 + JOB3 = MOD(JOB,1000)/100 + JOB4 = MOD(JOB,100)/10 + JOB5 = MOD(JOB,10) + WRITE (LUNRPT,1100) JOB + IF (RESTRT) THEN + WRITE (LUNRPT,1110) JOB1 + ELSE + WRITE (LUNRPT,1111) JOB1 + END IF + IF (ISODR) THEN + IF (INITD) THEN + WRITE (LUNRPT,1120) JOB2 + ELSE + WRITE (LUNRPT,1121) JOB2 + END IF + ELSE + WRITE (LUNRPT,1122) JOB2,JOB5 + END IF + IF (DOVCV) THEN + WRITE (LUNRPT,1130) JOB3 + IF (REDOJ) THEN + WRITE (LUNRPT,1131) + ELSE + WRITE (LUNRPT,1132) + END IF + ELSE + WRITE (LUNRPT,1133) JOB3 + END IF + IF (ANAJAC) THEN + WRITE (LUNRPT,1140) JOB4 + IF (CHKJAC) THEN + IF (MSGB1.GE.1 .OR. MSGD1.GE.1) THEN + WRITE (LUNRPT,1141) + ELSE + WRITE (LUNRPT,1142) + END IF + ELSE + WRITE (LUNRPT,1143) + END IF + ELSE IF (CDJAC) THEN + WRITE (LUNRPT,1144) JOB4 + ELSE + WRITE (LUNRPT,1145) JOB4 + END IF + IF (ISODR) THEN + IF (IMPLCT) THEN + WRITE (LUNRPT,1150) JOB5 + ELSE + WRITE (LUNRPT,1151) JOB5 + END IF + ELSE + WRITE (LUNRPT,1152) JOB5 + END IF + IF (NETA.LT.0) THEN + WRITE (LUNRPT,1200) -NETA + ELSE + WRITE (LUNRPT,1210) NETA + END IF + WRITE (LUNRPT,1300) TAUFAC + + +C PRINT STOPPING CRITERIA + + WRITE (LUNRPT,1400) SSTOL,PARTOL,MAXIT + + +C PRINT INITIAL SUM OF SQUARES + + IF (IMPLCT) THEN + WRITE (LUNRPT,1500) WSSDEL + IF (ISODR) THEN + WRITE (LUNRPT,1510) WSS,WSSEPS,PNLTY + END IF + ELSE + WRITE (LUNRPT,1600) WSS + IF (ISODR) THEN + WRITE (LUNRPT,1610) WSSDEL,WSSEPS + END IF + END IF + + + IF (IPR.GE.2) THEN + + +C PRINT FUNCTION PARAMETER DATA + + WRITE (LUNRPT,4000) + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + WRITE (LUNRPT,4110) + ELSE IF (ANAJAC) THEN + WRITE (LUNRPT,4120) + ELSE + WRITE (LUNRPT,4200) + END IF + DO 130 J=1,NP + IF (IFIXB(1).LT.0) THEN + TEMPC1 = ' NO' + ELSE + IF (IFIXB(J).NE.0) THEN + TEMPC1 = ' NO' + ELSE + TEMPC1 = ' YES' + END IF + END IF + IF (ANAJAC) THEN + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + ITEMP = -1 + DO 110 L=1,NQ + ITEMP = MAX(ITEMP,MSGB(L,J)) + 110 CONTINUE + IF (ITEMP.LE.-1) THEN + TEMPC2 = ' UNCHECKED' + ELSE IF (ITEMP.EQ.0) THEN + TEMPC2 = ' VERIFIED' + ELSE IF (ITEMP.GE.1) THEN + TEMPC2 = ' QUESTIONABLE' + END IF + ELSE + TEMPC2 = ' ' + END IF + ELSE + TEMPC2 = ' ' + END IF + IF (SSF(1).LT.ZERO) THEN + TEMP1 = ABS(SSF(1)) + ELSE + TEMP1 = SSF(J) + END IF + IF (ANAJAC) THEN + WRITE (LUNRPT,4310) J,BETA(J),TEMPC1,TEMP1,TEMPC2 + ELSE + IF (CDJAC) THEN + TEMP2 = DHSTEP(1,NETA,1,J,STPB,1) + ELSE + TEMP2 = DHSTEP(0,NETA,1,J,STPB,1) + END IF + WRITE (LUNRPT,4320) J,BETA(J),TEMPC1,TEMP1,TEMP2 + END IF + 130 CONTINUE + +C PRINT EXPLANATORY VARIABLE DATA + + IF (ISODR) THEN + WRITE (LUNRPT,2010) + IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN + WRITE (LUNRPT,2110) + ELSE IF (ANAJAC) THEN + WRITE (LUNRPT,2120) + ELSE + WRITE (LUNRPT,2130) + END IF + ELSE + WRITE (LUNRPT,2020) + WRITE (LUNRPT,2140) + END IF + IF (ISODR) THEN + DO 240 J = 1,M + TEMPC0 = '1,' + DO 230 I=1,N,N-1 + + IF (IFIXX(1,1).LT.0) THEN + TEMPC1 = ' NO' + ELSE + IF (LDIFX.EQ.1) THEN + IF (IFIXX(1,J).EQ.0) THEN + TEMPC1 = ' YES' + ELSE + TEMPC1 = ' NO' + END IF + ELSE + IF (IFIXX(I,J).EQ.0) THEN + TEMPC1 = ' YES' + ELSE + TEMPC1 = ' NO' + END IF + END IF + END IF + + IF (TT(1,1).LT.ZERO) THEN + TEMP1 = ABS(TT(1,1)) + ELSE + IF (LDTT.EQ.1) THEN + TEMP1 = TT(1,J) + ELSE + TEMP1 = TT(I,J) + END IF + END IF + + IF (WD(1,1,1).LT.ZERO) THEN + TEMP2 = ABS(WD(1,1,1)) + ELSE + IF (LDWD.EQ.1) THEN + IF (LD2WD.EQ.1) THEN + TEMP2 = WD(1,1,J) + ELSE + TEMP2 = WD(1,J,J) + END IF + ELSE + IF (LD2WD.EQ.1) THEN + TEMP2 = WD(I,1,J) + ELSE + TEMP2 = WD(I,J,J) + END IF + END IF + END IF + + IF (ANAJAC) THEN + IF (CHKJAC .AND. + + (((MSGB1.GE.1) .OR. (MSGD1.GE.1)) .AND. + + (I.EQ.1))) THEN + ITEMP = -1 + DO 210 L=1,NQ + ITEMP = MAX(ITEMP,MSGD(L,J)) + 210 CONTINUE + IF (ITEMP.LE.-1) THEN + TEMPC2 = ' UNCHECKED' + ELSE IF (ITEMP.EQ.0) THEN + TEMPC2 = ' VERIFIED' + ELSE IF (ITEMP.GE.1) THEN + TEMPC2 = ' QUESTIONABLE' + END IF + ELSE + TEMPC2 = ' ' + END IF + IF (M.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 + END IF + ELSE + TEMPC2 = ' ' + IF (CDJAC) THEN + TEMP3 = DHSTEP(1,NETA,I,J,STPD,LDSTPD) + ELSE + TEMP3 = DHSTEP(0,NETA,I,J,STPD,LDSTPD) + END IF + IF (M.LE.9) THEN + WRITE (LUNRPT,5210) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 + ELSE + WRITE (LUNRPT,5220) + + TEMPC0,J,X(I,J), + + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 + END IF + END IF + + TEMPC0 = 'N,' + + 230 CONTINUE + IF (J.LT.M) WRITE (LUNRPT,6000) + 240 CONTINUE + ELSE + + DO 260 J = 1,M + TEMPC0 = '1,' + DO 250 I=1,N,N-1 + IF (M.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,J,X(I,J) + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,J,X(I,J) + END IF + TEMPC0 = 'N,' + 250 CONTINUE + IF (J.LT.M) WRITE (LUNRPT,6000) + 260 CONTINUE + END IF + +C PRINT RESPONSE VARIABLE DATA AND OBSERVATION ERROR WEIGHTS + + IF (.NOT.IMPLCT) THEN + WRITE (LUNRPT,3000) + WRITE (LUNRPT,3100) + DO 310 L=1,NQ + TEMPC0 = '1,' + DO 300 I=1,N,N-1 + IF (WE(1,1,1).LT.ZERO) THEN + TEMP1 = ABS(WE(1,1,1)) + ELSE IF (LDWE.EQ.1) THEN + IF (LD2WE.EQ.1) THEN + TEMP1 = WE(1,1,L) + ELSE + TEMP1 = WE(1,L,L) + END IF + ELSE + IF (LD2WE.EQ.1) THEN + TEMP1 = WE(I,1,L) + ELSE + TEMP1 = WE(I,L,L) + END IF + END IF + IF (NQ.LE.9) THEN + WRITE (LUNRPT,5110) + + TEMPC0,L,Y(I,L),TEMP1 + ELSE + WRITE (LUNRPT,5120) + + TEMPC0,L,Y(I,L),TEMP1 + END IF + TEMPC0 = 'N,' + 300 CONTINUE + IF (L.LT.NQ) WRITE (LUNRPT,6000) + 310 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (/' --- PROBLEM SIZE:'/ + + ' N = ',I5, + + ' (NUMBER WITH NONZERO WEIGHT = ',I5,')'/ + + ' NQ = ',I5/ + + ' M = ',I5/ + + ' NP = ',I5, + + ' (NUMBER UNFIXED = ',I5,')') + 1100 FORMAT + + (/' --- CONTROL VALUES:'/ + + ' JOB = ',I5.5/ + + ' = ABCDE, WHERE') + 1110 FORMAT + + (' A=',I1,' ==> FIT IS A RESTART.') + 1111 FORMAT + + (' A=',I1,' ==> FIT IS NOT A RESTART.') + 1120 FORMAT + + (' B=',I1,' ==> DELTAS ARE INITIALIZED', + + ' TO ZERO.') + 1121 FORMAT + + (' B=',I1,' ==> DELTAS ARE INITIALIZED', + + ' BY USER.') + 1122 FORMAT + + (' B=',I1,' ==> DELTAS ARE FIXED AT', + + ' ZERO SINCE E=',I1,'.') + 1130 FORMAT + + (' C=',I1,' ==> COVARIANCE MATRIX WILL', + + ' BE COMPUTED USING') + 1131 FORMAT + + (' DERIVATIVES RE-', + + 'EVALUATED AT THE SOLUTION.') + 1132 FORMAT + + (' DERIVATIVES FROM THE', + + ' LAST ITERATION.') + 1133 FORMAT + + (' C=',I1,' ==> COVARIANCE MATRIX WILL', + + ' NOT BE COMPUTED.') + 1140 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' SUPPLIED BY USER.') + 1141 FORMAT + + (' DERIVATIVES WERE CHECKED.'/ + + ' RESULTS APPEAR QUESTIONABLE.') + 1142 FORMAT + + (' DERIVATIVES WERE CHECKED.'/ + + ' RESULTS APPEAR CORRECT.') + 1143 FORMAT + + (' DERIVATIVES WERE NOT', + + ' CHECKED.') + 1144 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' ESTIMATED BY CENTRAL', + + ' DIFFERENCES.') + 1145 FORMAT + + (' D=',I1,' ==> DERIVATIVES ARE', + + ' ESTIMATED BY FORWARD', + + ' DIFFERENCES.') + 1150 FORMAT + + (' E=',I1,' ==> METHOD IS IMPLICIT ODR.') + 1151 FORMAT + + (' E=',I1,' ==> METHOD IS EXPLICIT ODR.') + 1152 FORMAT + + (' E=',I1,' ==> METHOD IS EXPLICIT OLS.') + 1200 FORMAT + + (' NDIGIT = ',I5,' (ESTIMATED BY ODRPACK)') + 1210 FORMAT + + (' NDIGIT = ',I5,' (SUPPLIED BY USER)') + 1300 FORMAT + + (' TAUFAC = ',1P,D12.2) + 1400 FORMAT + + (/' --- STOPPING CRITERIA:'/ + + ' SSTOL = ',1P,D12.2, + + ' (SUM OF SQUARES STOPPING TOLERANCE)'/ + + ' PARTOL = ',1P,D12.2, + + ' (PARAMETER STOPPING TOLERANCE)'/ + + ' MAXIT = ',I5, + + ' (MAXIMUM NUMBER OF ITERATIONS)') + 1500 FORMAT + + (/' --- INITIAL SUM OF SQUARED WEIGHTED DELTAS =', + + 17X,1P,D17.8) + 1510 FORMAT + + ( ' INITIAL PENALTY FUNCTION VALUE =',1P,D17.8/ + + ' PENALTY TERM =',1P,D17.8/ + + ' PENALTY PARAMETER =',1P,D10.1) + 1600 FORMAT + + (/' --- INITIAL WEIGHTED SUM OF SQUARES =', + + 17X,1P,D17.8) + 1610 FORMAT + + ( ' SUM OF SQUARED WEIGHTED DELTAS =',1P,D17.8/ + + ' SUM OF SQUARED WEIGHTED EPSILONS =',1P,D17.8) + 2010 FORMAT + + (/' --- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:') + 2020 FORMAT + + (/' --- EXPLANATORY VARIABLE SUMMARY:') + 2110 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT DERIVATIVE'/ + + ' ', + + ' ASSESSMENT'/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) '/) + 2120 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT '/ + + ' ', + + ' '/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) '/) + 2130 FORMAT + + (/' INDEX X(I,J) DELTA(I,J) FIXED', + + ' SCALE WEIGHT DERIVATIVE'/ + + ' ', + + ' STEP SIZE'/, + + ' (I,J) (IFIXX)', + + ' (SCLD) (WD) (STPD)'/) + 2140 FORMAT + + (/' INDEX X(I,J)'/ + + ' (I,J) '/) + 3000 FORMAT + + (/' --- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT', + + ' SUMMARY:') + 3100 FORMAT + + (/' INDEX Y(I,L) WEIGHT'/ + + ' (I,L) (WE)'/) + 4000 FORMAT + + (/' --- FUNCTION PARAMETER SUMMARY:') + 4110 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' DERIVATIVE'/ + + ' ', + + ' ASSESSMENT'/, + + ' (K) (IFIXB) (SCLB)', + + ' '/) + 4120 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' '/ + + ' ', + + ' '/, + + ' (K) (IFIXB) (SCLB)', + + ' '/) + 4200 FORMAT + + (/' INDEX BETA(K) FIXED SCALE', + + ' DERIVATIVE'/ + + ' ', + + ' STEP SIZE'/, + + ' (K) (IFIXB) (SCLB)', + + ' (STPB)'/) + 4310 FORMAT + + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,A13) + 4320 FORMAT + + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,D13.5) + 5110 FORMAT + + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,A13) + 5120 FORMAT + + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,A13) + 5210 FORMAT + + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) + 5220 FORMAT + + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) + 6000 FORMAT + + (' ') + END +*DODPC2 + SUBROUTINE DODPC2 + + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + + PNLTY, + + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) +C***BEGIN PROLOGUE DODPC2 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE GENERATE ITERATION REPORTS +C***END PROLOGUE DODPC2 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRED,ALPHA,PNLTY,PNORM,PRERED,TAU,WSS + INTEGER + + IPR,LUNRPT,NFEV,NITER,NP + LOGICAL + + FSTITR,IMPLCT,PRTPEN + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + RATIO,ZERO + INTEGER + + J,K,L + CHARACTER GN*3 + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C BETA: THE FUNCTION PARAMETERS. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). +C GN: THE CHARACTER*3 VARIABLE INDICATING WHETHER A GAUSS-NEWTON +C STEP WAS TAKEN. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C RATIO: THE RATIO OF TAU TO PNORM. +C TAU: THE TRUST REGION DIAMETER. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODPC2 + + + IF (FSTITR) THEN + IF (IPR.EQ.1) THEN + IF (IMPLCT) THEN + WRITE (LUNRPT,1121) + ELSE + WRITE (LUNRPT,1122) + END IF + ELSE + IF (IMPLCT) THEN + WRITE (LUNRPT,1131) + ELSE + WRITE (LUNRPT,1132) + END IF + END IF + END IF + IF (PRTPEN) THEN + WRITE (LUNRPT,1133) PNLTY + END IF + + IF (ALPHA.EQ.ZERO) THEN + GN = 'YES' + ELSE + GN = ' NO' + END IF + IF (PNORM.NE.ZERO) THEN + RATIO = TAU/PNORM + ELSE + RATIO = ZERO + END IF + IF (IPR.EQ.1) THEN + WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN + ELSE + J = 1 + K = MIN(3,NP) + IF (J.EQ.K) THEN + WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN,J,BETA(J) + ELSE + WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED, + + RATIO,GN,J,K,(BETA(L),L=J,K) + END IF + IF (NP.GT.3) THEN + DO 10 J=4,NP,3 + K = MIN(J+2,NP) + IF (J.EQ.K) THEN + WRITE (LUNRPT,1151) J,BETA(J) + ELSE + WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K) + END IF + 10 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1121 FORMAT + + (// + + ' CUM. PENALTY ACT. REL. PRED. REL.'/ + + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', + + ' G-N'/ + + ' NUM. EVALS VALUE REDUCTION REDUCTION', + + ' TAU/PNORM STEP'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ----') + 1122 FORMAT + + (// + + ' CUM. ACT. REL. PRED. REL.'/ + + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + + ' G-N'/ + + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + + ' TAU/PNORM STEP'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ----'/) + 1131 FORMAT + + (// + + ' CUM. PENALTY ACT. REL. PRED. REL.'/ + + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', + + ' G-N BETA -------------->'/ + + ' NUM. EVALS VALUE REDUCTION REDUCTION', + + ' TAU/PNORM STEP INDEX VALUE'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ---- ----- -----') + 1132 FORMAT + + (// + + ' CUM. ACT. REL. PRED. REL.'/ + + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + + ' G-N BETA -------------->'/ + + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + + ' TAU/PNORM STEP INDEX VALUE'/ + + ' ---- ------ ----------- ----------- -----------', + + ' --------- ---- ----- -----'/) + 1133 FORMAT + + (/' PENALTY PARAMETER VALUE = ', 1P,E10.1) + 1141 FORMAT + + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8) + 1142 FORMAT + + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8) + 1151 FORMAT + + (76X,I3,1P,D16.8) + 1152 FORMAT + + (70X,I3,' TO',I3,1P,3D16.8) + END +*DODPC3 + SUBROUTINE DODPC3 + + (IPR,LUNRPT, + + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + + N,M,NP,NQ,NPP, + + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + + WSS,WSSDEL,WSSEPS,PNLTY,RVAR,IDF, + + BETA,SDBETA,IFIXB2,F,DELTA) +C***BEGIN PROLOGUE DODPC3 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPPT +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE FINAL SUMMARY REPORT +C***END PROLOGUE DODPC3 + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PNLTY,RCOND,RVAR,WSS,WSSDEL,WSSEPS + INTEGER + + IDF,INFO,IPR,IRANK,ISTOP,LUNRPT,M, + + N,NFEV,NITER,NJEV,NP,NPP,NQ + LOGICAL + + ANAJAC,DIDVCV,DOVCV,IMPLCT,ISODR,REDOJ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP) + INTEGER + + IFIXB2(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TVAL + INTEGER + + D1,D2,D3,D4,D5,I,J,K,L,NPLM1 + CHARACTER FMT1*90 + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DPPT + EXTERNAL + + DPPT + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN,MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C D1: THE FIRST DIGIT OF INFO. +C D2: THE SECOND DIGIT OF INFO. +C D3: THE THIRD DIGIT OF INFO. +C D4: THE FOURTH DIGIT OF INFO. +C D5: THE FIFTH DIGIT OF INFO. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C F: THE ESTIMATED VALUES OF EPSILON. +C FMT1: A CHARACTER*90 VARIABLE USED FOR FORMATS. +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB2: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA WERE +C ESTIMATED, FIXED, OR DROPPED BECAUSE THEY CAUSED RANK +C DEFICIENCY, CORRESPONDING TO VALUES OF IFIXB2 EQUALING 1, +C 0, AND -1, RESPECTIVELY. IF IFIXB2 IS -2, THEN NO ATTEMPT +C WAS MADE TO ESTIMATE THE PARAMETERS BECAUSE MAXIT = 0. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C IPR: THE VARIABLE INDICATING WHAT IS TO BE PRINTED. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C L: AN INDEXING VARIABLE. +C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPLM1: THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS +C TO BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE +C MATRIX (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RVAR: THE RESIDUAL VARIANCE. +C SDBETA: THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS. +C TVAL: THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE +C T DISTRIBUTION. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. +C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. +C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. + + +C***FIRST EXECUTABLE STATEMENT DODPC3 + + + D1 = INFO/10000 + D2 = MOD(INFO,10000)/1000 + D3 = MOD(INFO,1000)/100 + D4 = MOD(INFO,100)/10 + D5 = MOD(INFO,10) + +C PRINT STOPPING CONDITIONS + + WRITE (LUNRPT,1000) + IF (INFO.LE.9) THEN + IF (INFO.EQ.1) THEN + WRITE (LUNRPT,1011) INFO + ELSE IF (INFO.EQ.2) THEN + WRITE (LUNRPT,1012) INFO + ELSE IF (INFO.EQ.3) THEN + WRITE (LUNRPT,1013) INFO + ELSE IF (INFO.EQ.4) THEN + WRITE (LUNRPT,1014) INFO + ELSE IF (INFO.LE.9) THEN + WRITE (LUNRPT,1015) INFO + END IF + ELSE IF (INFO.LE.9999) THEN + +C PRINT WARNING DIAGNOSTICS + + WRITE (LUNRPT,1020) INFO + IF (D2.EQ.1) WRITE (LUNRPT,1021) + IF (D3.EQ.1) WRITE (LUNRPT,1022) + IF (D4.EQ.1) WRITE (LUNRPT,1023) + IF (D4.EQ.2) WRITE (LUNRPT,1024) + IF (D5.EQ.1) THEN + WRITE (LUNRPT,1031) + ELSE IF (D5.EQ.2) THEN + WRITE (LUNRPT,1032) + ELSE IF (D5.EQ.3) THEN + WRITE (LUNRPT,1033) + ELSE IF (D5.EQ.4) THEN + WRITE (LUNRPT,1034) + ELSE IF (D5.LE.9) THEN + WRITE (LUNRPT,1035) D5 + END IF + ELSE + +C PRINT ERROR MESSAGES + + WRITE (LUNRPT,1040) INFO + IF (D1.EQ.5) THEN + WRITE (LUNRPT,1042) + IF (D2.NE.0) WRITE (LUNRPT,1043) D2 + IF (D3.EQ.3) THEN + WRITE (LUNRPT,1044) D3 + ELSE IF (D3.NE.0) THEN + WRITE (LUNRPT,1045) D3 + END IF + ELSE IF (D1.EQ.6) THEN + WRITE (LUNRPT,1050) + ELSE + WRITE (LUNRPT,1060) D1 + END IF + END IF + +C PRINT MISC. STOPPING INFO + + WRITE (LUNRPT,1300) NITER + WRITE (LUNRPT,1310) NFEV + IF (ANAJAC) WRITE (LUNRPT,1320) NJEV + WRITE (LUNRPT,1330) IRANK + WRITE (LUNRPT,1340) RCOND + WRITE (LUNRPT,1350) ISTOP + +C PRINT FINAL SUM OF SQUARES + + IF (IMPLCT) THEN + WRITE (LUNRPT,2000) WSSDEL + IF (ISODR) THEN + WRITE (LUNRPT,2010) WSS,WSSEPS,PNLTY + END IF + ELSE + WRITE (LUNRPT,2100) WSS + IF (ISODR) THEN + WRITE (LUNRPT,2110) WSSDEL,WSSEPS + END IF + END IF + IF (DIDVCV) THEN + WRITE (LUNRPT,2200) SQRT(RVAR),IDF + END IF + + NPLM1 = 3 + +C PRINT ESTIMATED BETA'S, AND, +C IF, FULL RANK, THEIR STANDARD ERRORS + + WRITE (LUNRPT,3000) + IF (DIDVCV) THEN + WRITE (LUNRPT,7300) + TVAL = DPPT(0.975D0,IDF) + DO 10 J=1,NP + IF (IFIXB2(J).GE.1) THEN + WRITE (LUNRPT,8400) J,BETA(J),SDBETA(J), + + BETA(J)-TVAL*SDBETA(J), + + BETA(J)+TVAL*SDBETA(J) + ELSE IF (IFIXB2(J).EQ.0) THEN + WRITE (LUNRPT,8600) J,BETA(J) + ELSE + WRITE (LUNRPT,8700) J,BETA(J) + END IF + 10 CONTINUE + IF (.NOT.REDOJ) WRITE (LUNRPT,7310) + ELSE + IF (DOVCV) THEN + IF (D1.LE.5) THEN + WRITE (LUNRPT,7410) + ELSE + WRITE (LUNRPT,7420) + END IF + END IF + + IF ((IRANK.EQ.0 .AND. NPP.EQ.NP) .OR. NITER.EQ.0) THEN + IF (NP.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 20 J=1,NP,NPLM1+1 + K = MIN(J+NPLM1,NP) + IF (K.EQ.J) THEN + WRITE (LUNRPT,8100) J,BETA(J) + ELSE + WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K) + END IF + 20 CONTINUE + IF (NITER.GE.1) THEN + WRITE (LUNRPT,8800) + ELSE + WRITE (LUNRPT,8900) + END IF + ELSE + WRITE (LUNRPT,7500) + DO 30 J=1,NP + IF (IFIXB2(J).GE.1) THEN + WRITE (LUNRPT,8500) J,BETA(J) + ELSE IF (IFIXB2(J).EQ.0) THEN + WRITE (LUNRPT,8600) J,BETA(J) + ELSE + WRITE (LUNRPT,8700) J,BETA(J) + END IF + 30 CONTINUE + END IF + END IF + + IF (IPR.EQ.1) RETURN + + +C PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF +C COLUMNS OF DATA IN EPSILON AND DELTA IS LESS THAN OR EQUAL TO THREE. + + IF (IMPLCT .AND. (M.LE.4)) THEN + WRITE (LUNRPT,4100) + WRITE (FMT1,9110) M + WRITE (LUNRPT,FMT1) (J,J=1,M) + DO 40 I=1,N + WRITE (LUNRPT,4130) I,(DELTA(I,J),J=1,M) + 40 CONTINUE + + ELSE IF (ISODR .AND. (NQ+M.LE.4)) THEN + WRITE (LUNRPT,4110) + WRITE (FMT1,9120) NQ,M + WRITE (LUNRPT,FMT1) (L,L=1,NQ),(J,J=1,M) + DO 50 I=1,N + WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ),(DELTA(I,J),J=1,M) + 50 CONTINUE + + ELSE IF (.NOT.ISODR .AND. ((NQ.GE.2) .AND. (NQ.LE.4))) THEN + WRITE (LUNRPT,4120) + WRITE (FMT1,9130) NQ + WRITE (LUNRPT,FMT1) (L,L=1,NQ) + DO 60 I=1,N + WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ) + 60 CONTINUE + ELSE + +C PRINT EPSILON'S AND DELTA'S SEPARATELY + + IF (.NOT.IMPLCT) THEN + +C PRINT EPSILON'S + + DO 80 J=1,NQ + WRITE (LUNRPT,4200) J + IF (N.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 70 I=1,N,NPLM1+1 + K = MIN(I+NPLM1,N) + IF (I.EQ.K) THEN + WRITE (LUNRPT,8100) I,F(I,J) + ELSE + WRITE (LUNRPT,8200) I,K,(F(L,J),L=I,K) + END IF + 70 CONTINUE + 80 CONTINUE + END IF + +C PRINT DELTA'S + + IF (ISODR) THEN + DO 100 J=1,M + WRITE (LUNRPT,4300) J + IF (N.EQ.1) THEN + WRITE (LUNRPT,7100) + ELSE + WRITE (LUNRPT,7200) + END IF + DO 90 I=1,N,NPLM1+1 + K = MIN(I+NPLM1,N) + IF (I.EQ.K) THEN + WRITE (LUNRPT,8100) I,DELTA(I,J) + ELSE + WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K) + END IF + 90 CONTINUE + 100 CONTINUE + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (/' --- STOPPING CONDITIONS:') + 1011 FORMAT + + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE.') + 1012 FORMAT + + (' INFO = ',I5,' ==> PARAMETER CONVERGENCE.') + 1013 FORMAT + + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE AND', + + ' PARAMETER CONVERGENCE.') + 1014 FORMAT + + (' INFO = ',I5,' ==> ITERATION LIMIT REACHED.') + 1015 FORMAT + + (' INFO = ',I5,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1020 FORMAT + + (' INFO = ',I5.4/ + + ' = ABCD, WHERE A NONZERO VALUE FOR DIGIT A,', + + ' B, OR C INDICATES WHY'/ + + ' THE RESULTS MIGHT BE QUESTIONABLE,', + + ' AND DIGIT D INDICATES'/ + + ' THE ACTUAL STOPPING CONDITION.') + 1021 FORMAT + + (' A=1 ==> DERIVATIVES ARE', + + ' QUESTIONABLE.') + 1022 FORMAT + + (' B=1 ==> USER SET ISTOP TO', + + ' NONZERO VALUE DURING LAST'/ + + ' CALL TO SUBROUTINE FCN.') + 1023 FORMAT + + (' C=1 ==> DERIVATIVES ARE NOT', + + ' FULL RANK AT THE SOLUTION.') + 1024 FORMAT + + (' C=2 ==> DERIVATIVES ARE ZERO', + + ' RANK AT THE SOLUTION.') + 1031 FORMAT + + (' D=1 ==> SUM OF SQUARES CONVERGENCE.') + 1032 FORMAT + + (' D=2 ==> PARAMETER CONVERGENCE.') + 1033 FORMAT + + (' D=3 ==> SUM OF SQUARES CONVERGENCE', + + ' AND PARAMETER CONVERGENCE.') + 1034 FORMAT + + (' D=4 ==> ITERATION LIMIT REACHED.') + 1035 FORMAT + + (' D=',I1,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1040 FORMAT + + (' INFO = ',I5.5/ + + ' = ABCDE, WHERE A NONZERO VALUE FOR A GIVEN', + + ' DIGIT INDICATES AN'/ + + ' ABNORMAL STOPPING CONDITION.') + 1042 FORMAT + + (' A=5 ==> USER STOPPED COMPUTATIONS', + + ' IN SUBROUTINE FCN.') + 1043 FORMAT + + (' B=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED DURING THE'/ + + ' FUNCTION EVALUATION.') + 1044 FORMAT + + (' C=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED BECAUSE'/ + + ' DERIVATIVES WITH', + + ' RESPECT TO DELTA WERE'/ + + ' COMPUTED BY', + + ' SUBROUTINE FCN WHEN'/ + + ' FIT IS OLS.') + 1045 FORMAT + + (' C=',I1,' ==> COMPUTATIONS WERE', + + ' STOPPED DURING THE'/ + + ' JACOBIAN EVALUATION.') + 1050 FORMAT + + (' A=6 ==> NUMERICAL INSTABILITIES', + + ' HAVE BEEN DETECTED,'/ + + ' POSSIBLY INDICATING', + + ' A DISCONTINUITY IN THE'/ + + ' DERIVATIVES OR A POOR', + + ' POOR CHOICE OF PROBLEM'/ + + ' SCALE OR WEIGHTS.') + 1060 FORMAT + + (' A=',I1,' ==> UNEXPECTED VALUE,', + + ' PROBABLY INDICATING'/ + + ' INCORRECTLY SPECIFIED', + + ' USER INPUT.') + 1300 FORMAT + + (' NITER = ',I5, + + ' (NUMBER OF ITERATIONS)') + 1310 FORMAT + + (' NFEV = ',I5, + + ' (NUMBER OF FUNCTION EVALUATIONS)') + 1320 FORMAT + + (' NJEV = ',I5, + + ' (NUMBER OF JACOBIAN EVALUATIONS)') + 1330 FORMAT + + (' IRANK = ',I5, + + ' (RANK DEFICIENCY)') + 1340 FORMAT + + (' RCOND = ',1P,D12.2, + + ' (INVERSE CONDITION NUMBER)') +*1341 FORMAT +* + (' ==> POSSIBLY FEWER THAN 2 SIGNIFICANT', +* + ' DIGITS IN RESULTS;'/ +* + ' SEE ODRPACK REFERENCE', +* + ' GUIDE, SECTION 4.C.') + 1350 FORMAT + + (' ISTOP = ',I5, + + ' (RETURNED BY USER FROM', + + ' SUBROUTINE FCN)') + 2000 FORMAT + + (/' --- FINAL SUM OF SQUARED WEIGHTED DELTAS = ', + + 17X,1P,D17.8) + 2010 FORMAT + + ( ' FINAL PENALTY FUNCTION VALUE = ',1P,D17.8/ + + ' PENALTY TERM = ',1P,D17.8/ + + ' PENALTY PARAMETER = ',1P,D10.1) + 2100 FORMAT + + (/' --- FINAL WEIGHTED SUMS OF SQUARES = ',17X,1P,D17.8) + 2110 FORMAT + + ( ' SUM OF SQUARED WEIGHTED DELTAS = ',1P,D17.8/ + + ' SUM OF SQUARED WEIGHTED EPSILONS = ',1P,D17.8) + 2200 FORMAT + + (/' --- RESIDUAL STANDARD DEVIATION = ', + + 17X,1P,D17.8/ + + ' DEGREES OF FREEDOM =',I5) + 3000 FORMAT + + (/' --- ESTIMATED BETA(J), J = 1, ..., NP:') + 4100 FORMAT + + (/' --- ESTIMATED DELTA(I,*), I = 1, ..., N:') + 4110 FORMAT + + (/' --- ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:') + 4120 FORMAT + + (/' --- ESTIMATED EPSILON(I), I = 1, ..., N:') + 4130 FORMAT(5X,I5,1P,5D16.8) + 4200 FORMAT + + (/' --- ESTIMATED EPSILON(I,',I3,'), I = 1, ..., N:') + 4300 FORMAT + + (/' --- ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:') + 7100 FORMAT + + (/' INDEX VALUE'/) + 7200 FORMAT + + (/' INDEX VALUE -------------->'/) + 7300 FORMAT + + (/' BETA S.D. BETA', + + ' ---- 95% CONFIDENCE INTERVAL ----'/) + 7310 FORMAT + + (/' N.B. STANDARD ERRORS AND CONFIDENCE INTERVALS ARE', + + ' COMPUTED USING'/ + + ' DERIVATIVES CALCULATED AT THE BEGINNING', + + ' OF THE LAST ITERATION,'/ + + ' AND NOT USING DERIVATIVES RE-EVALUATED AT THE', + + ' FINAL SOLUTION.') + 7410 FORMAT + + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', + + ' NOT COMPUTED BECAUSE'/ + + ' THE DERIVATIVES WERE NOT AVAILABLE. EITHER MAXIT', + + ' IS 0 AND THE THIRD'/ + + ' DIGIT OF JOB IS GREATER THAN 1, OR THE MOST', + + ' RECENTLY TRIED VALUES OF'/ + + ' BETA AND/OR X+DELTA WERE IDENTIFIED AS', + + ' UNACCEPTABLE BY USER SUPPLIED'/ + + ' SUBROUTINE FCN.') + 7420 FORMAT + + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', + + ' NOT COMPUTED.'/ + + ' (SEE INFO ABOVE.)') + 7500 FORMAT + + (/' BETA STATUS') + 8100 FORMAT + + (11X,I5,1P,D16.8) + 8200 FORMAT + + (3X,I5,' TO',I5,1P,7D16.8) + 8400 FORMAT + + (3X,I5,1X,1P,D16.8,3X,D12.4,3X,D16.8,1X,'TO',D16.8) + 8500 FORMAT + + (3X,I5,1X,1P,D16.8,6X,'ESTIMATED') + 8600 FORMAT + + (3X,I5,1X,1P,D16.8,6X,' FIXED') + 8700 FORMAT + + (3X,I5,1X,1P,D16.8,6X,' DROPPED') + 8800 FORMAT + + (/' N.B. NO PARAMETERS WERE FIXED BY THE USER OR', + + ' DROPPED AT THE LAST'/ + + ' ITERATION BECAUSE THEY CAUSED THE MODEL TO BE', + + ' RANK DEFICIENT.') + 8900 FORMAT + + (/' N.B. NO CHANGE WAS MADE TO THE USER SUPPLIED PARAMETER', + + ' VALUES BECAUSE'/ + + ' MAXIT=0.') + 9110 FORMAT + + ('(/'' I'',', + + I2,'('' DELTA(I,'',I1,'')'')/)') + 9120 FORMAT + + ('(/'' I'',', + + I2,'('' EPSILON(I,'',I1,'')''),', + + I2,'('' DELTA(I,'',I1,'')'')/)') + 9130 FORMAT + + ('(/'' I'',', + + I2,'('' EPSILON(I,'',I1,'')'')/)') + + END +*DODPCR + SUBROUTINE DODPCR + + (IPR,LUNRPT, + + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + + N,M,NP,NQ,NPP,NNZW, + + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + SSF,TT,LDTT,STPB,STPD,LDSTPD, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS,RVAR,IDF,SDBETA, + + NITER,NFEV,NJEV,ACTRED,PRERED, + + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) +C***BEGIN PROLOGUE DODPCR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE COMPUTATION REPORTS +C***END PROLOGUE DODPCR + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR, + + SSTOL,TAU,TAUFAC + INTEGER + + IDF,IFLAG,INFO,IPR,IRANK,ISTOP,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE, + + LDX,LDY,LD2WD,LD2WE,LUNRPT,M,MAXIT,N,NETA,NFEV, + + NITER,NJEV,NNZW,NP,NPP,NQ + LOGICAL + + DIDVCV,FSTITR,HEAD,PRTPEN + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP),SSF(NP), + + STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WSS(3),X(LDX,M),Y(LDY,NQ) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ*NP+1),MSGD(NQ*M+1) + +C...LOCAL SCALARS + DOUBLE PRECISION + + PNLTY + LOGICAL + + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT + CHARACTER TYP*3 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). +C BETA: THE FUNCTION PARAMETERS. +C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED +C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD +C DIFFERENCES (CDJAC=FALSE). +C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED +C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT +C (CHKJAC=FALSE). +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS +C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). +C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS +C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST +C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFLAG: THE VARIABLE DESIGNATING WHAT IS TO BE PRINTED. +C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY +C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO +C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M +C ELEMENTS OF ARRAY WORK (INITD=FALSE). +C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C JOB: THE VARIABLE CONTROLING PROBLEM INITIALIZATION AND +C COMPUTATIONAL METHOD. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NITER: THE NUMBER OF ITERATIONS. +C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. +C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. +C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. +C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. +C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. +C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS +C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT +C (PRTPEN=FALSE). +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. +C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO +C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX +C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). +C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART +C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). +C RVAR: THE RESIDUAL VARIANCE. +C SDBETA: THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S. +C SSF: THE SCALING VALUES FOR BETA. +C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. +C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO BETA. +C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE +C DERIVATIVES WITH RESPECT TO DELTA. +C TAU: THE TRUST REGION DIAMETER. +C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION +C DIAMETER. +C TT: THE SCALING VALUES FOR DELTA. +C TYP: THE CHARACTER*3 STRING "ODR" OR "OLS". +C WE: THE EPSILON WEIGHTS. +C WD: THE DELTA WEIGHTS. +C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, +C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND +C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. +C X: THE EXPLANATORY VARIABLE. +C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. + + +C***FIRST EXECUTABLE STATEMENT DODPCR + + + CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) + PNLTY = ABS(WE(1,1,1)) + + IF (HEAD) THEN + CALL DODPHD(HEAD,LUNRPT) + END IF + IF (ISODR) THEN + TYP = 'ODR' + ELSE + TYP = 'OLS' + END IF + +C PRINT INITIAL SUMMARY + + IF (IFLAG.EQ.1) THEN + WRITE (LUNRPT,1200) TYP + CALL DODPC1 + + (IPR,LUNRPT, + + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + + MSGB(1),MSGB(2),MSGD(1),MSGD(2), + + N,M,NP,NQ,NPP,NNZW, + + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + + Y,LDY,WE,LDWE,LD2WE,PNLTY, + + BETA,IFIXB,SSF,STPB, + + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + + WSS(1),WSS(2),WSS(3)) + +C PRINT ITERATION REPORTS + + ELSE IF (IFLAG.EQ.2) THEN + + IF (FSTITR) THEN + WRITE (LUNRPT,1300) TYP + END IF + CALL DODPC2 + + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + + PNLTY, + + NITER,NFEV,WSS(1),ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) + +C PRINT FINAL SUMMARY + + ELSE IF (IFLAG.EQ.3) THEN + + WRITE (LUNRPT,1400) TYP + CALL DODPC3 + + (IPR,LUNRPT, + + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + + N,M,NP,NQ,NPP, + + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + + WSS(1),WSS(2),WSS(3),PNLTY,RVAR,IDF, + + BETA,SDBETA,IFIXB,F,DELTA) + END IF + + RETURN + +C FORMAT STATEMENTS + + 1200 FORMAT + + (/' *** INITIAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') + 1300 FORMAT + + (/' *** ITERATION REPORTS FOR FIT BY METHOD OF ',A3, ' ***') + 1400 FORMAT + + (/' *** FINAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') + + END +*DODPE1 + SUBROUTINE DODPE1 + + (UNIT,D1,D2,D3,D4,D5, + + N,M,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN) +C***BEGIN PROLOGUE DODPE1 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ERROR REPORTS +C***END PROLOGUE DODPE1 + +C...SCALAR ARGUMENTS + INTEGER + + D1,D2,D3,D4,D5,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE, + + LIWKMN,LWKMN,M,N,NQ,UNIT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. +C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. + + +C***FIRST EXECUTABLE STATEMENT DODPE1 + + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION +C PARAMETERS + + IF (D1.EQ.1) THEN + IF (D2.NE.0) THEN + WRITE(UNIT,1100) + END IF + IF (D3.NE.0) THEN + WRITE(UNIT,1200) + END IF + IF (D4.NE.0) THEN + WRITE(UNIT,1300) + END IF + IF (D5.NE.0) THEN + WRITE(UNIT,1400) + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION +C PARAMETERS + + ELSE IF (D1.EQ.2) THEN + + IF (D2.NE.0) THEN + IF (D2.EQ.1 .OR. D2.EQ.3) THEN + WRITE(UNIT,2110) + END IF + IF (D2.EQ.2 .OR. D2.EQ.3) THEN + WRITE(UNIT,2120) + END IF + END IF + + IF (D3.NE.0) THEN + IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN + WRITE(UNIT,2210) + END IF + IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN + WRITE(UNIT,2220) + END IF + IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN + WRITE(UNIT,2230) + END IF + END IF + + IF (D4.NE.0) THEN + IF (D4.EQ.1 .OR. D4.EQ.3) THEN + WRITE(UNIT,2310) + END IF + IF (D4.EQ.2 .OR. D4.EQ.3) THEN + WRITE(UNIT,2320) + END IF + END IF + + IF (D5.NE.0) THEN + IF (D5.EQ.1 .OR. D5.EQ.3) THEN + WRITE(UNIT,2410) LWKMN + END IF + IF (D5.EQ.2 .OR. D5.EQ.3) THEN + WRITE(UNIT,2420) LIWKMN + END IF + END IF + + ELSE IF (D1.EQ.3) THEN + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN SCALE VALUES + + IF (D2.NE.0) THEN + IF (D2.EQ.1 .OR. D2.EQ.3) THEN + IF (LDSCLD.GE.N) THEN + WRITE(UNIT,3110) + ELSE + WRITE(UNIT,3120) + END IF + END IF + IF (D2.EQ.2 .OR. D2.EQ.3) THEN + WRITE(UNIT,3130) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DERIVATIVE STEP VALUES + + IF (D3.NE.0) THEN + IF (D3.EQ.1 .OR. D3.EQ.3) THEN + IF (LDSTPD.GE.N) THEN + WRITE(UNIT,3210) + ELSE + WRITE(UNIT,3220) + END IF + END IF + IF (D3.EQ.2 .OR. D3.EQ.3) THEN + WRITE(UNIT,3230) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS + + IF (D4.NE.0) THEN + IF (D4.EQ.1) THEN + IF (LDWE.GE.N) THEN + IF (LD2WE.GE.NQ) THEN + WRITE(UNIT,3310) + ELSE + WRITE(UNIT,3320) + END IF + ELSE + IF (LD2WE.GE.NQ) THEN + WRITE(UNIT,3410) + ELSE + WRITE(UNIT,3420) + END IF + END IF + END IF + IF (D4.EQ.2) THEN + WRITE(UNIT,3500) + END IF + END IF + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS + + IF (D5.NE.0) THEN + IF (LDWD.GE.N) THEN + IF (LD2WD.GE.M) THEN + WRITE(UNIT,4310) + ELSE + WRITE(UNIT,4320) + END IF + ELSE + IF (LD2WD.GE.M) THEN + WRITE(UNIT,4410) + ELSE + WRITE(UNIT,4420) + END IF + END IF + END IF + + END IF + +C FORMAT STATEMENTS + + 1100 FORMAT + + (/' ERROR : N IS LESS THAN ONE.') + 1200 FORMAT + + (/' ERROR : M IS LESS THAN ONE.') + 1300 FORMAT + + (/' ERROR : NP IS LESS THAN ONE'/ + + ' OR NP IS GREATER THAN N.') + 1400 FORMAT + + (/' ERROR : NQ IS LESS THAN ONE.') + 2110 FORMAT + + (/' ERROR : LDX IS LESS THAN N.') + 2120 FORMAT + + (/' ERROR : LDY IS LESS THAN N.') + 2210 FORMAT + + (/' ERROR : LDIFX IS LESS THAN N'/ + + ' AND LDIFX IS NOT EQUAL TO ONE.') + 2220 FORMAT + + (/' ERROR : LDSCLD IS LESS THAN N'/ + + ' AND LDSCLD IS NOT EQUAL TO ONE.') + 2230 FORMAT + + (/' ERROR : LDSTPD IS LESS THAN N'/ + + ' AND LDSTPD IS NOT EQUAL TO ONE.') + 2310 FORMAT + + (/' ERROR : LDWE IS LESS THAN N'/ + + ' AND LDWE IS NOT EQUAL TO ONE OR'/ + + ' OR'/ + + ' LD2WE IS LESS THAN NQ'/ + + ' AND LD2WE IS NOT EQUAL TO ONE.') + 2320 FORMAT + + (/' ERROR : LDWD IS LESS THAN N'/ + + ' AND LDWD IS NOT EQUAL TO ONE.') + 2410 FORMAT + + (/' ERROR : LWORK IS LESS THAN ',I7, ','/ + + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.') + 2420 FORMAT + + (/' ERROR : LIWORK IS LESS THAN ',I7, ','/ + + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY', + + ' IWORK.') + 3110 FORMAT + + (/' ERROR : SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN'/ + + ' EACH OF THE N BY M ELEMENTS OF'/ + + ' SCLD MUST BE GREATER THAN ZERO.') + 3120 FORMAT + + (/' ERROR : SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME J = 1, ..., M.'// + + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSCLD IS EQUAL TO ONE THEN'/ + + ' EACH OF THE 1 BY M ELEMENTS OF'/ + + ' SCLD MUST BE GREATER THAN ZERO.') + 3130 FORMAT + + (/' ERROR : SCLB(K) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME K = 1, ..., NP.'// + + ' ALL NP ELEMENTS OF', + + ' SCLB MUST BE GREATER THAN ZERO.') + 3210 FORMAT + + (/' ERROR : STPD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSTPD IS GREATER THAN OR EQUAL TO N THEN'/ + + ' EACH OF THE N BY M ELEMENTS OF'/ + + ' STPD MUST BE GREATER THAN ZERO.') + 3220 FORMAT + + (/' ERROR : STPD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME J = 1, ..., M.'// + + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ + + ' AND LDSTPD IS EQUAL TO ONE THEN'/ + + ' EACH OF THE 1 BY M ELEMENTS OF'/ + + ' STPD MUST BE GREATER THAN ZERO.') + 3230 FORMAT + + (/' ERROR : STPB(K) IS LESS THAN OR EQUAL TO ZERO'/ + + ' FOR SOME K = 1, ..., NP.'// + + ' ALL NP ELEMENTS OF', + + ' STPB MUST BE GREATER THAN ZERO.') + 3310 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (NQ BY NQ) ARRAYS STARTING'/ + + ' IN WE(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ + + ' SEMIDEFINITE. WHEN WE(1,1,1) IS GREATER THAN'/ + + ' OR EQUAL TO ZERO, AND LDWE IS GREATER THAN OR'/ + + ' EQUAL TO N, AND LD2WE IS GREATER THAN OR EQUAL'/ + + ' TO NQ, THEN EACH OF THE (NQ BY NQ) ARRAYS IN WE'/ + + ' MUST BE POSITIVE SEMIDEFINITE.') + 3320 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (1 BY NQ) ARRAYS STARTING'/ + + ' IN WE(I,1,1), I = 1, ..., N, HAS A NEGATIVE'/ + + ' ELEMENT. WHEN WE(1,1,1) IS GREATER THAN OR'/ + + ' EQUAL TO ZERO, AND LDWE IS GREATER THAN OR EQUAL'/ + + ' TO N, AND LD2WE IS EQUAL TO 1, THEN EACH OF THE'/ + + ' (1 BY NQ) ARRAYS IN WE MUST HAVE ONLY NON-'/ + + ' NEGATIVE ELEMENTS.') + 3410 FORMAT + + (/' ERROR : THE (NQ BY NQ) ARRAY STARTING IN WE(1,1,1) IS'/ + + ' NOT POSITIVE SEMIDEFINITE. WHEN WE(1,1,1) IS'/ + + ' GREATER THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL'/ + + ' TO 1, AND LD2WE IS GREATER THAN OR EQUAL TO NQ,'/ + + ' THEN THE (NQ BY NQ) ARRAY IN WE MUST BE POSITIVE'/ + + ' SEMIDEFINITE.') + 3420 FORMAT + + (/' ERROR : THE (1 BY NQ) ARRAY STARTING IN WE(1,1,1) HAS'/ + + ' A NEGATIVE ELEMENT. WHEN WE(1,1,1) IS GREATER'/ + + ' THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL TO 1,'/ + + ' AND LD2WE IS EQUAL TO 1, THEN THE (1 BY NQ)'/ + + ' ARRAY IN WE MUST HAVE ONLY NONNEGATIVE ELEMENTS.') + 3500 FORMAT + + (/' ERROR : THE NUMBER OF NONZERO ARRAYS IN ARRAY WE IS'/ + + ' LESS THAN NP.') + 4310 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (M BY M) ARRAYS STARTING'/ + + ' IN WD(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ + + ' DEFINITE. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ + + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ + + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN EACH'/ + + ' OF THE (M BY M) ARRAYS IN WD MUST BE POSITIVE'/ + + ' DEFINITE.') + 4320 FORMAT + + (/' ERROR : AT LEAST ONE OF THE (1 BY M) ARRAYS STARTING'/ + + ' IN WD(I,1,1), I = 1, ..., N, HAS A NONPOSITIVE'/ + + ' ELEMENT. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ + + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ + + ' LD2WD IS EQUAL TO 1, THEN EACH OF THE (1 BY M)'/ + + ' ARRAYS IN WD MUST HAVE ONLY POSITIVE ELEMENTS.') + 4410 FORMAT + + (/' ERROR : THE (M BY M) ARRAY STARTING IN WD(1,1,1) IS'/ + + ' NOT POSITIVE DEFINITE. WHEN WD(1,1,1) IS'/ + + ' GREATER THAN ZERO, AND LDWD IS EQUAL TO 1, AND'/ + + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN THE'/ + + ' (M BY M) ARRAY IN WD MUST BE POSITIVE DEFINITE.') + 4420 FORMAT + + (/' ERROR : THE (1 BY M) ARRAY STARTING IN WD(1,1,1) HAS A'/ + + ' NONPOSITIVE ELEMENT. WHEN WD(1,1,1) IS GREATER'/ + + ' THAN ZERO, AND LDWD IS EQUAL TO 1, AND LD2WD IS'/ + + ' EQUAL TO 1, THEN THE (1 BY M) ARRAY IN WD MUST'/ + + ' HAVE ONLY POSITIVE ELEMENTS.') + END +*DODPE2 + SUBROUTINE DODPE2 + + (UNIT, + + N,M,NP,NQ, + + FJACB,FJACD, + + DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD, + + XPLUSD,NROW,NETA,NTOL) +C***BEGIN PROLOGUE DODPE2 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE GENERATE THE DERIVATIVE CHECKING REPORT +C***END PROLOGUE DODPE2 + +C...SCALAR ARGUMENTS + INTEGER + + M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) + INTEGER + + MSGB(NQ,NP),MSGD(NQ,M) + +C...LOCAL SCALARS + INTEGER + + I,J,K,L + CHARACTER FLAG*1,TYP*3 + +C...LOCAL ARRAYS + LOGICAL + + FTNOTE(0:7) + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FLAG: THE CHARACTER STRING INDICATING HIGHLY QUESTIONABLE RESULTS. +C FTNOTE: THE ARRAY CONTROLING FOOTNOTES. +C I: AN INDEX VARIABLE. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C J: AN INDEX VARIABLE. +C K: AN INDEX VARIABLE. +C L: AN INDEX VARIABLE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. +C TYP: THE CHARACTER STRING INDICATING SOLUTION TYPE, ODR OR OLS. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODPE2 + + +C SET UP FOR FOOTNOTES + + DO 10 I=0,7 + FTNOTE(I) = .FALSE. + 10 CONTINUE + + DO 40 L=1,NQ + IF (MSGB1.GE.1) THEN + DO 20 I=1,NP + IF (MSGB(L,I).GE.1) THEN + FTNOTE(0) = .TRUE. + FTNOTE(MSGB(L,I)) = .TRUE. + END IF + 20 CONTINUE + END IF + + IF (MSGD1.GE.1) THEN + DO 30 I=1,M + IF (MSGD(L,I).GE.1) THEN + FTNOTE(0) = .TRUE. + FTNOTE(MSGD(L,I)) = .TRUE. + END IF + 30 CONTINUE + END IF + 40 CONTINUE + +C PRINT REPORT + + IF (ISODR) THEN + TYP = 'ODR' + ELSE + TYP = 'OLS' + END IF + WRITE (UNIT,1000) TYP + + DO 70 L=1,NQ + + WRITE (UNIT,2100) L,NROW + WRITE (UNIT,2200) + + DO 50 I=1,NP + K = MSGB(L,I) + IF (K.GE.7) THEN + FLAG = '*' + ELSE + FLAG = ' ' + END IF + IF (K.LE.-1) THEN + WRITE (UNIT,3100) I + ELSE IF (K.EQ.0) THEN + WRITE (UNIT,3200) I,FJACB(NROW,I,L),DIFF(L,I),FLAG + ELSE IF (K.GE.1) THEN + WRITE (UNIT,3300) I,FJACB(NROW,I,L),DIFF(L,I),FLAG,K + END IF + 50 CONTINUE + IF (ISODR) THEN + DO 60 I=1,M + K = MSGD(L,I) + IF (K.GE.7) THEN + FLAG = '*' + ELSE + FLAG = ' ' + END IF + IF (K.LE.-1) THEN + WRITE (UNIT,4100) NROW,I + ELSE IF (K.EQ.0) THEN + WRITE (UNIT,4200) NROW,I, + + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG + ELSE IF (K.GE.1) THEN + WRITE (UNIT,4300) NROW,I, + + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG,K + END IF + 60 CONTINUE + END IF + 70 CONTINUE + +C PRINT FOOTNOTES + + IF (FTNOTE(0)) THEN + + WRITE (UNIT,5000) + IF (FTNOTE(1)) WRITE (UNIT,5100) + IF (FTNOTE(2)) WRITE (UNIT,5200) + IF (FTNOTE(3)) WRITE (UNIT,5300) + IF (FTNOTE(4)) WRITE (UNIT,5400) + IF (FTNOTE(5)) WRITE (UNIT,5500) + IF (FTNOTE(6)) WRITE (UNIT,5600) + IF (FTNOTE(7)) WRITE (UNIT,5700) + END IF + + IF (NETA.LT.0) THEN + WRITE (UNIT,6000) -NETA + ELSE + WRITE (UNIT,6100) NETA + END IF + WRITE (UNIT,7000) NTOL + +C PRINT OUT ROW OF EXPLANATORY VARIABLE WHICH WAS CHECKED. + + WRITE (UNIT,8100) NROW + + DO 80 J=1,M + WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J) + 80 CONTINUE + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT + + (//' *** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3, + + ' ***'/) + 2100 FORMAT (/' FOR RESPONSE ',I2,' OF OBSERVATION ', I5/) + 2200 FORMAT (' ',' USER', + + ' ',' '/ + + ' ',' SUPPLIED', + + ' RELATIVE',' DERIVATIVE '/ + + ' DERIVATIVE WRT',' VALUE', + + ' DIFFERENCE',' ASSESSMENT '/) + 3100 FORMAT (' BETA(',I3,')', ' --- ', + + ' --- ',' UNCHECKED') + 3200 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, + + 'VERIFIED') + 3300 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, + + 'QUESTIONABLE (SEE NOTE ',I1,')') + 4100 FORMAT (' DELTA(',I2,',',I2,')', ' --- ', + + ' --- ',' UNCHECKED') + 4200 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, + + 'VERIFIED') + 4300 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, + + 'QUESTIONABLE (SEE NOTE ',I1,')') + 5000 FORMAT + + (/' NOTES:') + 5100 FORMAT + + (/' (1) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' AGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE BOTH ARE ZERO.') + 5200 FORMAT + + (/' (2) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' AGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', + + ' IDENTICALLY ZERO'/ + + ' AND THE OTHER IS ONLY APPROXIMATELY ZERO.') + 5300 FORMAT + + (/' (3) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', + + ' IDENTICALLY ZERO'/ + + ' AND THE OTHER IS NOT.') + 5400 FORMAT + + (/' (4) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', + + ' BECAUSE EITHER'/ + + ' THE RATIO OF RELATIVE CURVATURE TO RELATIVE', + + ' SLOPE IS TOO HIGH'/ + + ' OR THE SCALE IS WRONG.') + 5500 FORMAT + + (/' (5) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', + + ' BECAUSE THE'/ + + ' RATIO OF RELATIVE CURVATURE TO RELATIVE SLOPE IS', + + ' TOO HIGH.') + 5600 FORMAT + + (/' (6) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, BUT'/ + + ' HAVE AT LEAST 2 DIGITS IN COMMON.') + 5700 FORMAT + + (/' (7) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + + ' DISAGREE, AND'/ + + ' HAVE FEWER THAN 2 DIGITS IN COMMON. DERIVATIVE', + + ' CHECKING MUST'/ + + ' BE TURNED OFF IN ORDER TO PROCEED.') + 6000 FORMAT + + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', + + I5/ + + ' (ESTIMATED BY ODRPACK)') + 6100 FORMAT + + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', + + I5/ + + ' (SUPPLIED BY USER)') + 7000 FORMAT + + (/' NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN '/ + + ' USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR '/ + + ' USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED ', + + I5) + 8100 FORMAT + + (/' ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED ', + + I5// + + ' -VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW'/) + 8110 FORMAT + + (10X,'X(',I2,',',I2,')',1X,1P,3D16.8) + END +*DODPE3 + SUBROUTINE DODPE3 + + (UNIT,D2,D3) +C***BEGIN PROLOGUE DODPE3 +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ERROR REPORTS INDICATING THAT COMPUTATIONS WERE +C STOPPED IN USER SUPPLIED SUBROUTINES FCN +C***END PROLOGUE DODPE3 + +C...SCALAR ARGUMENTS + INTEGER + + D2,D3,UNIT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. + + +C***FIRST EXECUTABLE STATEMENT DODPE3 + + +C PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE +C STOPPED + + IF (D2.EQ.2) THEN + WRITE(UNIT,1100) + ELSE IF (D2.EQ.3) THEN + WRITE(UNIT,1200) + ELSE IF (D2.EQ.4) THEN + WRITE(UNIT,1300) + END IF + IF (D3.EQ.2) THEN + WRITE(UNIT,1400) + END IF + +C FORMAT STATEMENTS + + 1100 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED USING THE'/ + + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ + + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ + + ' PROPER EVALUATION OF SUBROUTINE FCN BEFORE THE '/ + + ' REGRESSION PROCEDURE CAN CONTINUE.') + 1200 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ + + ' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE '/ + + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, INDI-'/ + + ' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),'/ + + ' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION), '/ + + ' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE'/ + + ' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT '/ + + ' SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. THE '/ + + ' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ + + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') + 1300 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ + + ' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT '/ + + ' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS '/ + + ' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR '/ + + ' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS '/ + + ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA '/ + + ' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN '/ + + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, '/ + + ' PREVENT SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. '/ + + ' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ + + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') + 1400 FORMAT + + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED FOR '/ + + ' DERIVATIVE EVALUATIONS USING THE INITIAL ESTIMATES OF '/ + + ' BETA AND DELTA SUPPLIED BY THE USER. THE INITIAL '/ + + ' ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER EVALUATION '/ + + ' OF SUBROUTINE FCN BEFORE THE REGRESSION PROCEDURE CAN '/ + + ' CONTINUE.') + END +*DODPER + SUBROUTINE DODPER + + (INFO,LUNERR,SHORT, + + N,M,NP,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN, + + FJACB,FJACD, + + DIFF,MSGB,ISODR,MSGD, + + XPLUSD,NROW,NETA,NTOL) +C***BEGIN PROLOGUE DODPER +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DODPE1,DODPE2,DODPE3,DODPHD +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS +C***END PROLOGUE DODPER + +C...SCALAR ARGUMENTS + INTEGER + + INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,LIWKMN,LUNERR,LWKMN, + + M,N,NETA,NP,NQ,NROW,NTOL + LOGICAL + + ISODR,SHORT + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) + INTEGER + + MSGB(NQ*NP+1),MSGD(NQ*M+1) + +C...LOCAL SCALARS + INTEGER + + D1,D2,D3,D4,D5,UNIT + LOGICAL + + HEAD + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DODPE1,DODPE2,DODPE3,DODPHD + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. +C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. +C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. +C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. +C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. +C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND +C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). +C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). +C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. +C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. +C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. +C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. +C N: THE NUMBER OF OBSERVATIONS. +C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE +C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. +C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED +C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL +C (SHORT=.FALSE.). +C UNIT: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. +C XPLUSD: THE VALUES X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DODPER + + +C SET LOGICAL UNIT NUMBER FOR ERROR REPORT + + IF (LUNERR.EQ.0) THEN + RETURN + ELSE IF (LUNERR.LT.0) THEN + UNIT = 6 + ELSE + UNIT = LUNERR + END IF + +C PRINT HEADING + + HEAD = .TRUE. + CALL DODPHD(HEAD,UNIT) + +C EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO + + D1 = MOD(INFO,100000)/10000 + D2 = MOD(INFO,10000)/1000 + D3 = MOD(INFO,1000)/100 + D4 = MOD(INFO,100)/10 + D5 = MOD(INFO,10) + +C PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP + + IF (D1.GE.1 .AND. D1.LE.3) THEN + +C PRINT APPROPRIATE MESSAGES FOR ERRORS IN +C PROBLEM SPECIFICATION PARAMETERS +C DIMENSION SPECIFICATION PARAMETERS +C NUMBER OF GOOD DIGITS IN X +C WEIGHTS + + CALL DODPE1(UNIT,D1,D2,D3,D4,D5, + + N,M,NQ, + + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + + LWKMN,LIWKMN) + + ELSE IF ((D1.EQ.4) .OR. (MSGB(1).GE.0)) THEN + +C PRINT APPROPRIATE MESSAGES FOR DERIVATIVE CHECKING + + CALL DODPE2(UNIT, + + N,M,NP,NQ, + + FJACB,FJACD, + + DIFF,MSGB(1),MSGB(2),ISODR,MSGD(1),MSGD(2), + + XPLUSD,NROW,NETA,NTOL) + + ELSE IF (D1.EQ.5) THEN + +C PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FCN + + CALL DODPE3(UNIT,D2,D3) + + END IF + +C PRINT CORRECT FORM OF CALL STATEMENT + + IF ((D1.GE.1 .AND. D1.LE.3) .OR. + + (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. + + (D1.EQ.5)) THEN + IF (SHORT) THEN + WRITE (UNIT,1100) + ELSE + WRITE (UNIT,1200) + END IF + END IF + + RETURN + +C FORMAT STATEMENTS + + 1100 FORMAT + + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + + ' CALL DODR'/ + + ' + (FCN,'/ + + ' + N,M,NP,NQ,'/ + + ' + BETA,'/ + + ' + Y,LDY,X,LDX,'/ + + ' + WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/ + + ' + JOB,'/ + + ' + IPRINT,LUNERR,LUNRPT,'/ + + ' + WORK,LWORK,IWORK,LIWORK,'/ + + ' + INFO)') + 1200 FORMAT + + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + + ' CALL DODRC'/ + + ' + (FCN,'/ + + ' + N,M,NP,NQ,'/ + + ' + BETA,'/ + + ' + Y,LDY,X,LDX,'/ + + ' + WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/ + + ' + IFIXB,IFIXX,LDIFX,'/ + + ' + JOB,NDIGIT,TAUFAC,'/ + + ' + SSTOL,PARTOL,MAXIT,'/ + + ' + IPRINT,LUNERR,LUNRPT,'/ + + ' + STPB,STPD,LDSTPD,'/ + + ' + SCLB,SCLD,LDSCLD,'/ + + ' + WORK,LWORK,IWORK,LIWORK,'/ + + ' + INFO)') + + END +*DODPHD + SUBROUTINE DODPHD + + (HEAD,UNIT) +C***BEGIN PROLOGUE DODPHD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE PRINT ODRPACK HEADING +C***END PROLOGUE DODPHD + +C...SCALAR ARGUMENTS + INTEGER + + UNIT + LOGICAL + + HEAD + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE +C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). +C UNIT: THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN. + + +C***FIRST EXECUTABLE STATEMENT DODPHD + + + IF (HEAD) THEN + WRITE(UNIT,1000) + HEAD = .FALSE. + END IF + + RETURN + +C FORMAT STATEMENTS + + 1000 FORMAT ( + + ' ******************************************************* '/ + + ' * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * '/ + + ' ******************************************************* '/) + END +*DODSTP + SUBROUTINE DODSTP + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ALPHA,EPSFCN,ISODR, + + TFJACB,OMEGA,U,QRAUX,KPVT, + + S,T,PHI,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODSTP +C***REFER TO DODR,DODRC +C***ROUTINES CALLED IDAMAX,DCHEX,DESUBI,DFCTR,DNRM2_odr,DQRDC,DQRSL,DROT, +C DROTG,DSOLVE,DTRCO,DTRSL_odr,DVEVTR,DWGHT,DZERO +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA) +C***END PROLOGUE DODSTP + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + ALPHA,EPSFCN,PHI,RCOND + INTEGER + + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),WRK(LWRK) + INTEGER + + KPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + CO,ONE,SI,TEMP,ZERO + INTEGER + + I,IMAX,INF,IPVT,J,K,K1,K2,KP,L + LOGICAL + + ELIM,FORVCV + +C...LOCAL ARRAYS + DOUBLE PRECISION + + DUM(2) + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DNRM2_odr + INTEGER + + IDAMAX + EXTERNAL + + DNRM2_odr,IDAMAX + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCHEX,DESUBI,DFCTR,DQRDC,DQRSL,DROT,DROTG, + + DSOLVE,DTRCO,DTRSL_odr,DVEVTR,DWGHT,DZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE + + /0.0D0,1.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. +C CO: THE COSINE FROM THE PLANE ROTATION. +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C DUM: A DUMMY ARRAY. +C ELIM: THE VARIABLE DESIGNATING WHETHER COLUMNS OF THE JACOBIAN +C WRT BETA HAVE BEEN ELIMINATED (ELIM=TRUE) OR NOT +C (ELIM=FALSE). +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE +C VALUE. +C INF: THE RETURN CODE FROM LINPACK ROUTINES. +C IPVT: THE VARIABLE DESIGNATING WHETHER PIVOTING IS TO BE DONE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C K1: AN INDEXING VARIABLE. +C K2: AN INDEXING VARIABLE. +C KP: THE RANK OF THE JACOBIAN WRT BETA. +C KPVT: THE PIVOT VECTOR. +C L: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C OMEGA: THE ARRAY DEFINED S.T. +C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) +C = (I-FJACD*INV(P)*TRANS(FJACD)) +C WHERE E = D**2 + ALPHA*TT**2 +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C ONE: THE VALUE 1.0D0. +C PHI: THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP +C AND THE TRUST REGION DIAMETER. +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. +C S: THE STEP FOR BETA. +C SI: THE SINE FROM THE PLANE ROTATION. +C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. +C T: THE STEP FOR DELTA. +C TEMP: A TEMPORARY STORAGE LOCATION. +C TFJACB: THE ARRAY OMEGA*FJACB. +C TT: THE SCALING VALUES FOR DELTA. +C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. +C WD: THE (SQUARED) DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODSTP + + +C COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE + +C SET UP KPVT IF ALPHA = 0 + + IF (ALPHA.EQ.ZERO) THEN + KP = NPP + DO 10 K=1,NP + KPVT(K) = K + 10 CONTINUE + ELSE + IF (NPP.GE.1) THEN + KP = NPP-IRANK + ELSE + KP = NPP + END IF + END IF + + IF (ISODR) THEN + +C T = WD * DELTA = D*G2 + CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,T,N) + + DO 300 I=1,N + +C COMPUTE WRK4, SUCH THAT +C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) + CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE OMEGA, SUCH THAT +C TRANS(OMEGA)*OMEGA = I+FJACD*INV(E)*TRANS(FJACD) +C INV(TRANS(OMEGA)*OMEGA) = I-FJACD*INV(P)*TRANS(FJACD) + CALL DVEVTR(M,NQ,I, + + FJACD,N,M, WRK4,M, WRK1,N,NQ, OMEGA,NQ, WRK5) + DO 110 L=1,NQ + OMEGA(L,L) = ONE + OMEGA(L,L) + 110 CONTINUE + CALL DFCTR(.FALSE.,OMEGA,NQ,NQ,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) +C = TRANS(FJACD)*INV(TRANS(OMEGA)*OMEGA) + DO 130 J=1,M + DO 120 L=1,NQ + WRK1(I,L,J) = FJACD(I,J,L) + 120 CONTINUE + CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,4) + CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,2) + 130 CONTINUE + +C COMPUTE WRK5 = INV(E)*D*G2 + DO 140 J=1,M + WRK5(J) = T(I,J) + 140 CONTINUE + CALL DSOLVE(M,WRK4,M,WRK5,1,4) + CALL DSOLVE(M,WRK4,M,WRK5,1,2) + +C COMPUTE TFJACB = INV(TRANS(OMEGA))*FJACB + DO 170 K=1,KP + DO 150 L=1,NQ + TFJACB(I,L,K) = FJACB(I,KPVT(K),L) + 150 CONTINUE + CALL DSOLVE(NQ,OMEGA,NQ,TFJACB(I,1,K),N,4) + DO 160 L=1,NQ + IF (SS(1).GT.ZERO) THEN + TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) + ELSE + TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) + END IF + 160 CONTINUE + 170 CONTINUE + +C COMPUTE WRK2 = (V*INV(E)*D**2*G2 - G1) + DO 190 L=1,NQ + WRK2(I,L) = ZERO + DO 180 J=1,M + WRK2(I,L) = WRK2(I,L) + FJACD(I,J,L)*WRK5(J) + 180 CONTINUE + WRK2(I,L) = WRK2(I,L) - F(I,L) + 190 CONTINUE + +C COMPUTE WRK2 = INV(TRANS(OMEGA))*(V*INV(E)*D**2*G2 - G1) + CALL DSOLVE(NQ,OMEGA,NQ,WRK2(I,1),N,4) + 300 CONTINUE + + ELSE + DO 360 I=1,N + DO 350 L=1,NQ + DO 340 K=1,KP + TFJACB(I,L,K) = FJACB(I,KPVT(K),L) + IF (SS(1).GT.ZERO) THEN + TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) + ELSE + TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) + END IF + 340 CONTINUE + WRK2(I,L) = -F(I,L) + 350 CONTINUE + 360 CONTINUE + END IF + +C COMPUTE S + +C DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0) + + IF (ALPHA.EQ.ZERO) THEN + IPVT = 1 + DO 410 K=1,NP + KPVT(K) = 0 + 410 CONTINUE + ELSE + IPVT = 0 + END IF + + CALL DQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT) + CALL DQRSL(TFJACB,N*NQ,N*NQ,KP, + + QRAUX,WRK2,DUM,WRK2,DUM,DUM,DUM,1000,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C ELIMINATE ALPHA PART USING GIVENS ROTATIONS + + IF (ALPHA.NE.ZERO) THEN + CALL DZERO(NPP,1,S,NPP) + DO 430 K1=1,KP + CALL DZERO(KP,1,WRK3,KP) + WRK3(K1) = SQRT(ALPHA) + DO 420 K2=K1,KP + CALL DROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI) + IF (KP-K2.GE.1) THEN + CALL DROT(KP-K2,TFJACB(K2,1,K2+1),N*NQ, + + WRK3(K2+1),1,CO,SI) + END IF + TEMP = CO*WRK2(K2,1) + SI*S(KPVT(K1)) + S(KPVT(K1)) = -SI*WRK2(K2,1) + CO*S(KPVT(K1)) + WRK2(K2,1) = TEMP + 420 CONTINUE + 430 CONTINUE + END IF + +C COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY + + IF (NPP.GE.1) THEN + IF (ALPHA.EQ.ZERO) THEN + KP = NPP + +C ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR + + 440 CALL DTRCO(TFJACB,N*NQ,KP,RCOND,U,1) + IF (RCOND.LE.EPSFCN) THEN + ELIM = .TRUE. + IMAX = IDAMAX(KP,U,1) + +C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX KPVT + + IF (IMAX.NE.KP) THEN + CALL DCHEX(TFJACB,N*NQ,KP,IMAX,KP,WRK2,N*NQ,1, + + QRAUX,WRK3,2) + K = KPVT(IMAX) + DO 450 I=IMAX,KP-1 + KPVT(I) = KPVT(I+1) + 450 CONTINUE + KPVT(KP) = K + END IF + KP = KP-1 + ELSE + ELIM = .FALSE. + END IF + IF (ELIM .AND. KP.GE.1) THEN + GO TO 440 + ELSE + IRANK = NPP-KP + END IF + END IF + END IF + + IF (FORVCV) RETURN + +C BACKSOLVE AND UNSCRAMBLE + + IF (NPP.GE.1) THEN + DO 510 I=KP+1,NPP + WRK2(I,1) = ZERO + 510 CONTINUE + IF (KP.GE.1) THEN + CALL DTRSL_odr(TFJACB,N*NQ,KP,WRK2,01,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + END IF + DO 520 I=1,NPP + IF (SS(1).GT.ZERO) THEN + S(KPVT(I)) = WRK2(I,1)/SS(KPVT(I)) + ELSE + S(KPVT(I)) = WRK2(I,1)/ABS(SS(1)) + END IF + 520 CONTINUE + END IF + + IF (ISODR) THEN + +C NOTE: T AND WRK1 HAVE BEEN INITIALIZED ABOVE, +C WHERE T = WD * DELTA = D*G2 +C WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) + + DO 670 I=1,N + +C COMPUTE WRK4, SUCH THAT +C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) + CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) + CALL DFCTR(.FALSE.,WRK4,M,M,INF) + IF (INF.NE.0) THEN + ISTOPC = 60000 + RETURN + END IF + +C COMPUTE WRK5 = INV(E)*D*G2 + DO 610 J=1,M + WRK5(J) = T(I,J) + 610 CONTINUE + CALL DSOLVE(M,WRK4,M,WRK5,1,4) + CALL DSOLVE(M,WRK4,M,WRK5,1,2) + + DO 640 L=1,NQ + WRK2(I,L) = F(I,L) + DO 620 K=1,NPP + WRK2(I,L) = WRK2(I,L) + FJACB(I,K,L)*S(K) + 620 CONTINUE + DO 630 J=1,M + WRK2(I,L) = WRK2(I,L) - FJACD(I,J,L)*WRK5(J) + 630 CONTINUE + 640 CONTINUE + + DO 660 J=1,M + WRK5(J) = ZERO + DO 650 L=1,NQ + WRK5(J) = WRK5(J) + WRK1(I,L,J)*WRK2(I,L) + 650 CONTINUE + T(I,J) = -(WRK5(J) + T(I,J)) + 660 CONTINUE + CALL DSOLVE(M,WRK4,M,T(I,1),N,4) + CALL DSOLVE(M,WRK4,M,T(I,1),N,2) + 670 CONTINUE + + END IF + +C COMPUTE PHI(ALPHA) FROM SCALED S AND T + + CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) + IF (ISODR) THEN + CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) + PHI = DNRM2_odr(NPP+N*M,WRK,1) + ELSE + PHI = DNRM2_odr(NPP,WRK,1) + END IF + + RETURN + END +*DODVCV + SUBROUTINE DODVCV + + (N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + + EPSFCN,ISODR, + + VCV,SD, + + WRK6,OMEGA,U,QRAUX,JPVT, + + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) +C***BEGIN PROLOGUE DODVCV +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPODI,DODSTP +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS +C***END PROLOGUE DODVCV + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + EPSFCN,RCOND,RSS,RVAR + INTEGER + + IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ + LOGICAL + + ISODR + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DELTA(N,M),F(N,NQ), + + FJACB(N,NP,NQ),FJACD(N,M,NQ), + + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SD(NP),SS(NP),SSF(NP), + + T(N,M),TT(LDTT,M),U(NP),VCV(NP,NP),WD(LDWD,LD2WD,M), + + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M), + + WRK6(N*NQ,NP),WRK(LWRK) + INTEGER + + IFIXB(NP),JPVT(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + I,IUNFIX,J,JUNFIX,KP,L + LOGICAL + + FORVCV + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DPODI,DODSTP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,SQRT + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. +C EPSFCN: THE FUNCTION'S PRECISION. +C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. +C FJACB: THE JACOBIAN WITH RESPECT TO BETA. +C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. +C FORVCV: THE VARIABLE DESIGNATING WHETHER SUBROUTINE DODSTP IS +C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS +C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). +C I: AN INDEXING VARIABLE. +C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF +C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE +C NUMBER OF PARAMETERS BEING ESTIMATED. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE +C VALUE. +C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE +C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. +C IUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. +C J: AN INDEXING VARIABLE. +C JPVT: THE PIVOT VECTOR. +C JUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. +C KP: THE RANK OF THE JACOBIAN WRT BETA. +C L: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDWD: THE LEADING DIMENSION OF ARRAY WD. +C LD2WD: THE SECOND DIMENSION OF ARRAY WD. +C LWRK: THE LENGTH OF VECTOR WRK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OMEGA: THE ARRAY DEFINED S.T. +C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) +C = (I-FJACD*INV(P)*TRANS(FJACD)) +C WHERE E = D**2 + ALPHA*TT**2 +C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 +C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE +C Q-R DECOMPOSITION. +C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. +C RSS: THE RESIDUAL SUM OF SQUARES. +C RVAR: THE RESIDUAL VARIANCE. +C S: THE STEP FOR BETA. +C SD: THE STANDARD DEVIATIONS OF THE ESTIMATED BETAS. +C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. +C SSF: THE SCALING VALUES USED FOR BETA. +C T: THE STEP FOR DELTA. +C TEMP: A TEMPORARY STORAGE LOCATION +C TT: THE SCALING VALUES FOR DELTA. +C U: THE APPROXIMATE NULL VECTOR FOR FJACB. +C VCV: THE COVARIANCE MATRIX OF THE ESTIMATED BETAS. +C WD: THE DELTA WEIGHTS. +C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, +C EQUIVALENCED TO WRK1 AND WRK2. +C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. +C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. +C WRK3: A WORK ARRAY OF (NP) ELEMENTS. +C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. +C WRK5: A WORK ARRAY OF (M) ELEMENTS. +C WRK6: A WORK ARRAY OF (N*NQ BY P) ELEMENTS. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DODVCV + + + FORVCV = .TRUE. + ISTOPC = 0 + + CALL DODSTP(N,M,NP,NQ,NPP, + + F,FJACB,FJACD, + + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + + ZERO,EPSFCN,ISODR, + + WRK6,OMEGA,U,QRAUX,JPVT, + + S,T,TEMP,IRANK,RCOND,FORVCV, + + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) + IF (ISTOPC.NE.0) THEN + RETURN + END IF + KP = NPP - IRANK + CALL DPODI (WRK6,N*NQ,KP,WRK3,1) + + IDF = 0 + DO 150 I=1,N + DO 120 J=1,NPP + DO 110 L=1,NQ + IF (FJACB(I,J,L).NE.ZERO) THEN + IDF = IDF + 1 + GO TO 150 + END IF + 110 CONTINUE + 120 CONTINUE + IF (ISODR) THEN + DO 140 J=1,M + DO 130 L=1,NQ + IF (FJACD(I,J,L).NE.ZERO) THEN + IDF = IDF + 1 + GO TO 150 + END IF + 130 CONTINUE + 140 CONTINUE + END IF + 150 CONTINUE + + IF (IDF.GT.KP) THEN + IDF = IDF - KP + RVAR = RSS/IDF + ELSE + IDF = 0 + RVAR = RSS + END IF + +C STORE VARIANCES IN SD, RESTORING ORIGINAL ORDER + + DO 200 I=1,NP + SD(I) = ZERO + 200 CONTINUE + DO 210 I=1,KP + SD(JPVT(I)) = WRK6(I,I) + 210 CONTINUE + IF (NP.GT.NPP) THEN + JUNFIX = NPP + DO 220 J=NP,1,-1 + IF (IFIXB(J).EQ.0) THEN + SD(J) = ZERO + ELSE + SD(J) = SD(JUNFIX) + JUNFIX = JUNFIX - 1 + END IF + 220 CONTINUE + END IF + +C STORE COVARIANCE MATRIX IN VCV, RESTORING ORIGINAL ORDER + + DO 310 I=1,NP + DO 300 J=1,I + VCV(I,J) = ZERO + 300 CONTINUE + 310 CONTINUE + DO 330 I=1,KP + DO 320 J=I+1,KP + IF (JPVT(I).GT.JPVT(J)) THEN + VCV(JPVT(I),JPVT(J))=WRK6(I,J) + ELSE + VCV(JPVT(J),JPVT(I))=WRK6(I,J) + END IF + 320 CONTINUE + 330 CONTINUE + IF (NP.GT.NPP) THEN + IUNFIX = NPP + DO 360 I=NP,1,-1 + IF (IFIXB(I).EQ.0) THEN + DO 340 J=I,1,-1 + VCV(I,J) = ZERO + 340 CONTINUE + ELSE + JUNFIX = NPP + DO 350 J=NP,1,-1 + IF (IFIXB(J).EQ.0) THEN + VCV(I,J) = ZERO + ELSE + VCV(I,J) = VCV(IUNFIX,JUNFIX) + JUNFIX = JUNFIX - 1 + END IF + 350 CONTINUE + IUNFIX = IUNFIX - 1 + END IF + 360 CONTINUE + END IF + + DO 380 I=1,NP + VCV(I,I) = SD(I) + SD(I) = SQRT(RVAR*SD(I)) + DO 370 J=1,I + VCV(J,I) = VCV(I,J) + 370 CONTINUE + 380 CONTINUE + +C UNSCALE STANDARD ERRORS AND COVARIANCE MATRIX + DO 410 I=1,NP + IF (SSF(1).GT.ZERO) THEN + SD(I) = SD(I)/SSF(I) + ELSE + SD(I) = SD(I)/ABS(SSF(1)) + END IF + DO 400 J=1,NP + IF (SSF(1).GT.ZERO) THEN + VCV(I,J) = VCV(I,J)/(SSF(I)*SSF(J)) + ELSE + VCV(I,J) = VCV(I,J)/(SSF(1)*SSF(1)) + END IF + 400 CONTINUE + 410 CONTINUE + + RETURN + END +*DPACK + SUBROUTINE DPACK + + (N2,N1,V1,V2,IFIX) +C***BEGIN PROLOGUE DPACK +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DCOPY_odr +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1 +C***END PROLOGUE DPACK + +C...SCALAR ARGUMENTS + INTEGER + + N1,N2 + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + V1(N2),V2(N2) + INTEGER + + IFIX(N2) + +C...LOCAL SCALARS + INTEGER + + I + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY_odr + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C N1: THE NUMBER OF ITEMS IN V1. +C N2: THE NUMBER OF ITEMS IN V2. +C V1: THE VECTOR OF THE UNFIXED ITEMS FROM V2. +C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE +C UNFIXED ELEMENTS ARE TO BE EXTRACTED. + + +C***FIRST EXECUTABLE STATEMENT DPACK + + + N1 = 0 + IF (IFIX(1).GE.0) THEN + DO 10 I=1,N2 + IF (IFIX(I).NE.0) THEN + N1 = N1+1 + V1(N1) = V2(I) + END IF + 10 CONTINUE + ELSE + N1 = N2 + CALL DCOPY_odr(N2,V2,1,V1,1) + END IF + + RETURN + END +*DPPNML + DOUBLE PRECISION FUNCTION DPPNML + + (P) +C***BEGIN PROLOGUE DPPNML +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***AUTHOR FILLIBEN, JAMES J., +C STATISTICAL ENGINEERING DIVISION +C NATIONAL BUREAU OF STANDARDS +C WASHINGTON, D. C. 20234 +C (ORIGINAL VERSION--JUNE 1972. +C (UPDATED --SEPTEMBER 1975, +C NOVEMBER 1975, AND +C OCTOBER 1976. +C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE +C NORMAL (GAUSSIAN) DISTRIBUTION WITH MEAN 0 AND STANDARD +C DEVIATION 1, AND WITH PROBABILITY DENSITY FUNCTION +C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). +C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS +C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) +C***DESCRIPTION +C --THE CODING AS PRESENTED BELOW IS ESSENTIALLY +C IDENTICAL TO THAT PRESENTED BY ODEH AND EVANS +C AS ALGORTIHM 70 OF APPLIED STATISTICS. +C --AS POINTED OUT BY ODEH AND EVANS IN APPLIED +C STATISTICS, THEIR ALGORITHM REPRESENTES A +C SUBSTANTIAL IMPROVEMENT OVER THE PREVIOUSLY EMPLOYED +C HASTINGS APPROXIMATION FOR THE NORMAL PERCENT POINT +C FUNCTION, WITH ACCURACY IMPROVING FROM 4.5*(10**-4) +C TO 1.5*(10**-8). +C***REFERENCES ODEH AND EVANS, THE PERCENTAGE POINTS OF THE NORMAL +C DISTRIBUTION, ALGORTIHM 70, APPLIED STATISTICS, 1974, +C PAGES 96-97. +C EVANS, ALGORITHMS FOR MINIMAL DEGREE POLYNOMIAL AND +C RATIONAL APPROXIMATION, M. SC. THESIS, 1972, +C UNIVERSITY OF VICTORIA, B. C., CANADA. +C HASTINGS, APPROXIMATIONS FOR DIGITAL COMPUTERS, 1955, +C PAGES 113, 191, 192. +C NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS +C SERIES 55, 1964, PAGE 933, FORMULA 26.2.23. +C FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE +C LOCATION PARAMETER OF A SYMMETRIC DISTRIBUTION +C (UNPUBLISHED PH.D. DISSERTATION, PRINCETON +C UNIVERSITY), 1969, PAGES 21-44, 229-231. +C FILLIBEN, "THE PERCENT POINT FUNCTION", +C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. +C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, +C VOLUME 1, 1970, PAGES 40-111. +C KELLEY STATISTICAL TABLES, 1948. +C OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, PAGES 3-16. +C PEARSON AND HARTLEY, BIOMETRIKA TABLES FOR +C STATISTICIANS, VOLUME 1, 1954, PAGES 104-113. +C***END PROLOGUE DPPNML + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + P + +C...LOCAL SCALARS + DOUBLE PRECISION + + ADEN,ANUM,HALF,ONE,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T,TWO,ZERO + +C...INTRINSIC FUNCTIONS + INTRINSIC + + LOG,SQRT + +C...DATA STATEMENTS + DATA + + P0,P1,P2,P3,P4 + + /-0.322232431088D0,-1.0D0,-0.342242088547D0, + + -0.204231210245D-1,-0.453642210148D-4/ + DATA + + Q0,Q1,Q2,Q3,Q4 + + /0.993484626060D-1,0.588581570495D0, + + 0.531103462366D0,0.103537752850D0,0.38560700634D-2/ + DATA + + ZERO,HALF,ONE,TWO + + /0.0D0,0.5D0,1.0D0,2.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ADEN: A VALUE USED IN THE APPROXIMATION. +C ANUM: A VALUE USED IN THE APPROXIMATION. +C HALF: THE VALUE 0.5D0. +C ONE: THE VALUE 1.0D0. +C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE +C EVALUATED. P MUST BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVE. +C P0: A PARAMETER USED IN THE APPROXIMATION. +C P1: A PARAMETER USED IN THE APPROXIMATION. +C P2: A PARAMETER USED IN THE APPROXIMATION. +C P3: A PARAMETER USED IN THE APPROXIMATION. +C P4: A PARAMETER USED IN THE APPROXIMATION. +C Q0: A PARAMETER USED IN THE APPROXIMATION. +C Q1: A PARAMETER USED IN THE APPROXIMATION. +C Q2: A PARAMETER USED IN THE APPROXIMATION. +C Q3: A PARAMETER USED IN THE APPROXIMATION. +C Q4: A PARAMETER USED IN THE APPROXIMATION. +C R: THE PROBABILITY AT WHICH THE PERCENT POINT IS EVALUATED. +C T: A VALUE USED IN THE APPROXIMATION. +C TWO: THE VALUE 2.0D0. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DPPT + + + IF (P.EQ.HALF) THEN + DPPNML = ZERO + + ELSE + R = P + IF (P.GT.HALF) R = ONE - R + T = SQRT(-TWO*LOG(R)) + ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0) + ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0) + DPPNML = T + (ANUM/ADEN) + + IF (P.LT.HALF) DPPNML = -DPPNML + END IF + + RETURN + + END +*DPPT + DOUBLE PRECISION FUNCTION DPPT + + (P, IDF) +C***BEGIN PROLOGUE DPPT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DPPNML +C***DATE WRITTEN 901207 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***AUTHOR FILLIBEN, JAMES J., +C STATISTICAL ENGINEERING DIVISION +C NATIONAL BUREAU OF STANDARDS +C WASHINGTON, D. C. 20234 +C (ORIGINAL VERSION--OCTOBER 1975.) +C (UPDATED --NOVEMBER 1975.) +C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE +C STUDENT'S T DISTRIBUTION WITH IDF DEGREES OF FREEDOM. +C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS +C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) +C***DESCRIPTION +C --FOR IDF = 1 AND IDF = 2, THE PERCENT POINT FUNCTION +C FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM +C AND SO THE COMPUTED PERCENT POINTS ARE EXACT. +C --FOR IDF BETWEEN 3 AND 6, INCLUSIVELY, THE APPROXIMATION +C IS AUGMENTED BY 3 ITERATIONS OF NEWTON'S METHOD TO +C IMPROVE THE ACCURACY, ESPECIALLY FOR P NEAR 0 OR 1. +C***REFERENCES NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS +C SERIES 55, 1964, PAGE 949, FORMULA 26.7.5. +C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, +C VOLUME 2, 1970, PAGE 102, FORMULA 11. +C FEDERIGHI, "EXTENDED TABLES OF THE PERCENTAGE POINTS +C OF STUDENT"S T DISTRIBUTION, JOURNAL OF THE AMERICAN +C STATISTICAL ASSOCIATION, 1969, PAGES 683-688. +C HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS, A +C HANDBOOK FOR STUDENTS AND PRACTITIONERS, 1975, +C PAGES 120-123. +C***END PROLOGUE DPPT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + P + INTEGER + + IDF + +C...LOCAL SCALARS + DOUBLE PRECISION + + ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45, + + B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,EIGHT,FIFTN, + + HALF,ONE,PI,PPFN,S,TERM1,TERM2,TERM3,TERM4,TERM5,THREE,TWO, + + Z,ZERO + INTEGER + + IPASS,MAXIT + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DPPNML + EXTERNAL + + DPPNML + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ATAN,COS,SIN,SQRT + +C...DATA STATEMENTS + DATA + + B21 + + /4.0D0/ + DATA + + B31, B32, B33, B34 + + /96.0D0,5.0D0,16.0D0,3.0D0/ + DATA + + B41, B42, B43, B44, B45 + + /384.0D0,3.0D0,19.0D0,17.0D0,-15.0D0/ + DATA + + B51,B52,B53,B54,B55,B56 + + /9216.0D0,79.0D0,776.0D0,1482.0D0,-1920.0D0,-945.0D0/ + DATA + + ZERO,HALF,ONE,TWO,THREE,EIGHT,FIFTN + + /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,8.0D0,15.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ARG: A VALUE USED IN THE APPROXIMATION. +C B21: A PARAMETER USED IN THE APPROXIMATION. +C B31: A PARAMETER USED IN THE APPROXIMATION. +C B32: A PARAMETER USED IN THE APPROXIMATION. +C B33: A PARAMETER USED IN THE APPROXIMATION. +C B34: A PARAMETER USED IN THE APPROXIMATION. +C B41: A PARAMETER USED IN THE APPROXIMATION. +C B42: A PARAMETER USED IN THE APPROXIMATION. +C B43: A PARAMETER USED IN THE APPROXIMATION. +C B44: A PARAMETER USED IN THE APPROXIMATION. +C B45: A PARAMETER USED IN THE APPROXIMATION. +C B51: A PARAMETER USED IN THE APPROXIMATION. +C B52: A PARAMETER USED IN THE APPROXIMATION. +C B53: A PARAMETER USED IN THE APPROXIMATION. +C B54: A PARAMETER USED IN THE APPROXIMATION. +C B55: A PARAMETER USED IN THE APPROXIMATION. +C B56: A PARAMETER USED IN THE APPROXIMATION. +C C: A VALUE USED IN THE APPROXIMATION. +C CON: A VALUE USED IN THE APPROXIMATION. +C DF: THE DEGREES OF FREEDOM. +C D1: A VALUE USED IN THE APPROXIMATION. +C D3: A VALUE USED IN THE APPROXIMATION. +C D5: A VALUE USED IN THE APPROXIMATION. +C D7: A VALUE USED IN THE APPROXIMATION. +C D9: A VALUE USED IN THE APPROXIMATION. +C EIGHT: THE VALUE 8.0D0. +C FIFTN: THE VALUE 15.0D0. +C HALF: THE VALUE 0.5D0. +C IDF: THE (POSITIVE INTEGER) DEGREES OF FREEDOM. +C IPASS: A VALUE USED IN THE APPROXIMATION. +C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR THE APPROX. +C ONE: THE VALUE 1.0D0. +C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE +C EVALUATED. P MUST LIE BETWEEN 0.0DO AND 1.0D0, EXCLUSIVE. +C PI: THE VALUE OF PI. +C PPFN: THE NORMAL PERCENT POINT VALUE. +C S: A VALUE USED IN THE APPROXIMATION. +C TERM1: A VALUE USED IN THE APPROXIMATION. +C TERM2: A VALUE USED IN THE APPROXIMATION. +C TERM3: A VALUE USED IN THE APPROXIMATION. +C TERM4: A VALUE USED IN THE APPROXIMATION. +C TERM5: A VALUE USED IN THE APPROXIMATION. +C THREE: THE VALUE 3.0D0. +C TWO: THE VALUE 2.0D0. +C Z: A VALUE USED IN THE APPROXIMATION. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DPPT + + + PI = 3.141592653589793238462643383279D0 + DF = IDF + MAXIT = 5 + + IF (IDF.LE.0) THEN + +C TREAT THE IDF < 1 CASE + DPPT = ZERO + + ELSE IF (IDF.EQ.1) THEN + +C TREAT THE IDF = 1 (CAUCHY) CASE + ARG = PI*P + DPPT = -COS(ARG)/SIN(ARG) + + ELSE IF (IDF.EQ.2) THEN + +C TREAT THE IDF = 2 CASE + TERM1 = SQRT(TWO)/TWO + TERM2 = TWO*P - ONE + TERM3 = SQRT(P*(ONE-P)) + DPPT = TERM1*TERM2/TERM3 + + ELSE IF (IDF.GE.3) THEN + +C TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE + PPFN = DPPNML(P) + D1 = PPFN + D3 = PPFN**3 + D5 = PPFN**5 + D7 = PPFN**7 + D9 = PPFN**9 + TERM1 = D1 + TERM2 = (ONE/B21)*(D3+D1)/DF + TERM3 = (ONE/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2) + TERM4 = (ONE/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) + TERM5 = (ONE/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4) + DPPT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5 + + IF (IDF.EQ.3) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 3 CASE + CON = PI*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 70 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - (Z+S*C-CON)/(TWO*C**2) + 70 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.4) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 4 CASE + CON = TWO*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 90 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - ((ONE+HALF*C**2)*S-CON)/((ONE+HALF)*C**3) + 90 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.5) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 5 CASE + + CON = PI*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 110 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - (Z+(C+(TWO/THREE)*C**3)*S-CON)/ + + ((EIGHT/THREE)*C**4) + 110 CONTINUE + DPPT = SQRT(DF)*S/C + + ELSE IF (IDF.EQ.6) THEN + +C AUGMENT THE RESULTS FOR THE IDF = 6 CASE + CON = TWO*(P-HALF) + ARG = DPPT/SQRT(DF) + Z = ATAN(ARG) + DO 130 IPASS=1,MAXIT + S = SIN(Z) + C = COS(Z) + Z = Z - ((ONE+HALF*C**2 + (THREE/EIGHT)*C**4)*S-CON)/ + + ((FIFTN/EIGHT)*C**5) + 130 CONTINUE + DPPT = SQRT(DF)*S/C + END IF + END IF + + RETURN + + END +*DPVB + SUBROUTINE DPVB + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVB, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DPVB +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP +C***END PROLOGUE DPVB + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PVB,STP + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + BETAJ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BETAJ: THE CURRENT ESTIMATE OF THE JTH PARAMETER. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C PVB: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DPVB + + +C COMPUTE PREDICTED VALUES + + BETAJ = BETA(J) + BETA(J) = BETA(J) + STP + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + ELSE + RETURN + END IF + BETA(J) = BETAJ + + PVB = WRK2(NROW,LQ) + + RETURN + END +*DPVD + SUBROUTINE DPVD + + (FCN, + + N,M,NP,NQ, + + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + + NROW,J,LQ,STP, + + ISTOP,NFEV,PVD, + + WRK1,WRK2,WRK6) +C***BEGIN PROLOGUE DPVD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED FCN +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE NROW-TH FUNCTION VALUE USING +C X(NROW,J) + DELTA(NROW,J) + STP +C***END PROLOGUE DPVD + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + PVD,STP + INTEGER + + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) + INTEGER + + IFIXB(NP),IFIXX(LDIFX,M) + +C...SUBROUTINE ARGUMENTS + EXTERNAL + + FCN + +C...LOCAL SCALARS + DOUBLE PRECISION + + XPDJ + +C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS +C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS +C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. +C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. +C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. +C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT +C WHICH THE DERIVATIVE IS TO BE CHECKED. +C PVD: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. +C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. +C XPDJ: THE (NROW,J)TH ELEMENT OF XPLUSD. +C XPLUSD: THE VALUES OF X + DELTA. + + +C***FIRST EXECUTABLE STATEMENT DPVD + + +C COMPUTE PREDICTED VALUES + + XPDJ = XPLUSD(NROW,J) + XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP + ISTOP = 0 + CALL FCN(N,M,NP,NQ, + + N,M,NP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + 003,WRK2,WRK6,WRK1, + + ISTOP) + IF (ISTOP.EQ.0) THEN + NFEV = NFEV + 1 + ELSE + RETURN + END IF + XPLUSD(NROW,J) = XPDJ + + PVD = WRK2(NROW,LQ) + + RETURN + END +*DSCALE + SUBROUTINE DSCALE + + (N,M,SCL,LDSCL,T,LDT,SCLT,LDSCLT) +C***BEGIN PROLOGUE DSCALE +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SCALE T BY THE INVERSE OF SCL, I.E., COMPUTE T/SCL +C***END PROLOGUE DSCALE + +C...SCALAR ARGUMENTS + INTEGER + + LDT,LDSCL,LDSCLT,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),SCL(LDSCL,M),SCLT(LDSCLT,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,TEMP,ZERO + INTEGER + + I,J + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ONE,ZERO + + /1.0D0,0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDSCL: THE LEADING DIMENSION OF ARRAY SCL. +C LDSCLT: THE LEADING DIMENSION OF ARRAY SCLT. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C M: THE NUMBER OF COLUMNS OF DATA IN T. +C N: THE NUMBER OF ROWS OF DATA IN T. +C ONE: THE VALUE 1.0D0. +C SCL: THE SCALE VALUES. +C SCLT: THE INVERSELY SCALED MATRIX. +C T: THE ARRAY TO BE INVERSELY SCALED BY SCL. +C TEMP: A TEMPORARY SCALAR. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCALE + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (SCL(1,1).GE.ZERO) THEN + IF (LDSCL.GE.N) THEN + DO 80 J=1,M + DO 70 I=1,N + SCLT(I,J) = T(I,J)/SCL(I,J) + 70 CONTINUE + 80 CONTINUE + ELSE + DO 100 J=1,M + TEMP = ONE/SCL(1,J) + DO 90 I=1,N + SCLT(I,J) = T(I,J)*TEMP + 90 CONTINUE + 100 CONTINUE + END IF + ELSE + TEMP = ONE/ABS(SCL(1,1)) + DO 120 J=1,M + DO 110 I=1,N + SCLT(I,J) = T(I,J)*TEMP + 110 CONTINUE + 120 CONTINUE + END IF + + RETURN + END +*DSCLB + SUBROUTINE DSCLB + + (NP,BETA,SSF) +C***BEGIN PROLOGUE DSCLB +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT SCALING VALUES FOR BETA ACCORDING TO THE +C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE +C***END PROLOGUE DSCLB + +C...SCALAR ARGUMENTS + INTEGER + + NP + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + BETA(NP),SSF(NP) + +C...LOCAL SCALARS + DOUBLE PRECISION + + BMAX,BMIN,ONE,TEN,ZERO + INTEGER + + K + LOGICAL + + BIGDIF + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,LOG10,MAX,MIN,SQRT + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TEN + + /0.0D0,1.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BETA: THE FUNCTION PARAMETERS. +C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT +C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF +C BETA (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). +C BMAX: THE LARGEST NONZERO MAGNITUDE. +C BMIN: THE SMALLEST NONZERO MAGNITUDE. +C K: AN INDEXING VARIABLE. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C ONE: THE VALUE 1.0D0. +C SSF: THE SCALING VALUES FOR BETA. +C TEN: THE VALUE 10.0D0. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCLB + + + BMAX = ABS(BETA(1)) + DO 10 K=2,NP + BMAX = MAX(BMAX,ABS(BETA(K))) + 10 CONTINUE + + IF (BMAX.EQ.ZERO) THEN + +C ALL INPUT VALUES OF BETA ARE ZERO + + DO 20 K=1,NP + SSF(K) = ONE + 20 CONTINUE + + ELSE + +C SOME OF THE INPUT VALUES ARE NONZERO + + BMIN = BMAX + DO 30 K=1,NP + IF (BETA(K).NE.ZERO) THEN + BMIN = MIN(BMIN,ABS(BETA(K))) + END IF + 30 CONTINUE + BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE + DO 40 K=1,NP + IF (BETA(K).EQ.ZERO) THEN + SSF(K) = TEN/BMIN + ELSE + IF (BIGDIF) THEN + SSF(K) = ONE/ABS(BETA(K)) + ELSE + SSF(K) = ONE/BMAX + END IF + END IF + 40 CONTINUE + + END IF + + RETURN + END +*DSCLD + SUBROUTINE DSCLD + + (N,M,X,LDX,TT,LDTT) +C***BEGIN PROLOGUE DSCLD +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT SCALING VALUES FOR DELTA ACCORDING TO THE +C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE +C***END PROLOGUE DSCLD + +C...SCALAR ARGUMENTS + INTEGER + + LDTT,LDX,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + TT(LDTT,M),X(LDX,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,TEN,XMAX,XMIN,ZERO + INTEGER + + I,J + LOGICAL + + BIGDIF + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS,LOG10,MAX,MIN + +C...DATA STATEMENTS + DATA + + ZERO,ONE,TEN + + /0.0D0,1.0D0,10.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT +C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF +C X (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDTT: THE LEADING DIMENSION OF ARRAY TT. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C ONE: THE VALUE 1.0D0. +C TT: THE SCALING VALUES FOR DELTA. +C X: THE INDEPENDENT VARIABLE. +C XMAX: THE LARGEST NONZERO MAGNITUDE. +C XMIN: THE SMALLEST NONZERO MAGNITUDE. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSCLD + + + DO 50 J=1,M + XMAX = ABS(X(1,J)) + DO 10 I=2,N + XMAX = MAX(XMAX,ABS(X(I,J))) + 10 CONTINUE + + IF (XMAX.EQ.ZERO) THEN + +C ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO + + DO 20 I=1,N + TT(I,J) = ONE + 20 CONTINUE + + ELSE + +C SOME OF THE INPUT VALUES ARE NONZERO + + XMIN = XMAX + DO 30 I=1,N + IF (X(I,J).NE.ZERO) THEN + XMIN = MIN(XMIN,ABS(X(I,J))) + END IF + 30 CONTINUE + BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE + DO 40 I=1,N + IF (X(I,J).NE.ZERO) THEN + IF (BIGDIF) THEN + TT(I,J) = ONE/ABS(X(I,J)) + ELSE + TT(I,J) = ONE/XMAX + END IF + ELSE + TT(I,J) = TEN/XMIN + END IF + 40 CONTINUE + END IF + 50 CONTINUE + + RETURN + END +*DSETN + SUBROUTINE DSETN + + (N,M,X,LDX,NROW) +C***BEGIN PROLOGUE DSETN +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED +C***END PROLOGUE DSETN + +C...SCALAR ARGUMENTS + INTEGER + + LDX,M,N,NROW + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEX VARIABLE. +C J: AN INDEX VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NROW: THE SELECTED ROW NUMBER OF THE INDEPENDENT VARIABLE. +C X: THE INDEPENDENT VARIABLE. + + +C***FIRST EXECUTABLE STATEMENT DSETN + + + IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN + +C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS +C IF THERE IS ONE, OTHERWISE FIRST ROW IS USED. + + DO 20 I = 1, N + DO 10 J = 1, M + IF (X(I,J).EQ.0.0) GO TO 20 + 10 CONTINUE + NROW = I + RETURN + 20 CONTINUE + + NROW = 1 + + RETURN + END +*DSOLVE + SUBROUTINE DSOLVE(N,T,LDT,B,LDB,JOB) +C***BEGIN PROLOGUE DSOLVE +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DAXPY_odr,DDOT_odr +C***DATE WRITTEN 920220 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE SOLVE SYSTEMS OF THE FORM +C T * X = B OR TRANS(T) * X = B +C WHERE T IS AN UPPER OR LOWER TRIANGULAR MATRIX OF ORDER N, +C AND THE SOLUTION X OVERWRITES THE RHS B. +C (ADAPTED FROM LINPACK SUBROUTINE DTRSL_odr) +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***END PROLOGUE DSOLVE + +C...SCALAR ARGUMENTS + INTEGER + + JOB,LDB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(LDB,N),T(LDT,N) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + J1,J,JN + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr + EXTERNAL + + DDOT_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY_odr + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C B: ON INPUT: THE RIGHT HAND SIDE; ON EXIT: THE SOLUTION +C J1: THE FIRST NONZERO ENTRY IN T. +C J: AN INDEXING VARIABLE. +C JN: THE LAST NONZERO ENTRY IN T. +C JOB: WHAT KIND OF SYSTEM IS TO BE SOLVED, WHERE IF JOB IS +C 1 SOLVE T*X=B, T LOWER TRIANGULAR, +C 2 SOLVE T*X=B, T UPPER TRIANGULAR, +C 3 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, +C 4 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. +C LDB: THE LEADING DIMENSION OF ARRAY B. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY T. +C T: THE UPPER OR LOWER TRIDIAGONAL SYSTEM. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DSOLVE + + +C FIND FIRST NONZERO DIAGONAL ENTRY IN T + J1 = 0 + DO 10 J=1,N + IF (J1.EQ.0 .AND. T(J,J).NE.ZERO) THEN + J1 = J + ELSE IF (T(J,J).EQ.ZERO) THEN + B(1,J) = ZERO + END IF + 10 CONTINUE + IF (J1.EQ.0) RETURN + +C FIND LAST NONZERO DIAGONAL ENTRY IN T + JN = 0 + DO 20 J=N,J1,-1 + IF (JN.EQ.0 .AND. T(J,J).NE.ZERO) THEN + JN = J + ELSE IF (T(J,J).EQ.ZERO) THEN + B(1,J) = ZERO + END IF + 20 CONTINUE + + IF (JOB.EQ.1) THEN + +C SOLVE T*X=B FOR T LOWER TRIANGULAR + B(1,J1) = B(1,J1)/T(J1,J1) + DO 30 J = J1+1, JN + TEMP = -B(1,J-1) + CALL DAXPY_odr(JN-J+1,TEMP,T(J,J-1),1,B(1,J),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 30 CONTINUE + + ELSE IF (JOB.EQ.2) THEN + +C SOLVE T*X=B FOR T UPPER TRIANGULAR. + B(1,JN) = B(1,JN)/T(JN,JN) + DO 40 J = JN-1,J1,-1 + TEMP = -B(1,J+1) + CALL DAXPY_odr(J,TEMP,T(1,J+1),1,B(1,1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 40 CONTINUE + + ELSE IF (JOB.EQ.3) THEN + +C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. + B(1,JN) = B(1,JN)/T(JN,JN) + DO 50 J = JN-1,J1,-1 + B(1,J) = B(1,J) - + + DDOT_odr(JN-J+1,T(J+1,J),1,B(1,J+1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 50 CONTINUE + + ELSE IF (JOB.EQ.4) THEN + +C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. + B(1,J1) = B(1,J1)/T(J1,J1) + DO 60 J = J1+1,JN + B(1,J) = B(1,J) - DDOT_odr(J-1,T(1,J),1,B(1,1),LDB) + IF (T(J,J).NE.ZERO) THEN + B(1,J) = B(1,J)/T(J,J) + ELSE + B(1,J) = ZERO + END IF + 60 CONTINUE + END IF + + RETURN + END +*DUNPAC + SUBROUTINE DUNPAC + + (N2,V1,V2,IFIX) +C***BEGIN PROLOGUE DUNPAC +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DCOPY_odr +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE +C UNFIXED +C***END PROLOGUE DUNPAC + +C...SCALAR ARGUMENTS + INTEGER + + N2 + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + V1(N2),V2(N2) + INTEGER + + IFIX(N2) + +C...LOCAL SCALARS + INTEGER + + I,N1 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DCOPY_odr + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE +C FIXED AT THEIR INPUT VALUES OR NOT. +C ODRPACK REFERENCE GUIDE.) +C N1: THE NUMBER OF ITEMS IN V1. +C N2: THE NUMBER OF ITEMS IN V2. +C V1: THE VECTOR OF THE UNFIXED ITEMS. +C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE +C ELEMENTS OF V1 ARE TO BE INSERTED. + + +C***FIRST EXECUTABLE STATEMENT DUNPAC + N1 = 0 + IF (IFIX(1).GE.0) THEN + DO 10 I = 1,N2 + IF (IFIX(I).NE.0) THEN + N1 = N1 + 1 + V2(I) = V1(N1) + END IF + 10 CONTINUE + ELSE + N1 = N2 + CALL DCOPY_odr(N2,V1,1,V2,1) + END IF + RETURN + END +*DVEVTR + SUBROUTINE DVEVTR + + (M,NQ,INDX, + + V,LDV,LD2V, E,LDE, VE,LDVE,LD2VE, VEV,LDVEV, + + WRK5) +C***BEGIN PROLOGUE DVEVTR +C***REFER TO DODR,DODRC +C***ROUTINES CALLED DSOLVE +C***DATE WRITTEN 910613 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE V*E*TRANS(V) FOR THE (INDX)TH M BY NQ ARRAY IN V +C***END PROLOGUE DVEVTR + +C...SCALAR ARGUMENTS + INTEGER + + INDX,LDE,LDV,LDVE,LDVEV,LD2V,LD2VE,M,NQ + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + E(LDE,M),V(LDV,LD2V,NQ),VE(LDVE,LD2VE,M),VEV(LDVEV,NQ),WRK5(M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + J,L1,L2 + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DSOLVE + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C INDX: THE ROW IN V IN WHICH THE M BY NQ ARRAY IS STORED. +C J: AN INDEXING VARIABLE. +C LDE: THE LEADING DIMENSION OF ARRAY E. +C LDV: THE LEADING DIMENSION OF ARRAY V. +C LDVE: THE LEADING DIMENSION OF ARRAY VE. +C LDVEV: THE LEADING DIMENSION OF ARRAY VEV. +C LD2V: THE SECOND DIMENSION OF ARRAY V. +C L1: AN INDEXING VARIABLE. +C L2: AN INDEXING VARIABLE. +C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C E: THE M BY M MATRIX OF THE FACTORS SO ETE = (D**2 + ALPHA*T**2). +C V: AN ARRAY OF NQ BY M MATRICES. +C VE: THE NQ BY M ARRAY VE = V * INV(E) +C VEV: THE NQ BY NQ ARRAY VEV = V * INV(ETE) * TRANS(V). +C WRK5: AN M WORK VECTOR. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DVEVTR + + + IF (NQ.EQ.0 .OR. M.EQ.0) RETURN + + DO 140 L1 = 1,NQ + DO 110 J = 1,M + WRK5(J) = V(INDX,J,L1) + 110 CONTINUE + CALL DSOLVE(M,E,LDE,WRK5,1,4) + DO 120 J = 1,M + VE(INDX,L1,J) = WRK5(J) + 120 CONTINUE + 140 CONTINUE + + DO 230 L1 = 1,NQ + DO 220 L2 = 1,L1 + VEV(L1,L2) = ZERO + DO 210 J = 1,M + VEV(L1,L2) = VEV(L1,L2) + VE(INDX,L1,J)*VE(INDX,L2,J) + 210 CONTINUE + VEV(L2,L1) = VEV(L1,L2) + 220 CONTINUE + 230 CONTINUE + + RETURN + END +*DWGHT + SUBROUTINE DWGHT + + (N,M,WT,LDWT,LD2WT,T,LDT,WTT,LDWTT) +C***BEGIN PROLOGUE DWGHT +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SCALE MATRIX T USING WT, I.E., COMPUTE WTT = WT*T +C***END PROLOGUE DWGHT + +C...SCALAR ARGUMENTS + INTEGER + + LDT,LDWT,LDWTT,LD2WT,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,M),WT(LDWT,LD2WT,M),WTT(LDWTT,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP,ZERO + INTEGER + + I,J,K + +C...INTRINSIC FUNCTIONS + INTRINSIC + + ABS + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C K: AN INDEXING VARIABLE. +C LDT: THE LEADING DIMENSION OF ARRAY T. +C LDWT: THE LEADING DIMENSION OF ARRAY WT. +C LDWTT: THE LEADING DIMENSION OF ARRAY WTT. +C LD2WT: THE SECOND DIMENSION OF ARRAY WT. +C M: THE NUMBER OF COLUMNS OF DATA IN T. +C N: THE NUMBER OF ROWS OF DATA IN T. +C T: THE ARRAY BEING SCALED BY WT. +C TEMP: A TEMPORARY SCALAR. +C WT: THE WEIGHTS. +C WTT: THE RESULTS OF WEIGHTING ARRAY T BY WT. +C ARRAY WTT CAN BE THE SAME AS T ONLY IF THE ARRAYS IN WT +C ARE UPPER TRIANGULAR WITH ZEROS BELOW THE DIAGONAL. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DWGHT + + + IF (N.EQ.0 .OR. M.EQ.0) RETURN + + IF (WT(1,1,1).GE.ZERO) THEN + IF (LDWT.GE.N) THEN + IF (LD2WT.GE.M) THEN +C WT IS AN N-ARRAY OF M BY M MATRICES + DO 130 I=1,N + DO 120 J=1,M + TEMP = ZERO + DO 110 K=1,M + TEMP = TEMP + WT(I,J,K)*T(I,K) + 110 CONTINUE + WTT(I,J) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE +C WT IS AN N-ARRAY OF DIAGONAL MATRICES + DO 230 I=1,N + DO 220 J=1,M + WTT(I,J) = WT(I,1,J)*T(I,J) + 220 CONTINUE + 230 CONTINUE + END IF + ELSE + IF (LD2WT.GE.M) THEN +C WT IS AN M BY M MATRIX + DO 330 I=1,N + DO 320 J=1,M + TEMP = ZERO + DO 310 K=1,M + TEMP = TEMP + WT(1,J,K)*T(I,K) + 310 CONTINUE + WTT(I,J) = TEMP + 320 CONTINUE + 330 CONTINUE + ELSE +C WT IS A DIAGONAL MATRICE + DO 430 I=1,N + DO 420 J=1,M + WTT(I,J) = WT(1,1,J)*T(I,J) + 420 CONTINUE + 430 CONTINUE + END IF + END IF + ELSE +C WT IS A SCALAR + DO 520 J=1,M + DO 510 I=1,N + WTT(I,J) = ABS(WT(1,1,1))*T(I,J) + 510 CONTINUE + 520 CONTINUE + END IF + + RETURN + END +*DWINF + SUBROUTINE DWINF + + (N,M,NP,NQ,LDWE,LD2WE,ISODR, + + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + + PARTLI,SSTOLI,TAUFCI,EPSMAI, + + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + + FSI,FJACBI,WE1I,DIFFI, + + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + LWKMN) +C***BEGIN PROLOGUE DWINF +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920619 (YYMMDD) +C***PURPOSE SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE +C***END PROLOGUE DWINF + +C...SCALAR ARGUMENTS + INTEGER + + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + + DIFFI,EPSI,EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,LDWE,LD2WE,LWKMN, + + M,N,NP,NQ,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI, + + WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + + WSSI,WSSDEI,WSSEPI,XPLUSI + LOGICAL + + ISODR + +C...LOCAL SCALARS + INTEGER + + NEXT + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. +C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. +C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. +C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. +C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. +C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. +C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. +C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. +C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. +C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. +C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. +C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. +C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. +C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. +C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. +C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. +C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. +C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR +C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). +C LDWE: THE LEADING DIMENSION OF ARRAY WE. +C LD2WE: THE SECOND DIMENSION OF ARRAY WE. +C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF VECTOR WORK. +C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. +C N: THE NUMBER OF OBSERVATIONS. +C NEXT: THE NEXT AVAILABLE LOCATION WITH WORK. +C NP: THE NUMBER OF FUNCTION PARAMETERS. +C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. +C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. +C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. +C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. +C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. +C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. +C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. +C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCONDI. +C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. +C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. +C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. +C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. +C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. +C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. +C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. +C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. +C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. +C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. +C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. +C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. +C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. +C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. +C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. +C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. +C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. +C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. +C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. +C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. +C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. +C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. +C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. +C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. +C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. + + +C***FIRST EXECUTABLE STATEMENT DWINF + + + IF (N.GE.1 .AND. M.GE.1 .AND. NP.GE.1 .AND. NQ.GE.1 .AND. + + LDWE.GE.1 .AND. LD2WE.GE.1) THEN + + DELTAI = 1 + EPSI = DELTAI + N*M + XPLUSI = EPSI + N*NQ + FNI = XPLUSI + N*M + SDI = FNI + N*NQ + VCVI = SDI + NP + RVARI = VCVI + NP*NP + + WSSI = RVARI + 1 + WSSDEI = WSSI + 1 + WSSEPI = WSSDEI + 1 + RCONDI = WSSEPI + 1 + ETAI = RCONDI + 1 + OLMAVI = ETAI + 1 + + TAUI = OLMAVI + 1 + ALPHAI = TAUI + 1 + ACTRSI = ALPHAI + 1 + PNORMI = ACTRSI + 1 + RNORSI = PNORMI + 1 + PRERSI = RNORSI + 1 + PARTLI = PRERSI + 1 + SSTOLI = PARTLI + 1 + TAUFCI = SSTOLI + 1 + EPSMAI = TAUFCI + 1 + BETA0I = EPSMAI + 1 + + BETACI = BETA0I + NP + BETASI = BETACI + NP + BETANI = BETASI + NP + SI = BETANI + NP + SSI = SI + NP + SSFI = SSI + NP + QRAUXI = SSFI + NP + UI = QRAUXI + NP + FSI = UI + NP + + FJACBI = FSI + N*NQ + + WE1I = FJACBI + N*NP*NQ + + DIFFI = WE1I + LDWE*LD2WE*NQ + + NEXT = DIFFI + NQ*(NP+M) + + IF (ISODR) THEN + DELTSI = NEXT + DELTNI = DELTSI + N*M + TI = DELTNI + N*M + TTI = TI + N*M + OMEGAI = TTI + N*M + FJACDI = OMEGAI + NQ*NQ + WRK1I = FJACDI + N*M*NQ + NEXT = WRK1I + N*M*NQ + ELSE + DELTSI = DELTAI + DELTNI = DELTAI + TI = DELTAI + TTI = DELTAI + OMEGAI = DELTAI + FJACDI = DELTAI + WRK1I = DELTAI + END IF + + WRK2I = NEXT + WRK3I = WRK2I + N*NQ + WRK4I = WRK3I + NP + WRK5I = WRK4I + M*M + WRK6I = WRK5I + M + WRK7I = WRK6I + N*NQ*NP + NEXT = WRK7I + 5*NQ + + LWKMN = NEXT + ELSE + DELTAI = 1 + EPSI = 1 + XPLUSI = 1 + FNI = 1 + SDI = 1 + VCVI = 1 + RVARI = 1 + WSSI = 1 + WSSDEI = 1 + WSSEPI = 1 + RCONDI = 1 + ETAI = 1 + OLMAVI = 1 + TAUI = 1 + ALPHAI = 1 + ACTRSI = 1 + PNORMI = 1 + RNORSI = 1 + PRERSI = 1 + PARTLI = 1 + SSTOLI = 1 + TAUFCI = 1 + EPSMAI = 1 + BETA0I = 1 + BETACI = 1 + BETASI = 1 + BETANI = 1 + SI = 1 + SSI = 1 + SSFI = 1 + QRAUXI = 1 + FSI = 1 + UI = 1 + FJACBI = 1 + WE1I = 1 + DIFFI = 1 + DELTSI = 1 + DELTNI = 1 + TI = 1 + TTI = 1 + FJACDI = 1 + OMEGAI = 1 + WRK1I = 1 + WRK2I = 1 + WRK3I = 1 + WRK4I = 1 + WRK5I = 1 + WRK6I = 1 + WRK7I = 1 + LWKMN = 1 + END IF + + RETURN + END +*DXMY + SUBROUTINE DXMY + + (N,M,X,LDX,Y,LDY,XMY,LDXMY) +C***BEGIN PROLOGUE DXMY +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE XMY = X - Y +C***END PROLOGUE DXMY + +C...SCALAR ARGUMENTS + INTEGER + + LDX,LDXMY,LDY,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M),XMY(LDXMY,M),Y(LDY,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDXMY: THE LEADING DIMENSION OF ARRAY XMY. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. +C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. +C X: THE FIRST OF THE TWO ARRAYS. +C XMY: THE VALUES OF X-Y. +C Y: THE SECOND OF THE TWO ARRAYS. + + +C***FIRST EXECUTABLE STATEMENT DXMY + + + DO 20 J=1,M + DO 10 I=1,N + XMY(I,J) = X(I,J) - Y(I,J) + 10 CONTINUE + 20 CONTINUE + + RETURN + END +*DXPY + SUBROUTINE DXPY + + (N,M,X,LDX,Y,LDY,XPY,LDXPY) +C***BEGIN PROLOGUE DXPY +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE COMPUTE XPY = X + Y +C***END PROLOGUE DXPY + +C...SCALAR ARGUMENTS + INTEGER + + LDX,LDXPY,LDY,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + X(LDX,M),XPY(LDXPY,M),Y(LDY,M) + +C...LOCAL SCALARS + INTEGER + + I,J + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDX: THE LEADING DIMENSION OF ARRAY X. +C LDXPY: THE LEADING DIMENSION OF ARRAY XPY. +C LDY: THE LEADING DIMENSION OF ARRAY Y. +C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. +C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. +C X: THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER. +C XPY: THE VALUES OF X+Y. +C Y: THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER. + + +C***FIRST EXECUTABLE STATEMENT DXPY + + + DO 20 J=1,M + DO 10 I=1,N + XPY(I,J) = X(I,J) + Y(I,J) + 10 CONTINUE + 20 CONTINUE + + RETURN + END +*DZERO + SUBROUTINE DZERO + + (N,M,A,LDA) +C***BEGIN PROLOGUE DZERO +C***REFER TO DODR,DODRC +C***ROUTINES CALLED (NONE) +C***DATE WRITTEN 860529 (YYMMDD) +C***REVISION DATE 920304 (YYMMDD) +C***PURPOSE SET A = ZERO +C***END PROLOGUE DZERO + +C...SCALAR ARGUMENTS + INTEGER + + LDA,M,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + A(LDA,M) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ZERO + INTEGER + + I,J + +C...DATA STATEMENTS + DATA + + ZERO + + /0.0D0/ + +C...VARIABLE DEFINITIONS (ALPHABETICALLY) +C A: THE ARRAY TO BE SET TO ZERO. +C I: AN INDEXING VARIABLE. +C J: AN INDEXING VARIABLE. +C LDA: THE LEADING DIMENSION OF ARRAY A. +C M: THE NUMBER OF COLUMNS TO BE SET TO ZERO. +C N: THE NUMBER OF ROWS TO BE SET TO ZERO. +C ZERO: THE VALUE 0.0D0. + + +C***FIRST EXECUTABLE STATEMENT DZERO + + + DO 20 J=1,M + DO 10 I=1,N + A(I,J) = ZERO + 10 CONTINUE + 20 CONTINUE + + RETURN + END + +*DASUM + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +C***BEGIN PROLOGUE DASUM +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A3A +C***KEYWORDS ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM, +C VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE SUM OF MAGNITUDES OF D.P. VECTOR COMPONENTS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DASUM DOUBLE PRECISION RESULT (ZERO IF N .LE. 0) +C RETURNS SUM OF MAGNITUDES OF DOUBLE PRECISION DX. +C DASUM = SUM FROM 0 TO N-1 OF DABS(DX(1+I*INCX)) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DASUM + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + INTEGER + + I,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,MOD + + +C***FIRST EXECUTABLE STATEMENT DASUM + + + DASUM = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + NS = N*INCX + DO 10 I=1,NS,INCX + DASUM = DASUM + DABS(DX(I)) + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. + + 20 M = MOD(N,6) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DASUM = DASUM + DABS(DX(I)) + 30 CONTINUE + IF( N .LT. 6 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) + 1 + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) + 50 CONTINUE + RETURN + END +*DAXPY_odr + SUBROUTINE DAXPY_odr(N,DA,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DAXPY_odr +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A7 +C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,TRIAD,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P COMPUTATION Y = A*X + Y +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DA DOUBLE PRECISION SCALAR MULTIPLIER +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DY DOUBLE PRECISION RESULT (UNCHANGED IF N .LE. 0) +C OVERWRITE DOUBLE PRECISION DY WITH DOUBLE PRECISION DA*DX + DY. +C FOR I = 0 TO N-1, REPLACE DY(LY+I*INCY) WITH DA*DX(LX+I*INCX) + +C DY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N +C AND LY IS DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DAXPY_odr + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DAXPY_odr + + + IF(N.LE.0.OR.DA.EQ.0.D0) RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. + + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I + 1) = DY(I + 1) + DA*DX(I + 1) + DY(I + 2) = DY(I + 2) + DA*DX(I + 2) + DY(I + 3) = DY(I + 3) + DA*DX(I + 3) + 50 CONTINUE + RETURN + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DY(I) = DA*DX(I) + DY(I) + 70 CONTINUE + RETURN + END +*DCHEX + SUBROUTINE DCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB) +C***BEGIN PROLOGUE DCHEX +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D7B +C***KEYWORDS CHOLESKY DECOMPOSITION,DOUBLE PRECISION,EXCHANGE, +C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE UPDATES THE CHOLESKY FACTORIZATION A=TRANS(R)*R OF A +C POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL +C PERMUTATIONS OF THE FORM TRANS(E)*A*E WHERE E IS A +C PERMUTATION MATRIX. +C***DESCRIPTION +C DCHEX UPDATES THE CHOLESKY FACTORIZATION +C A = TRANS(R)*R +C OF A POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL +C PERMUTATIONS OF THE FORM +C TRANS(E)*A*E +C WHERE E IS A PERMUTATION MATRIX. SPECIFICALLY, GIVEN +C AN UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX +C E (WHICH IS SPECIFIED BY K, L, AND JOB), DCHEX DETERMINES +C AN ORTHOGONAL MATRIX U SUCH THAT +C U*R*E = RR, +C WHERE RR IS UPPER TRIANGULAR. AT THE USERS OPTION, THE +C TRANSFORMATION U WILL BE MULTIPLIED INTO THE ARRAY Z. +C IF A = TRANS(X)*X, SO THAT R IS THE TRIANGULAR PART OF THE +C QR FACTORIZATION OF X, THEN RR IS THE TRIANGULAR PART OF THE +C QR FACTORIZATION OF X*E, I.E. X WITH ITS COLUMNS PERMUTED. +C FOR A LESS TERSE DESCRIPTION OF WHAT DCHEX DOES AND HOW +C IT MAY BE APPLIED, SEE THE LINPACK GUIDE. +C THE MATRIX Q IS DETERMINED AS THE PRODUCT U(L-K)*...*U(1) +C OF PLANE ROTATIONS OF THE FORM +C ( C(I) S(I) ) +C ( ) , +C ( -S(I) C(I) ) +C WHERE C(I) IS DOUBLE PRECISION. THE ROWS THESE ROTATIONS OPERATE +C ON ARE DESCRIBED BELOW. +C THERE ARE TWO TYPES OF PERMUTATIONS, WHICH ARE DETERMINED +C BY THE VALUE OF JOB. +C 1. RIGHT CIRCULAR SHIFT (JOB = 1). +C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER. +C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. +C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) +C ACTS IN THE (L-I,L-I+1)-PLANE. +C 2. LEFT CIRCULAR SHIFT (JOB = 2). +C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER +C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. +C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) +C ACTS IN THE (K+I-1,K+I)-PLANE. +C ON ENTRY +C R DOUBLE PRECISION(LDR,P), WHERE LDR .GE. P. +C R CONTAINS THE UPPER TRIANGULAR FACTOR +C THAT IS TO BE UPDATED. ELEMENTS OF R +C BELOW THE DIAGONAL ARE NOT REFERENCED. +C LDR INTEGER. +C LDR IS THE LEADING DIMENSION OF THE ARRAY R. +C P INTEGER. +C P IS THE ORDER OF THE MATRIX R. +C K INTEGER. +C K IS THE FIRST COLUMN TO BE PERMUTED. +C L INTEGER. +C L IS THE LAST COLUMN TO BE PERMUTED. +C L MUST BE STRICTLY GREATER THAN K. +C Z DOUBLE PRECISION(LDZ,N)Z), WHERE LDZ .GE. P. +C Z IS AN ARRAY OF NZ P-VECTORS INTO WHICH THE +C TRANSFORMATION U IS MULTIPLIED. Z IS +C NOT REFERENCED IF NZ = 0. +C LDZ INTEGER. +C LDZ IS THE LEADING DIMENSION OF THE ARRAY Z. +C NZ INTEGER. +C NZ IS THE NUMBER OF COLUMNS OF THE MATRIX Z. +C JOB INTEGER. +C JOB DETERMINES THE TYPE OF PERMUTATION. +C JOB = 1 RIGHT CIRCULAR SHIFT. +C JOB = 2 LEFT CIRCULAR SHIFT. +C ON RETURN +C R CONTAINS THE UPDATED FACTOR. +C Z CONTAINS THE UPDATED MATRIX Z. +C C DOUBLE PRECISION(P). +C C CONTAINS THE COSINES OF THE TRANSFORMING ROTATIONS. +C S DOUBLE PRECISION(P). +C S CONTAINS THE SINES OF THE TRANSFORMING ROTATIONS. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DROTG +C***END PROLOGUE DCHEX + +C...SCALAR ARGUMENTS + INTEGER + + JOB,K,L,LDR,LDZ,NZ,P + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + C(*),R(LDR,*),S(*),Z(LDZ,*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + T,T1 + INTEGER + + I,II,IL,IU,J,JJ,KM1,KP1,LM1,LMK + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DROTG + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MAX0,MIN0 + + +C***FIRST EXECUTABLE STATEMENT DCHEX + + + KM1 = K - 1 + KP1 = K + 1 + LMK = L - K + LM1 = L - 1 + +C PERFORM THE APPROPRIATE TASK. + + GO TO (10,130), JOB + +C RIGHT CIRCULAR SHIFT. + + 10 CONTINUE + +C REORDER THE COLUMNS. + + DO 20 I = 1, L + II = L - I + 1 + S(I) = R(II,L) + 20 CONTINUE + DO 40 JJ = K, LM1 + J = LM1 - JJ + K + DO 30 I = 1, J + R(I,J+1) = R(I,J) + 30 CONTINUE + R(J+1,J+1) = 0.0D0 + 40 CONTINUE + IF (K .EQ. 1) GO TO 60 + DO 50 I = 1, KM1 + II = L - I + 1 + R(I,K) = S(II) + 50 CONTINUE + 60 CONTINUE + +C CALCULATE THE ROTATIONS. + + T = S(1) + DO 70 I = 1, LMK + T1 = S(I) + CALL DROTG(S(I+1),T,C(I),T1) + S(I) = T1 + T = S(I+1) + 70 CONTINUE + R(K,K) = T + DO 90 J = KP1, P + IL = MAX0(1,L-J+1) + DO 80 II = IL, LMK + I = L - II + T = C(II)*R(I,J) + S(II)*R(I+1,J) + R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) + R(I,J) = T + 80 CONTINUE + 90 CONTINUE + +C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. + + IF (NZ .LT. 1) GO TO 120 + DO 110 J = 1, NZ + DO 100 II = 1, LMK + I = L - II + T = C(II)*Z(I,J) + S(II)*Z(I+1,J) + Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) + Z(I,J) = T + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + GO TO 260 + +C LEFT CIRCULAR SHIFT + + 130 CONTINUE + +C REORDER THE COLUMNS + + DO 140 I = 1, K + II = LMK + I + S(II) = R(I,K) + 140 CONTINUE + DO 160 J = K, LM1 + DO 150 I = 1, J + R(I,J) = R(I,J+1) + 150 CONTINUE + JJ = J - KM1 + S(JJ) = R(J+1,J+1) + 160 CONTINUE + DO 170 I = 1, K + II = LMK + I + R(I,L) = S(II) + 170 CONTINUE + DO 180 I = KP1, L + R(I,L) = 0.0D0 + 180 CONTINUE + +C REDUCTION LOOP. + + DO 220 J = K, P + IF (J .EQ. K) GO TO 200 + +C APPLY THE ROTATIONS. + + IU = MIN0(J-1,L-1) + DO 190 I = K, IU + II = I - K + 1 + T = C(II)*R(I,J) + S(II)*R(I+1,J) + R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) + R(I,J) = T + 190 CONTINUE + 200 CONTINUE + IF (J .GE. L) GO TO 210 + JJ = J - K + 1 + T = S(JJ) + CALL DROTG(R(J,J),T,C(JJ),S(JJ)) + 210 CONTINUE + 220 CONTINUE + +C APPLY THE ROTATIONS TO Z. + + IF (NZ .LT. 1) GO TO 250 + DO 240 J = 1, NZ + DO 230 I = K, LM1 + II = I - KM1 + T = C(II)*Z(I,J) + S(II)*Z(I+1,J) + Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) + Z(I,J) = T + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + 260 CONTINUE + RETURN + END +*DCOPY_odr + SUBROUTINE DCOPY_odr(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DCOPY_odr +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A5 +C***KEYWORDS BLAS,COPY,DOUBLE PRECISION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. VECTOR COPY Y = X +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DY COPY OF VECTOR DX (UNCHANGED IF N .LE. 0) +C COPY DOUBLE PRECISION DX TO DOUBLE PRECISION DY. +C FOR I = 0 TO N-1, COPY DX(LX+I*INCX) TO DY(LY+I*INCY), +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DCOPY_odr + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DCOPY_odr + + + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. + + 20 M = MOD(N,7) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DX(I) + 30 CONTINUE + IF( N .LT. 7 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,7 + DY(I) = DX(I) + DY(I + 1) = DX(I + 1) + DY(I + 2) = DX(I + 2) + DY(I + 3) = DX(I + 3) + DY(I + 4) = DX(I + 4) + DY(I + 5) = DX(I + 5) + DY(I + 6) = DX(I + 6) + 50 CONTINUE + RETURN + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + 60 CONTINUE + NS=N*INCX + DO 70 I=1,NS,INCX + DY(I) = DX(I) + 70 CONTINUE + RETURN + END +*DDOT_odr + DOUBLE PRECISION FUNCTION DDOT_odr(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DDOT_odr +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A4 +C***KEYWORDS BLAS,DOUBLE PRECISION,INNER PRODUCT,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. INNER PRODUCT OF D.P. VECTORS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DDOT_odr DOUBLE PRECISION DOT PRODUCT (ZERO IF N .LE. 0) +C RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. +C DDOT_odr = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DDOT_odr + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DDOT_odr + + + DDOT_odr = 0.D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DDOT_odr = DDOT_odr + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1. + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. + + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DDOT_odr = DDOT_odr + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DDOT_odr = DDOT_odr + DX(I)*DY(I) + DX(I+1)*DY(I+1) + + 1 DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + RETURN + +C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. + + 60 CONTINUE + NS = N*INCX + DO 70 I=1,NS,INCX + DDOT_odr = DDOT_odr + DX(I)*DY(I) + 70 CONTINUE + RETURN + END +*DNRM2_odr + DOUBLE PRECISION FUNCTION DNRM2_odr(N,DX,INCX) +C***BEGIN PROLOGUE DNRM2_odr +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A3B +C***KEYWORDS BLAS,DOUBLE PRECISION,EUCLIDEAN,L2,LENGTH,LINEAR ALGEBRA, +C NORM,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE EUCLIDEAN LENGTH (L2 NORM) OF D.P. VECTOR +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DNRM2_odr DOUBLE PRECISION RESULT (ZERO IF N .LE. 0) +C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE +C INCREMENT INCX . +C IF N .LE. 0 RETURN WITH RESULT = 0. +C IF N .GE. 1 THEN INCX MUST BE .GE. 1 +C C.L. LAWSON, 1978 JAN 08 +C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE +C HOPEFULLY APPLICABLE TO ALL MACHINES. +C CUTLO = MAXIMUM OF DSQRT(U/EPS) OVER ALL KNOWN MACHINES. +C CUTHI = MINIMUM OF DSQRT(V) OVER ALL KNOWN MACHINES. +C WHERE +C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. +C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) +C V = LARGEST NO. (OVERFLOW LIMIT) +C BRIEF OUTLINE OF ALGORITHM.. +C PHASE 1 SCANS ZERO COMPONENTS. +C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO +C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO +C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M +C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. + +C VALUES FOR CUTLO AND CUTHI.. +C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER +C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. +C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE +C UNIVAC AND DEC AT 2**(-103) +C THUS CUTLO = 2**(-51) = 4.44089E-16 +C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. +C THUS CUTHI = 2**(63.5) = 1.30438E19 +C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. +C THUS CUTLO = 2**(-33.5) = 8.23181D-11 +C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 +C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / +C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DNRM2_odr + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + CUTHI,CUTLO,HITEST,ONE,SUM,XMAX,ZERO + INTEGER + + I,J,NEXT,NN + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DSQRT,FLOAT + +C...DATA STATEMENTS + DATA + + ZERO,ONE/0.0D0,1.0D0/ + DATA + + CUTLO,CUTHI/8.232D-11,1.304D19/ + + +C***FIRST EXECUTABLE STATEMENT DNRM2_odr + + + XMAX = ZERO + IF(N .GT. 0) GO TO 10 + DNRM2_odr = ZERO + GO TO 300 + + 10 ASSIGN 30 TO NEXT + SUM = ZERO + NN = N * INCX +C BEGIN MAIN LOOP + I = 1 +C 20 GO TO NEXT,(30, 50, 70, 110) + 20 GO TO NEXT + 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + ASSIGN 50 TO NEXT + XMAX = ZERO + +C PHASE 1. SUM IS ZERO + + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + +C PREPARE FOR PHASE 2. + ASSIGN 70 TO NEXT + GO TO 105 + +C PREPARE FOR PHASE 4. + + 100 I = J + ASSIGN 110 TO NEXT + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = DABS(DX(I)) + GO TO 115 + +C PHASE 2. SUM IS SMALL. +C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. + + 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 + +C COMMON CODE FOR PHASES 2 AND 4. +C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. + + 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = DABS(DX(I)) + GO TO 200 + + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 + + +C PREPARE FOR PHASE 3. + + 75 SUM = (SUM * XMAX) * XMAX + + +C FOR REAL OR D.P. SET HITEST = CUTHI/N +C FOR COMPLEX SET HITEST = CUTHI/(2*N) + + 85 HITEST = CUTHI/FLOAT( N ) + +C PHASE 3. SUM IS MID-RANGE. NO SCALING. + + DO 95 J =I,NN,INCX + IF(DABS(DX(J)) .GE. HITEST) GO TO 100 + 95 SUM = SUM + DX(J)**2 + DNRM2_odr = DSQRT( SUM ) + GO TO 300 + + 200 CONTINUE + I = I + INCX + IF ( I .LE. NN ) GO TO 20 + +C END OF MAIN LOOP. + +C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. + + DNRM2_odr = XMAX * DSQRT(SUM) + 300 CONTINUE + RETURN + END +*DPODI + SUBROUTINE DPODI(A,LDA,N,DET,JOB) +C***BEGIN PROLOGUE DPODI +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2B1B,D3B1B +C***KEYWORDS DETERMINANT,DOUBLE PRECISION,FACTOR,INVERSE, +C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN DOUBLE +C PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE ABSTRACT) +C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. +C***DESCRIPTION +C DPODI COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN +C DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE BELOW) +C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. +C ON ENTRY +C A DOUBLE PRECISION(LDA, N) +C THE OUTPUT A FROM DPOCO OR DPOFA +C OR THE OUTPUT X FROM DQRDC. +C LDA INTEGER +C THE LEADING DIMENSION OF THE ARRAY A . +C N INTEGER +C THE ORDER OF THE MATRIX A . +C JOB INTEGER +C = 11 BOTH DETERMINANT AND INVERSE. +C = 01 INVERSE ONLY. +C = 10 DETERMINANT ONLY. +C ON RETURN +C A IF DPOCO OR DPOFA WAS USED TO FACTOR A , THEN +C DPODI PRODUCES THE UPPER HALF OF INVERSE(A) . +C IF DQRDC WAS USED TO DECOMPOSE X , THEN +C DPODI PRODUCES THE UPPER HALF OF INVERSE(TRANS(X)*X) +C WHERE TRANS(X) IS THE TRANSPOSE. +C ELEMENTS OF A BELOW THE DIAGONAL ARE UNCHANGED. +C IF THE UNITS DIGIT OF JOB IS ZERO, A IS UNCHANGED. +C DET DOUBLE PRECISION(2) +C DETERMINANT OF A OR OF TRANS(X)*X IF REQUESTED. +C OTHERWISE NOT REFERENCED. +C DETERMINANT = DET(1) * 10.0**DET(2) +C WITH 1.0 .LE. DET(1) .LT. 10.0 +C OR DET(1) .EQ. 0.0 . +C ERROR CONDITION +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 DPOCO OR DPOFA HAS SET INFO .EQ. 0 . +C LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY_odr,DSCAL_odr +C***END PROLOGUE DPODI + +C...SCALAR ARGUMENTS + INTEGER JOB,LDA,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION A(LDA,*),DET(*) + +C...LOCAL SCALARS + DOUBLE PRECISION S,T + INTEGER I,J,JM1,K,KP1 + +C...EXTERNAL SUBROUTINES + EXTERNAL DAXPY_odr,DSCAL_odr + +C...INTRINSIC FUNCTIONS + INTRINSIC MOD + + +C***FIRST EXECUTABLE STATEMENT DPODI + + + IF (JOB/10 .EQ. 0) GO TO 70 + DET(1) = 1.0D0 + DET(2) = 0.0D0 + S = 10.0D0 + DO 50 I = 1, N + DET(1) = A(I,I)**2*DET(1) +C ...EXIT + IF (DET(1) .EQ. 0.0D0) GO TO 60 + 10 IF (DET(1) .GE. 1.0D0) GO TO 20 + DET(1) = S*DET(1) + DET(2) = DET(2) - 1.0D0 + GO TO 10 + 20 CONTINUE + 30 IF (DET(1) .LT. S) GO TO 40 + DET(1) = DET(1)/S + DET(2) = DET(2) + 1.0D0 + GO TO 30 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + +C COMPUTE INVERSE(R) + + IF (MOD(JOB,10) .EQ. 0) GO TO 140 + DO 100 K = 1, N + A(K,K) = 1.0D0/A(K,K) + T = -A(K,K) + CALL DSCAL_odr(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_odr(K,T,A(1,K),1,A(1,J),1) + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + +C FORM INVERSE(R) * TRANS(INVERSE(R)) + + DO 130 J = 1, N + JM1 = J - 1 + IF (JM1 .LT. 1) GO TO 120 + DO 110 K = 1, JM1 + T = A(K,J) + CALL DAXPY_odr(K,T,A(1,J),1,A(1,K),1) + 110 CONTINUE + 120 CONTINUE + T = A(J,J) + CALL DSCAL_odr(J,T,A(1,J),1) + 130 CONTINUE + 140 CONTINUE + RETURN + END +*DQRDC + SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB) +C***BEGIN PROLOGUE DQRDC +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D5 +C***KEYWORDS DECOMPOSITION,DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK, +C MATRIX,ORTHOGONAL TRIANGULAR +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR FACTORI- +C ZATION OF N BY P MATRIX X. COLUMN PIVOTING IS OPTIONAL. +C***DESCRIPTION +C DQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR +C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING +C BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE +C PERFORMED AT THE USER'S OPTION. +C ON ENTRY +C X DOUBLE PRECISION(LDX,P), WHERE LDX .GE. N. +C X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE +C COMPUTED. +C LDX INTEGER. +C LDX IS THE LEADING DIMENSION OF THE ARRAY X. +C N INTEGER. +C N IS THE NUMBER OF ROWS OF THE MATRIX X. +C P INTEGER. +C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. +C JPVT INTEGER(P). +C JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION +C OF THE PIVOT COLUMNS. THE K-TH COLUMN X(K) OF X +C IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE +C VALUE OF JPVT(K). +C IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL +C COLUMN. +C IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN. +C IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN. +C BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS +C ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL +C COLUMNS TO THE END. BOTH INITIAL AND FINAL COLUMNS +C ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY +C FREE COLUMNS ARE MOVED. AT THE K-TH STAGE OF THE +C REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN +C IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST +C REDUCED NORM. JPVT IS NOT REFERENCED IF +C JOB .EQ. 0. +C WORK DOUBLE PRECISION(P). +C WORK IS A WORK ARRAY. WORK IS NOT REFERENCED IF +C JOB .EQ. 0. +C JOB INTEGER. +C JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING. +C IF JOB .EQ. 0, NO PIVOTING IS DONE. +C IF JOB .NE. 0, PIVOTING IS DONE. +C ON RETURN +C X X CONTAINS IN ITS UPPER TRIANGLE THE UPPER +C TRIANGULAR MATRIX R OF THE QR FACTORIZATION. +C BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM +C WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION +C CAN BE RECOVERED. NOTE THAT IF PIVOTING HAS +C BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT +C OF THE ORIGINAL MATRIX X BUT THAT OF X +C WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT. +C QRAUX DOUBLE PRECISION(P). +C QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER +C THE ORTHOGONAL PART OF THE DECOMPOSITION. +C JPVT JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE +C ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO +C THE K-TH COLUMN, IF PIVOTING WAS REQUESTED. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY_odr,DDOT_odr,DNRM2_odr,DSCAL_odr,DSWAP +C***END PROLOGUE DQRDC + +C...SCALAR ARGUMENTS + INTEGER + + JOB,LDX,N,P + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + QRAUX(*),WORK(*),X(LDX,*) + INTEGER + + JPVT(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + MAXNRM,NRMXL,T,TT + INTEGER + + J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU + LOGICAL + + NEGJ,SWAPJ + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr,DNRM2_odr + EXTERNAL + + DDOT_odr,DNRM2_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY_odr,DSCAL_odr,DSWAP + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DMAX1,DSIGN,DSQRT,MIN0 + + +C***FIRST EXECUTABLE STATEMENT DQRDC + + + PL = 1 + PU = 0 + IF (JOB .EQ. 0) GO TO 60 + +C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS +C ACCORDING TO JPVT. + + DO 20 J = 1, P + SWAPJ = JPVT(J) .GT. 0 + NEGJ = JPVT(J) .LT. 0 + JPVT(J) = J + IF (NEGJ) JPVT(J) = -J + IF (.NOT.SWAPJ) GO TO 10 + IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1) + JPVT(J) = JPVT(PL) + JPVT(PL) = J + PL = PL + 1 + 10 CONTINUE + 20 CONTINUE + PU = P + DO 50 JJ = 1, P + J = P - JJ + 1 + IF (JPVT(J) .GE. 0) GO TO 40 + JPVT(J) = -JPVT(J) + IF (J .EQ. PU) GO TO 30 + CALL DSWAP(N,X(1,PU),1,X(1,J),1) + JP = JPVT(PU) + JPVT(PU) = JPVT(J) + JPVT(J) = JP + 30 CONTINUE + PU = PU - 1 + 40 CONTINUE + 50 CONTINUE + 60 CONTINUE + +C COMPUTE THE NORMS OF THE FREE COLUMNS. + + IF (PU .LT. PL) GO TO 80 + DO 70 J = PL, PU + QRAUX(J) = DNRM2_odr(N,X(1,J),1) + WORK(J) = QRAUX(J) + 70 CONTINUE + 80 CONTINUE + +C PERFORM THE HOUSEHOLDER REDUCTION OF X. + + LUP = MIN0(N,P) + DO 200 L = 1, LUP + IF (L .LT. PL .OR. L .GE. PU) GO TO 120 + +C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT +C INTO THE PIVOT POSITION. + + MAXNRM = 0.0D0 + MAXJ = L + DO 100 J = L, PU + IF (QRAUX(J) .LE. MAXNRM) GO TO 90 + MAXNRM = QRAUX(J) + MAXJ = J + 90 CONTINUE + 100 CONTINUE + IF (MAXJ .EQ. L) GO TO 110 + CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1) + QRAUX(MAXJ) = QRAUX(L) + WORK(MAXJ) = WORK(L) + JP = JPVT(MAXJ) + JPVT(MAXJ) = JPVT(L) + JPVT(L) = JP + 110 CONTINUE + 120 CONTINUE + QRAUX(L) = 0.0D0 + IF (L .EQ. N) GO TO 190 + +C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. + + NRMXL = DNRM2_odr(N-L+1,X(L,L),1) + IF (NRMXL .EQ. 0.0D0) GO TO 180 + IF (X(L,L) .NE. 0.0D0) NRMXL = DSIGN(NRMXL,X(L,L)) + CALL DSCAL_odr(N-L+1,1.0D0/NRMXL,X(L,L),1) + X(L,L) = 1.0D0 + X(L,L) + +C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, +C UPDATING THE NORMS. + + LP1 = L + 1 + IF (P .LT. LP1) GO TO 170 + DO 160 J = LP1, P + T = -DDOT_odr(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) + CALL DAXPY_odr(N-L+1,T,X(L,L),1,X(L,J),1) + IF (J .LT. PL .OR. J .GT. PU) GO TO 150 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 150 + TT = 1.0D0 - (DABS(X(L,J))/QRAUX(J))**2 + TT = DMAX1(TT,0.0D0) + T = TT + TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2 + IF (TT .EQ. 1.0D0) GO TO 130 + QRAUX(J) = QRAUX(J)*DSQRT(T) + GO TO 140 + 130 CONTINUE + QRAUX(J) = DNRM2_odr(N-L,X(L+1,J),1) + WORK(J) = QRAUX(J) + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + +C SAVE THE TRANSFORMATION. + + QRAUX(L) = X(L,L) + X(L,L) = -NRMXL + 180 CONTINUE + 190 CONTINUE + 200 CONTINUE + RETURN + END +*DQRSL + SUBROUTINE DQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) +C***BEGIN PROLOGUE DQRSL +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D9,D2A1 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX, +C ORTHOGONAL TRIANGULAR,SOLVE +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE +C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. +C***DESCRIPTION +C DQRSL APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE +C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. +C FOR K .LE. MIN(N,P), LET XK BE THE MATRIX +C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) +C FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL +C N X P MATRIX X THAT WAS INPUT TO DQRDC (IF NO PIVOTING WAS +C DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR +C ORIGINAL ORDER). DQRDC PRODUCES A FACTORED ORTHOGONAL MATRIX Q +C AND AN UPPER TRIANGULAR MATRIX R SUCH THAT +C XK = Q * (R) +C (0) +C THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS +C X AND QRAUX. +C ON ENTRY +C X DOUBLE PRECISION(LDX,P). +C X CONTAINS THE OUTPUT OF DQRDC. +C LDX INTEGER. +C LDX IS THE LEADING DIMENSION OF THE ARRAY X. +C N INTEGER. +C N IS THE NUMBER OF ROWS OF THE MATRIX XK. IT MUST +C HAVE THE SAME VALUE AS N IN DQRDC. +C K INTEGER. +C K IS THE NUMBER OF COLUMNS OF THE MATRIX XK. K +C MUST NOT BE GREATER THAN MIN(N,P), WHERE P IS THE +C SAME AS IN THE CALLING SEQUENCE TO DQRDC. +C QRAUX DOUBLE PRECISION(P). +C QRAUX CONTAINS THE AUXILIARY OUTPUT FROM DQRDC. +C Y DOUBLE PRECISION(N) +C Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED +C BY DQRSL. +C JOB INTEGER. +C JOB SPECIFIES WHAT IS TO BE COMPUTED. JOB HAS +C THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING +C MEANING. +C IF A .NE. 0, COMPUTE QY. +C IF B,C,D, OR E .NE. 0, COMPUTE QTY. +C IF C .NE. 0, COMPUTE B. +C IF D .NE. 0, COMPUTE RSD. +C IF E .NE. 0, COMPUTE XB. +C NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB +C AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR +C WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING +C SEQUENCE. +C ON RETURN +C QY DOUBLE PRECISION(N). +C QY CONTAINS Q*Y, IF ITS COMPUTATION HAS BEEN +C REQUESTED. +C QTY DOUBLE PRECISION(N). +C QTY CONTAINS TRANS(Q)*Y, IF ITS COMPUTATION HAS +C BEEN REQUESTED. HERE TRANS(Q) IS THE +C TRANSPOSE OF THE MATRIX Q. +C B DOUBLE PRECISION(K) +C B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM +C MINIMIZE NORM2(Y - XK*B), +C IF ITS COMPUTATION HAS BEEN REQUESTED. (NOTE THAT +C IF PIVOTING WAS REQUESTED IN DQRDC, THE J-TH +C COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J) +C OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO DQRDC.) +C RSD DOUBLE PRECISION(N). +C RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B, +C IF ITS COMPUTATION HAS BEEN REQUESTED. RSD IS +C ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE +C ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK. +C XB DOUBLE PRECISION(N). +C XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B, +C IF ITS COMPUTATION HAS BEEN REQUESTED. XB IS ALSO +C THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE +C OF X. +C INFO INTEGER. +C INFO IS ZERO UNLESS THE COMPUTATION OF B HAS +C BEEN REQUESTED AND R IS EXACTLY SINGULAR. IN +C THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO +C DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED. +C THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED +C IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE +C CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM. +C TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME +C ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE. A +C FREQUENTLY OCCURING EXAMPLE IS WHEN ONE WISHES TO COMPUTE +C ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY. IN THIS +C CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE +C PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE +C COMPUTED. THUS THE CALLING SEQUENCE +C CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) +C WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD +C OVERWRITING Y. MORE GENERALLY, EACH ITEM IN THE FOLLOWING +C LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR +C A SINGLE CALLING SEQUENCE. +C 1. (Y,QTY,B) (RSD) (XB) (QY) +C 2. (Y,QTY,RSD) (B) (XB) (QY) +C 3. (Y,QTY,XB) (B) (RSD) (QY) +C 4. (Y,QY) (QTY,B) (RSD) (XB) +C 5. (Y,QY) (QTY,RSD) (B) (XB) +C 6. (Y,QY) (QTY,XB) (B) (RSD) +C IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO +C THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY_odr,DCOPY_odr,DDOT_odr +C***END PROLOGUE DQRSL + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,K,LDX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(*),QRAUX(*),QTY(*),QY(*),RSD(*),X(LDX,*),XB(*), + + Y(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + T,TEMP + INTEGER + + I,J,JJ,JU,KP1 + LOGICAL + + CB,CQTY,CQY,CR,CXB + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr + EXTERNAL + + DDOT_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY_odr,DCOPY_odr + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MIN0,MOD + + +C***FIRST EXECUTABLE STATEMENT DQRSL + + + INFO = 0 + +C DETERMINE WHAT IS TO BE COMPUTED. + + CQY = JOB/10000 .NE. 0 + CQTY = MOD(JOB,10000) .NE. 0 + CB = MOD(JOB,1000)/100 .NE. 0 + CR = MOD(JOB,100)/10 .NE. 0 + CXB = MOD(JOB,10) .NE. 0 + JU = MIN0(K,N-1) + +C SPECIAL ACTION WHEN N=1. + + IF (JU .NE. 0) GO TO 40 + IF (CQY) QY(1) = Y(1) + IF (CQTY) QTY(1) = Y(1) + IF (CXB) XB(1) = Y(1) + IF (.NOT.CB) GO TO 30 + IF (X(1,1) .NE. 0.0D0) GO TO 10 + INFO = 1 + GO TO 20 + 10 CONTINUE + B(1) = Y(1)/X(1,1) + 20 CONTINUE + 30 CONTINUE + IF (CR) RSD(1) = 0.0D0 + GO TO 250 + 40 CONTINUE + +C SET UP TO COMPUTE QY OR QTY. + + IF (CQY) CALL DCOPY_odr(N,Y,1,QY,1) + IF (CQTY) CALL DCOPY_odr(N,Y,1,QTY,1) + IF (.NOT.CQY) GO TO 70 + +C COMPUTE QY. + + DO 60 JJ = 1, JU + J = JU - JJ + 1 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 50 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + T = -DDOT_odr(N-J+1,X(J,J),1,QY(J),1)/X(J,J) + CALL DAXPY_odr(N-J+1,T,X(J,J),1,QY(J),1) + X(J,J) = TEMP + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IF (.NOT.CQTY) GO TO 100 + +C COMPUTE TRANS(Q)*Y. + + DO 90 J = 1, JU + IF (QRAUX(J) .EQ. 0.0D0) GO TO 80 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + T = -DDOT_odr(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) + CALL DAXPY_odr(N-J+1,T,X(J,J),1,QTY(J),1) + X(J,J) = TEMP + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + +C SET UP TO COMPUTE B, RSD, OR XB. + + IF (CB) CALL DCOPY_odr(K,QTY,1,B,1) + KP1 = K + 1 + IF (CXB) CALL DCOPY_odr(K,QTY,1,XB,1) + IF (CR .AND. K .LT. N) + + CALL DCOPY_odr(N-K,QTY(KP1),1,RSD(KP1),1) + IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 + DO 110 I = KP1, N + XB(I) = 0.0D0 + 110 CONTINUE + 120 CONTINUE + IF (.NOT.CR) GO TO 140 + DO 130 I = 1, K + RSD(I) = 0.0D0 + 130 CONTINUE + 140 CONTINUE + IF (.NOT.CB) GO TO 190 + +C COMPUTE B. + + DO 170 JJ = 1, K + J = K - JJ + 1 + IF (X(J,J) .NE. 0.0D0) GO TO 150 + INFO = J +C ......EXIT + GO TO 180 + 150 CONTINUE + B(J) = B(J)/X(J,J) + IF (J .EQ. 1) GO TO 160 + T = -B(J) + CALL DAXPY_odr(J-1,T,X(1,J),1,B,1) + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE + 190 CONTINUE + IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 + +C COMPUTE RSD OR XB AS REQUIRED. + + DO 230 JJ = 1, JU + J = JU - JJ + 1 + IF (QRAUX(J) .EQ. 0.0D0) GO TO 220 + TEMP = X(J,J) + X(J,J) = QRAUX(J) + IF (.NOT.CR) GO TO 200 + T = -DDOT_odr(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) + CALL DAXPY_odr(N-J+1,T,X(J,J),1,RSD(J),1) + 200 CONTINUE + IF (.NOT.CXB) GO TO 210 + T = -DDOT_odr(N-J+1,X(J,J),1,XB(J),1)/X(J,J) + CALL DAXPY_odr(N-J+1,T,X(J,J),1,XB(J),1) + 210 CONTINUE + X(J,J) = TEMP + 220 CONTINUE + 230 CONTINUE + 240 CONTINUE + 250 CONTINUE + RETURN + END +*DROT + SUBROUTINE DROT(N,DX,INCX,DY,INCY,DC,DS) +C***BEGIN PROLOGUE DROT +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A8 +C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE APPLY D.P. GIVENS ROTATION +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C DC D.P. ELEMENT OF ROTATION MATRIX +C DS D.P. ELEMENT OF ROTATION MATRIX +C --OUTPUT-- +C DX ROTATED VECTOR (UNCHANGED IF N .LE. 0) +C DY ROTATED VECTOR (UNCHANGED IF N .LE. 0) +C MULTIPLY THE 2 X 2 MATRIX ( DC DS) TIMES THE 2 X N MATRIX (DX**T) +C (-DS DC) (DY**T) +C WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN +C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE +C LX = (-INCX)*N, AND SIMILARLY FOR DY USING LY AND INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DROT + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DC,DS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + ONE,W,Z,ZERO + INTEGER + + I,KX,KY,NSTEPS + +C...DATA STATEMENTS + DATA + + ZERO,ONE/0.D0,1.D0/ + + +C***FIRST EXECUTABLE STATEMENT DROT + + + IF(N .LE. 0 .OR. (DS .EQ. ZERO .AND. DC .EQ. ONE)) GO TO 40 + IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 + + NSTEPS=INCX*N + DO 10 I=1,NSTEPS,INCX + W=DX(I) + Z=DY(I) + DX(I)=DC*W+DS*Z + DY(I)=-DS*W+DC*Z + 10 CONTINUE + GO TO 40 + + 20 CONTINUE + KX=1 + KY=1 + + IF(INCX .LT. 0) KX=1-(N-1)*INCX + IF(INCY .LT. 0) KY=1-(N-1)*INCY + + DO 30 I=1,N + W=DX(KX) + Z=DY(KY) + DX(KX)=DC*W+DS*Z + DY(KY)=-DS*W+DC*Z + KX=KX+INCX + KY=KY+INCY + 30 CONTINUE + 40 CONTINUE + + RETURN + END +*DROTG + SUBROUTINE DROTG(DA,DB,DC,DS) +C***BEGIN PROLOGUE DROTG +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1B10 +C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE CONSTRUCT D.P. PLANE GIVENS ROTATION +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C DA DOUBLE PRECISION SCALAR +C DB DOUBLE PRECISION SCALAR +C --OUTPUT-- +C DA DOUBLE PRECISION RESULT R +C DB DOUBLE PRECISION RESULT Z +C DC DOUBLE PRECISION RESULT +C DS DOUBLE PRECISION RESULT +C DESIGNED BY C. L. LAWSON, JPL, 1977 SEPT 08 +C CONSTRUCT THE GIVENS TRANSFORMATION +C ( DC DS ) +C G = ( ) , DC**2 + DS**2 = 1 , +C (-DS DC ) +C WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (DA,DB)**T . +C THE QUANTITY R = (+/-)DSQRT(DA**2 + DB**2) OVERWRITES DA IN +C STORAGE. THE VALUE OF DB IS OVERWRITTEN BY A VALUE Z WHICH +C ALLOWS DC AND DS TO BE RECOVERED BY THE FOLLOWING ALGORITHM. +C IF Z=1 SET DC=0.D0 AND DS=1.D0 +C IF DABS(Z) .LT. 1 SET DC=DSQRT(1-Z**2) AND DS=Z +C IF DABS(Z) .GT. 1 SET DC=1/Z AND DS=DSQRT(1-DC**2) +C NORMALLY, THE SUBPROGRAM DROT(N,DX,INCX,DY,INCY,DC,DS) WILL +C NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DROTG + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA,DB,DC,DS + +C...LOCAL SCALARS + DOUBLE PRECISION + + R,U,V + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DSQRT + + +C***FIRST EXECUTABLE STATEMENT DROTG + + + IF (DABS(DA) .LE. DABS(DB)) GO TO 10 + +C *** HERE DABS(DA) .GT. DABS(DB) *** + + U = DA + DA + V = DB / U + +C NOTE THAT U AND R HAVE THE SIGN OF DA + + R = DSQRT(.25D0 + V**2) * U + +C NOTE THAT DC IS POSITIVE + + DC = DA / R + DS = V * (DC + DC) + DB = DS + DA = R + RETURN + +C *** HERE DABS(DA) .LE. DABS(DB) *** + + 10 IF (DB .EQ. 0.D0) GO TO 20 + U = DB + DB + V = DA / U + +C NOTE THAT U AND R HAVE THE SIGN OF DB +C (R IS IMMEDIATELY STORED IN DA) + + DA = DSQRT(.25D0 + V**2) * U + +C NOTE THAT DS IS POSITIVE + + DS = DB / DA + DC = V * (DS + DS) + IF (DC .EQ. 0.D0) GO TO 15 + DB = 1.D0 / DC + RETURN + 15 DB = 1.D0 + RETURN + +C *** HERE DA = DB = 0.D0 *** + + 20 DC = 1.D0 + DS = 0.D0 + RETURN + + END +*DSCAL_odr + SUBROUTINE DSCAL_odr(N,DA,DX,INCX) +C***BEGIN PROLOGUE DSCAL_odr +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A6 +C***KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE D.P. VECTOR SCALE X = A*X +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DA DOUBLE PRECISION SCALE FACTOR +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C DX DOUBLE PRECISION RESULT (UNCHANGED IF N.LE.0) +C REPLACE DOUBLE PRECISION DX BY DOUBLE PRECISION DA*DX. +C FOR I = 0 TO N-1, REPLACE DX(1+I*INCX) WITH DA * DX(1+I*INCX) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DSCAL_odr + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + DA + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + INTEGER + + I,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DSCAL_odr + + + IF(N.LE.0)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + NS = N*INCX + DO 10 I = 1,NS,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. + + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I + 1) = DA*DX(I + 1) + DX(I + 2) = DA*DX(I + 2) + DX(I + 3) = DA*DX(I + 3) + DX(I + 4) = DA*DX(I + 4) + 50 CONTINUE + RETURN + END +*DSWAP + SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) +C***BEGIN PROLOGUE DSWAP +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A5 +C***KEYWORDS BLAS,DOUBLE PRECISION,INTERCHANGE,LINEAR ALGEBRA,VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE INTERCHANGE D.P. VECTORS +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY +C --OUTPUT-- +C DX INPUT VECTOR DY (UNCHANGED IF N .LE. 0) +C DY INPUT VECTOR DX (UNCHANGED IF N .LE. 0) +C INTERCHANGE DOUBLE PRECISION DX AND DOUBLE PRECISION DY. +C FOR I = 0 TO N-1, INTERCHANGE DX(LX+I*INCX) AND DY(LY+I*INCY), +C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS +C DEFINED IN A SIMILAR WAY USING INCY. +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE DSWAP + +C...SCALAR ARGUMENTS + INTEGER + + INCX,INCY,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*),DY(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + DTEMP1,DTEMP2,DTEMP3 + INTEGER + + I,IX,IY,M,MP1,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DSWAP + + + IF(N.LE.0)RETURN + IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 + 5 CONTINUE + +C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. + + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP1 = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP1 + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN + +C CODE FOR BOTH INCREMENTS EQUAL TO 1 + + +C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. + + 20 M = MOD(N,3) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 30 CONTINUE + IF( N .LT. 3 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP1 = DX(I) + DTEMP2 = DX(I+1) + DTEMP3 = DX(I+2) + DX(I) = DY(I) + DX(I+1) = DY(I+1) + DX(I+2) = DY(I+2) + DY(I) = DTEMP1 + DY(I+1) = DTEMP2 + DY(I+2) = DTEMP3 + 50 CONTINUE + RETURN + 60 CONTINUE + +C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. + + NS = N*INCX + DO 70 I=1,NS,INCX + DTEMP1 = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP1 + 70 CONTINUE + RETURN + END +*DTRCO + SUBROUTINE DTRCO(T,LDT,N,RCOND,Z,JOB) +C***BEGIN PROLOGUE DTRCO +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A3 +C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, +C MATRIX,TRIANGULAR +C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) +C***PURPOSE ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR +C MATRIX. +C***DESCRIPTION +C DTRCO ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR +C MATRIX. +C ON ENTRY +C T DOUBLE PRECISION(LDT,N) +C T CONTAINS THE TRIANGULAR MATRIX. THE ZERO +C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND +C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE +C USED TO STORE OTHER INFORMATION. +C LDT INTEGER +C LDT IS THE LEADING DIMENSION OF THE ARRAY T. +C N INTEGER +C N IS THE ORDER OF THE SYSTEM. +C JOB INTEGER +C = 0 T IS LOWER TRIANGULAR. +C = NONZERO T IS UPPER TRIANGULAR. +C ON RETURN +C RCOND DOUBLE PRECISION +C AN ESTIMATE OF THE RECIPROCAL CONDITION OF T . +C FOR THE SYSTEM T*X = B , RELATIVE PERTURBATIONS +C IN T 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 T MAY BE SINGULAR TO WORKING +C PRECISION. IN PARTICULAR, RCOND IS ZERO IF +C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE +C UNDERFLOWS. +C Z DOUBLE PRECISION(N) +C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. +C IF T 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 LINPACK. THIS VERSION DATED 08/14/78 . +C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DASUM,DAXPY_odr,DSCAL_odr +C***END PROLOGUE DTRCO + +C...SCALAR ARGUMENTS + DOUBLE PRECISION + + RCOND + INTEGER + + JOB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + T(LDT,*),Z(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + EK,S,SM,TNORM,W,WK,WKM,YNORM + INTEGER + + I1,J,J1,J2,K,KK,L + LOGICAL + + LOWER + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DASUM + EXTERNAL + + DASUM + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY_odr,DSCAL_odr + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS,DMAX1,DSIGN + + +C***FIRST EXECUTABLE STATEMENT DTRCO + + + LOWER = JOB .EQ. 0 + +C COMPUTE 1-NORM OF T + + TNORM = 0.0D0 + DO 10 J = 1, N + L = J + IF (LOWER) L = N + 1 - J + I1 = 1 + IF (LOWER) I1 = J + TNORM = DMAX1(TNORM,DASUM(L,T(I1,J),1)) + 10 CONTINUE + +C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . +C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . +C TRANS(T) IS THE TRANSPOSE OF T . +C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL +C GROWTH IN THE ELEMENTS OF Y . +C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. + +C SOLVE TRANS(T)*Y = E + + EK = 1.0D0 + DO 20 J = 1, N + Z(J) = 0.0D0 + 20 CONTINUE + DO 100 KK = 1, N + K = KK + IF (LOWER) K = N + 1 - KK + IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) + IF (DABS(EK-Z(K)) .LE. DABS(T(K,K))) GO TO 30 + S = DABS(T(K,K))/DABS(EK-Z(K)) + CALL DSCAL_odr(N,S,Z,1) + EK = S*EK + 30 CONTINUE + WK = EK - Z(K) + WKM = -EK - Z(K) + S = DABS(WK) + SM = DABS(WKM) + IF (T(K,K) .EQ. 0.0D0) GO TO 40 + WK = WK/T(K,K) + WKM = WKM/T(K,K) + GO TO 50 + 40 CONTINUE + WK = 1.0D0 + WKM = 1.0D0 + 50 CONTINUE + IF (KK .EQ. N) GO TO 90 + J1 = K + 1 + IF (LOWER) J1 = 1 + J2 = N + IF (LOWER) J2 = K - 1 + DO 60 J = J1, J2 + SM = SM + DABS(Z(J)+WKM*T(K,J)) + Z(J) = Z(J) + WK*T(K,J) + S = S + DABS(Z(J)) + 60 CONTINUE + IF (S .GE. SM) GO TO 80 + W = WKM - WK + WK = WKM + DO 70 J = J1, J2 + Z(J) = Z(J) + W*T(K,J) + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + Z(K) = WK + 100 CONTINUE + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL_odr(N,S,Z,1) + + YNORM = 1.0D0 + +C SOLVE T*Z = Y + + DO 130 KK = 1, N + K = N + 1 - KK + IF (LOWER) K = KK + IF (DABS(Z(K)) .LE. DABS(T(K,K))) GO TO 110 + S = DABS(T(K,K))/DABS(Z(K)) + CALL DSCAL_odr(N,S,Z,1) + YNORM = S*YNORM + 110 CONTINUE + IF (T(K,K) .NE. 0.0D0) Z(K) = Z(K)/T(K,K) + IF (T(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 + I1 = 1 + IF (LOWER) I1 = K + 1 + IF (KK .GE. N) GO TO 120 + W = -Z(K) + CALL DAXPY_odr(N-KK,W,T(I1,K),1,Z(I1),1) + 120 CONTINUE + 130 CONTINUE +C MAKE ZNORM = 1.0 + S = 1.0D0/DASUM(N,Z,1) + CALL DSCAL_odr(N,S,Z,1) + YNORM = S*YNORM + + IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM + IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0 + RETURN + END +*DTRSL_odr + SUBROUTINE DTRSL_odr(T,LDT,N,B,JOB,INFO) +C***BEGIN PROLOGUE DTRSL_odr +C***DATE WRITTEN 780814 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D2A3 +C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, +C TRIANGULAR +C***AUTHOR STEWART, G. W., (U. OF MARYLAND) +C***PURPOSE SOLVES SYSTEMS OF THE FORM T*X=B OR TRANS(T)*X=B WHERE T +C IS A TRIANGULAR MATRIX OF ORDER N. +C***DESCRIPTION +C DTRSL_odr SOLVES SYSTEMS OF THE FORM +C T * X = B +C OR +C TRANS(T) * X = B +C WHERE T IS A TRIANGULAR MATRIX OF ORDER N. HERE TRANS(T) +C DENOTES THE TRANSPOSE OF THE MATRIX T. +C ON ENTRY +C T DOUBLE PRECISION(LDT,N) +C T CONTAINS THE MATRIX OF THE SYSTEM. THE ZERO +C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND +C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE +C USED TO STORE OTHER INFORMATION. +C LDT INTEGER +C LDT IS THE LEADING DIMENSION OF THE ARRAY T. +C N INTEGER +C N IS THE ORDER OF THE SYSTEM. +C B DOUBLE PRECISION(N). +C B CONTAINS THE RIGHT HAND SIDE OF THE SYSTEM. +C JOB INTEGER +C JOB SPECIFIES WHAT KIND OF SYSTEM IS TO BE SOLVED. +C IF JOB IS +C 00 SOLVE T*X=B, T LOWER TRIANGULAR, +C 01 SOLVE T*X=B, T UPPER TRIANGULAR, +C 10 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, +C 11 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. +C ON RETURN +C B B CONTAINS THE SOLUTION, IF INFO .EQ. 0. +C OTHERWISE B IS UNALTERED. +C INFO INTEGER +C INFO CONTAINS ZERO IF THE SYSTEM IS NONSINGULAR. +C OTHERWISE INFO CONTAINS THE INDEX OF +C THE FIRST ZERO DIAGONAL ELEMENT OF T. +C LINPACK. THIS VERSION DATED 08/14/78 . +C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. +C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., +C *LINPACK USERS GUIDE*, SIAM, 1979. +C***ROUTINES CALLED DAXPY_odr,DDOT_odr +C***END PROLOGUE DTRSL_odr + +C...SCALAR ARGUMENTS + INTEGER + + INFO,JOB,LDT,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + B(*),T(LDT,*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + TEMP + INTEGER + + CASE,J,JJ + +C...EXTERNAL FUNCTIONS + DOUBLE PRECISION + + DDOT_odr + EXTERNAL + + DDOT_odr + +C...EXTERNAL SUBROUTINES + EXTERNAL + + DAXPY_odr + +C...INTRINSIC FUNCTIONS + INTRINSIC + + MOD + + +C***FIRST EXECUTABLE STATEMENT DTRSL_odr + + +C BEGIN BLOCK PERMITTING ...EXITS TO 150 + +C CHECK FOR ZERO DIAGONAL ELEMENTS. + + DO 10 INFO = 1, N +C ......EXIT + IF (T(INFO,INFO) .EQ. 0.0D0) GO TO 150 + 10 CONTINUE + INFO = 0 + +C DETERMINE THE TASK AND GO TO IT. + + CASE = 1 + IF (MOD(JOB,10) .NE. 0) CASE = 2 + IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 + GO TO (20,50,80,110), CASE + +C SOLVE T*X=B FOR T LOWER TRIANGULAR + + 20 CONTINUE + B(1) = B(1)/T(1,1) + IF (N .LT. 2) GO TO 40 + DO 30 J = 2, N + TEMP = -B(J-1) + CALL DAXPY_odr(N-J+1,TEMP,T(J,J-1),1,B(J),1) + B(J) = B(J)/T(J,J) + 30 CONTINUE + 40 CONTINUE + GO TO 140 + +C SOLVE T*X=B FOR T UPPER TRIANGULAR. + + 50 CONTINUE + B(N) = B(N)/T(N,N) + IF (N .LT. 2) GO TO 70 + DO 60 JJ = 2, N + J = N - JJ + 1 + TEMP = -B(J+1) + CALL DAXPY_odr(J,TEMP,T(1,J+1),1,B(1),1) + B(J) = B(J)/T(J,J) + 60 CONTINUE + 70 CONTINUE + GO TO 140 + +C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. + + 80 CONTINUE + B(N) = B(N)/T(N,N) + IF (N .LT. 2) GO TO 100 + DO 90 JJ = 2, N + J = N - JJ + 1 + B(J) = B(J) - DDOT_odr(JJ-1,T(J+1,J),1,B(J+1),1) + B(J) = B(J)/T(J,J) + 90 CONTINUE + 100 CONTINUE + GO TO 140 + +C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. + + 110 CONTINUE + B(1) = B(1)/T(1,1) + IF (N .LT. 2) GO TO 130 + DO 120 J = 2, N + B(J) = B(J) - DDOT_odr(J-1,T(1,J),1,B(1),1) + B(J) = B(J)/T(J,J) + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + RETURN + END +*IDAMAX + INTEGER FUNCTION IDAMAX(N,DX,INCX) +C***BEGIN PROLOGUE IDAMAX +C***DATE WRITTEN 791001 (YYMMDD) +C***REVISION DATE 820801 (YYMMDD) +C***CATEGORY NO. D1A2 +C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT, +C VECTOR +C***AUTHOR LAWSON, C. L., (JPL) +C HANSON, R. J., (SNLA) +C KINCAID, D. R., (U. OF TEXAS) +C KROGH, F. T., (JPL) +C***PURPOSE FIND LARGEST COMPONENT OF D.P. VECTOR +C***DESCRIPTION +C B L A S SUBPROGRAM +C DESCRIPTION OF PARAMETERS +C --INPUT-- +C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) +C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS +C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX +C --OUTPUT-- +C IDAMAX SMALLEST INDEX (ZERO IF N .LE. 0) +C FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF DOUBLE PRECISION DX. +C IDAMAX = FIRST I, I = 1 TO N, TO MINIMIZE ABS(DX(1-INCX+I*INCX) +C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., +C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, +C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL +C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 +C***ROUTINES CALLED (NONE) +C***END PROLOGUE IDAMAX + +C...SCALAR ARGUMENTS + INTEGER + + INCX,N + +C...ARRAY ARGUMENTS + DOUBLE PRECISION + + DX(*) + +C...LOCAL SCALARS + DOUBLE PRECISION + + DMAX,XMAG + INTEGER + + I,II,NS + +C...INTRINSIC FUNCTIONS + INTRINSIC + + DABS + + +C***FIRST EXECUTABLE STATEMENT IDAMAX + + + IDAMAX = 0 + IF(N.LE.0) RETURN + IDAMAX = 1 + IF(N.LE.1)RETURN + IF(INCX.EQ.1)GOTO 20 + +C CODE FOR INCREMENTS NOT EQUAL TO 1. + + DMAX = DABS(DX(1)) + NS = N*INCX + II = 1 + DO 10 I = 1,NS,INCX + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 5 + IDAMAX = II + DMAX = XMAG + 5 II = II + 1 + 10 CONTINUE + RETURN + +C CODE FOR INCREMENTS EQUAL TO 1. + + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + XMAG = DABS(DX(I)) + IF(XMAG.LE.DMAX) GO TO 30 + IDAMAX = I + DMAX = XMAG + 30 CONTINUE + RETURN + END + diff --git a/dataassim/math/optimization/phenofit.f b/dataassim/math/optimization/phenofit.f new file mode 100644 index 0000000..98baed7 --- /dev/null +++ b/dataassim/math/optimization/phenofit.f @@ -0,0 +1,497 @@ + subroutine phenofit(nphenocycl0,iphenodowhat0,phenocyclmark, + &ntotpoints,phenoy,phenox,y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax, + &bmin,bmax,cmin,cmax,y0min,y0max,x01min,x01max,x02min,x02max,ndim, + &beta,phenoy0,abcx,predphenoy,predphenox,sumsquare) + implicit none + integer nphenocycl0,iphenodowhat0(nphenocycl0),ntotpoints + double precision phenocyclmark(nphenocycl0),phenoy(ntotpoints), + &phenox(ntotpoints),y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax,bmin, + &bmax,cmin,cmax,y0min,y0max,x01min,x01max,x02min,x02max,phenoy0, + &abcx(nphenocycl0,8),predphenoy(ntotpoints),predphenox(ntotpoints), + &sumsquare +!nphenocycl: the number of individual cycle units +!iphenodowhat: an index specifying what mathematical function to use for each individual cycle unit +!iphenodowhat= 1 - 4: double function cycle (paired sigmoid functions) +! =1: all parameters, 8 params +! =2: c1 and c2 set 1, 6 params +! =3: c1=c2=1, a1=a2, 5 params +! =4: a1=a2, 7 params +!iphenodowhat= 5 - 6: single function cycle (a2, b2, c2 and x02 are not used) +! =5: a1, b1, c1, x01. 4 parameters +! =6: a1, b1, x01. 3 parameters (c1 is set to be 1) +! +!ntotpoints: the total number of points in all cycle units +!phenoy: the y variable +!phenox: the x variable +!y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax,bmin,bmax,cmin,cmax,y0min,y0max,x01min,x01max,x02min,x02max: +! - initial guesses and their bounds +!ndim: the total number of parameters estimated +!phenoy0: the estimated y0 +!abcx: The parameters estimated for each cycle unit. (-0.9999 indicating not used) +! abcx(i,1)=a1 +! abcx(i,2)=b1 +! abcx(i,3)=c1 +! abcx(i,4)=x01 +! abcx(i,5)=a2 +! abcx(i,6)=b2 +! abcx(i,7)=c2 +! abcx(i,8)=x02 +!predphenoy: the predicted y variable for each phenox +!predphenox: the predicted x variable in case orthorgonal regression is used. + integer iderivative,INFO,j,ndim + double precision beta(nphenocycl0*8+1),betamin(nphenocycl0*8+1), + &betamax(nphenocycl0*8+1),weitphenox(ntotpoints), + &phenoxmin(ntotpoints),phenoxmax(ntotpoints),weitphenoy(ntotpoints) +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer nphenocycl,iphenodowhat(100) + COMMON /phenocom/nphenocycl,iphenodowhat + save /phenocom/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + nphenocycl=nphenocycl0 + do j=1,nphenocycl + iphenodowhat(j)=iphenodowhat0(j) + enddo + call phenoparams_init(nphenocycl,iphenodowhat,phenocyclmark, + &y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax,bmin,bmax,cmin,cmax,y0min, + &y0max,x01min,x01max,x02min,x02max,beta,betamin,betamax,ndim) + iderivative=1 + INFO=0 +!INFO =0, ordinary distance regression +!INFO =1, explicit orthogonal distance regression with shortest distance within iteration +!INFO =2, explicit orthogonal distance regression with x positions as parameters + do j=1,ntotpoints + weitphenox(j)=1.0d0 + phenoxmin(j)=phenox(j)-20.0d0 + phenoxmax(j)=phenox(j)+20.0d0 + weitphenoy(j)=1.0d0 + enddo + call GenericRegres(ntotpoints,1,phenoy,1,phenox,weitphenoy, + &weitphenox,ndim,beta,betamin,betamax,phenoxmin,phenoxmax, + &iderivative,INFO,predphenoy,predphenox,sumsquare) + phenoy0=beta(1) + call phenoparams_alloc(nphenocycl,iphenodowhat,beta,abcx) + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine surffunc(nyvars,yvars,nxvars, + & xvars,ndim,beta,dydxp,idowhat) + implicit none +!idowhat=0, value of the function only +! =1, derivative with respect to the independent variable x and value of the function +! =2, derivative with respect to the parameters and value of the function + integer nyvars,nxvars,ndim,idowhat + double precision yvars(nyvars),xvars(nxvars), + & beta(ndim),dydxp(nyvars,(nxvars+ndim)) +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer nphenocycl,iphenodowhat(100) + COMMON /phenocom/nphenocycl,iphenodowhat + save /phenocom/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + integer j,NParam,i + double precision y0,a1,b1,c1,x01,a2,b2,c2,x02, + &abcx(1:nphenocycl,1:8),twoexpfunc,sigmoidfunc,grad(10) + y0=beta(1) + call phenoparams_alloc(nphenocycl,iphenodowhat,beta, + &abcx(1:nphenocycl,1:8)) + +! write(*,*)y0,ndim +! do j=1,nphenocycl +! write(*,330)(abcx(j,i),i=1,8) +! enddo +!330 format(8(f15.6)) +! pause + + yvars(1)=y0 + do j=1,nphenocycl + a1=abcx(j,1) + b1=abcx(j,2) + c1=abcx(j,3) + x01=abcx(j,4) + if(iphenodowhat(j).le.4)then + a2=abcx(j,5) + b2=abcx(j,6) + c2=abcx(j,7) + x02=abcx(j,8) + yvars(1)=yvars(1)+ + &twoexpfunc(0.0d0,a1,b1,c1,x01,a2,b2,c2,x02,xvars(1)) + else + yvars(1)=yvars(1)+sigmoidfunc(0.0d0,a1,b1,c1,x01,xvars(1)) + endif + enddo + if(idowhat.eq.1)then + dydxp(1,1)=0.0d0 + do j=1,nphenocycl + a1=abcx(j,1) + b1=abcx(j,2) + c1=abcx(j,3) + x01=abcx(j,4) + if(iphenodowhat(j).le.4)then + a2=abcx(j,5) + b2=abcx(j,6) + c2=abcx(j,7) + x02=abcx(j,8) + call gradtwoexp(0.0d0,a1,b1,c1,x01, + &a2,b2,c2,x02,xvars(1),grad) + else + call gradsigmoidfunc(0.0d0,a1,b1,c1,x01,xvars(1),grad) + endif + dydxp(1,1)=dydxp(1,1)+grad(6) + enddo + endif + if(idowhat.eq.2)then + NParam=1 + dydxp(1,1)=1.0d0 + do j=1,nphenocycl + a1=abcx(j,1) + b1=abcx(j,2) + c1=abcx(j,3) + x01=abcx(j,4) + if(iphenodowhat(j).le.4)then + a2=abcx(j,5) + b2=abcx(j,6) + c2=abcx(j,7) + x02=abcx(j,8) + call gradtwoexp(0.0d0,a1,b1,c1,x01, + &a2,b2,c2,x02,xvars(1),grad) + else + call gradsigmoidfunc(0.0d0,a1,b1,c1,x01,xvars(1),grad) + endif +! a1<->grad(1) +! b1<->grad(2) +! c1<->grad(3) +! x01<->grad(4) +! y0<->grad(5) +! x<->grad(6) +! a2<->grad(7) +! b2<->grad(8) +! c2<->grad(9) +! x02<->grad(10) + if(iphenodowhat(j).eq.1)then +! all parameters in the two exp functions + dydxp(1,NParam+1)=grad(1) + dydxp(1,NParam+2)=grad(2) + dydxp(1,NParam+3)=grad(3) + dydxp(1,NParam+4)=grad(4) + dydxp(1,NParam+5)=grad(7) + dydxp(1,NParam+6)=grad(8) + dydxp(1,NParam+7)=grad(9) + dydxp(1,NParam+8)=grad(10) + NParam=NParam+8 + endif + if(iphenodowhat(j).eq.2)then +! c1=c2=1.0 + dydxp(1,NParam+1)=grad(1) + dydxp(1,NParam+2)=grad(2) + dydxp(1,NParam+3)=grad(4) + dydxp(1,NParam+4)=grad(7) + dydxp(1,NParam+5)=grad(8) + dydxp(1,NParam+6)=grad(10) + NParam=NParam+6 + endif + if(iphenodowhat(j).eq.3)then +! c1=c2=1.0 +! a1=a2 + dydxp(1,NParam+1)=grad(1)+grad(7) + dydxp(1,NParam+2)=grad(2) + dydxp(1,NParam+3)=grad(4) + dydxp(1,NParam+4)=grad(8) + dydxp(1,NParam+5)=grad(10) + NParam=NParam+5 + endif + if(iphenodowhat(j).eq.4)then +! a1=a2 + dydxp(1,NParam+1)=grad(1)+grad(7) + dydxp(1,NParam+2)=grad(2) + dydxp(1,NParam+3)=grad(3) + dydxp(1,NParam+4)=grad(4) + dydxp(1,NParam+5)=grad(8) + dydxp(1,NParam+6)=grad(9) + dydxp(1,NParam+7)=grad(10) + NParam=NParam+7 + endif + if(iphenodowhat(j).eq.5)then +! single function, 4 parameters + dydxp(1,NParam+1)=grad(1) + dydxp(1,NParam+2)=grad(2) + dydxp(1,NParam+3)=grad(3) + dydxp(1,NParam+4)=grad(4) + NParam=NParam+4 + endif + if(iphenodowhat(j).eq.6)then +! single function, 3 parameters, c=1 + dydxp(1,NParam+1)=grad(1) + dydxp(1,NParam+2)=grad(2) + dydxp(1,NParam+3)=grad(4) + NParam=NParam+3 + endif + enddo + endif + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine phenoparams_init(nphenocycl,iphenodowhat,phenocyclmark, + &y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax,bmin,bmax,cmin,cmax,y0min, + &y0max,x01min,x01max,x02min,x02max,BETA,BETAmin,BETAmax,NParam) + implicit none + integer nphenocycl,iphenodowhat(nphenocycl),NParam,i + double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,amin,amax,bmin,bmax, + &cmin,cmax,x01min,x01max,x02min,x02max,y0min,y0max, + &BETA(nphenocycl*8+1),BETAmin(nphenocycl*8+1), + &BETAmax(nphenocycl*8+1),phenocyclmark(nphenocycl) +!number of parameters for each phenocycl +!iphenodowhat= 1 - 4: double function cycle +! =1: all parameters, 8 params +! =2: c1 and c2 set 1, 6 params +! =3: c1=c2=1, a1=a2, 5 params +! =4: a1=a2, 7 params +! +!iphenodowhat= 5 - 6: single function cycle +! =5: a, b, c, x0. 4 parameters +! =6: a, b, x0. c is set to be 1 +! +! abcx(i,1)=a1 +! abcx(i,2)=b1 +! abcx(i,3)=c1 +! abcx(i,4)=x01 +! abcx(i,5)=a2 +! abcx(i,6)=b2 +! abcx(i,7)=c2 +! abcx(i,8)=x02 + NParam=1 + BETA(1)=y0 + BETAmin(1)=y0min + BETAmax(1)=y0max + do i=1,nphenocycl + if(iphenodowhat(i).eq.1)then +! all parameters in the two exp functions + BETA(NParam+1)=a1 + BETA(NParam+2)=b1 + BETA(NParam+3)=c1 + BETA(NParam+4)=phenocyclmark(i)+x01 + BETA(NParam+5)=a2 + BETA(NParam+6)=b2 + BETA(NParam+7)=c2 + BETA(NParam+8)=phenocyclmark(i)+x02 + BETAmin(NParam+1)=amin + BETAmax(NParam+1)=amax + BETAmin(NParam+2)=bmin + BETAmax(NParam+2)=bmax + BETAmin(NParam+3)=cmin + BETAmax(NParam+3)=cmax + BETAmin(NParam+4)=phenocyclmark(i)+x01min + BETAmax(NParam+4)=phenocyclmark(i)+x01max + BETAmin(NParam+5)=BETAmin(NParam+1) + BETAmax(NParam+5)=BETAmax(NParam+1) + BETAmin(NParam+6)=BETAmin(NParam+2) + BETAmax(NParam+6)=BETAmax(NParam+2) + BETAmin(NParam+7)=BETAmin(NParam+3) + BETAmax(NParam+7)=BETAmax(NParam+3) + BETAmin(NParam+8)=phenocyclmark(i)+x02min + BETAmax(NParam+8)=phenocyclmark(i)+x02max + NParam=NParam+8 + endif + if(iphenodowhat(i).eq.2)then +! c1=c2=1.0 + BETA(NParam+1)=a1 + BETA(NParam+2)=b1 + BETA(NParam+3)=phenocyclmark(i)+x01 + BETA(NParam+4)=a2 + BETA(NParam+5)=b2 + BETA(NParam+6)=phenocyclmark(i)+x02 + BETAmin(NParam+1)=amin + BETAmax(NParam+1)=amax + BETAmin(NParam+2)=bmin + BETAmax(NParam+2)=bmax + BETAmin(NParam+3)=phenocyclmark(i)+x01min + BETAmax(NParam+3)=phenocyclmark(i)+x01max + BETAmin(NParam+4)=BETAmin(NParam+1) + BETAmax(NParam+4)=BETAmax(NParam+1) + BETAmin(NParam+5)=BETAmin(NParam+2) + BETAmax(NParam+5)=BETAmax(NParam+2) + BETAmin(NParam+6)=phenocyclmark(i)+x01min + BETAmax(NParam+6)=phenocyclmark(i)+x02max + NParam=NParam+6 + endif + if(iphenodowhat(i).eq.3)then +! c1=c2=1.0 +! a1=a2 + BETA(NParam+1)=a1 + BETA(NParam+2)=b1 + BETA(NParam+3)=phenocyclmark(i)+x01 + BETA(NParam+4)=b2 + BETA(NParam+5)=phenocyclmark(i)+x02 + BETAmin(NParam+1)=amin + BETAmax(NParam+1)=amax + BETAmin(NParam+2)=bmin + BETAmax(NParam+2)=bmax + BETAmin(NParam+3)=phenocyclmark(i)+x01min + BETAmax(NParam+3)=phenocyclmark(i)+x01max + BETAmin(NParam+4)=BETAmin(NParam+2) + BETAmax(NParam+4)=BETAmax(NParam+2) + BETAmin(NParam+5)=phenocyclmark(i)+x02min + BETAmax(NParam+5)=phenocyclmark(i)+x02max + NParam=NParam+5 + endif + if(iphenodowhat(i).eq.4)then +! a1=a2 + BETA(NParam+1)=a1 + BETA(NParam+2)=b1 + BETA(NParam+3)=c1 + BETA(NParam+4)=phenocyclmark(i)+x01 + BETA(NParam+5)=b2 + BETA(NParam+6)=c2 + BETA(NParam+7)=phenocyclmark(i)+x02 + BETAmin(NParam+1)=amin + BETAmax(NParam+1)=amax + BETAmin(NParam+2)=bmin + BETAmax(NParam+2)=bmax + BETAmin(NParam+3)=cmin + BETAmax(NParam+3)=cmax + BETAmin(NParam+4)=phenocyclmark(i)+x01min + BETAmax(NParam+4)=phenocyclmark(i)+x01max + BETAmin(NParam+5)=BETAmin(NParam+2) + BETAmax(NParam+5)=BETAmax(NParam+2) + BETAmin(NParam+6)=BETAmin(NParam+3) + BETAmax(NParam+6)=BETAmax(NParam+3) + BETAmin(NParam+7)=phenocyclmark(i)+x02min + BETAmax(NParam+7)=phenocyclmark(i)+x02max + NParam=NParam+7 + endif + if(iphenodowhat(i).eq.5)then +! single function, 4 parameters + BETA(NParam+1)=a1 + BETA(NParam+2)=b1 + BETA(NParam+3)=c1 + BETA(NParam+4)=phenocyclmark(i)+x01 + BETAmin(NParam+1)=amin + BETAmax(NParam+1)=amax + BETAmin(NParam+2)=bmin + BETAmax(NParam+2)=bmax + BETAmin(NParam+3)=cmin + BETAmax(NParam+3)=cmax + BETAmin(NParam+4)=phenocyclmark(i)+x01min + BETAmax(NParam+4)=phenocyclmark(i)+x01max + NParam=NParam+4 + endif + if(iphenodowhat(i).eq.6)then +! single function, 3 parameters, c=1 + BETA(NParam+1)=a1 + BETA(NParam+2)=b1 + BETA(NParam+3)=phenocyclmark(i)+x01 + BETAmin(NParam+1)=amin + BETAmax(NParam+1)=amax + BETAmin(NParam+2)=bmin + BETAmax(NParam+2)=bmax + BETAmin(NParam+3)=phenocyclmark(i)+x01min + BETAmax(NParam+3)=phenocyclmark(i)+x01max + NParam=NParam+3 + endif + enddo + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine phenoparams_alloc(nphenocycl,iphenodowhat,BETA,abcx) + implicit none + integer nphenocycl,iphenodowhat(nphenocycl) + double precision BETA(nphenocycl*8+1),abcx(nphenocycl,8) + integer NParam,i + +!number of parameters for each phenocycl +!iphenodowhat= 1 - 4: double function cycle +! =1: all parameters, 8 params +! =2: c1 and c2 set 1, 6 params +! =3: c1=c2=1, a1=a2, 5 params +! =4: a1=a2, 7 params +! +!iphenodowhat= 5 - 6: single function cycle +! =5: a, b, c, x0. 4 parameters +! =6: a, b, x0. c is set to be 1 + +! abcx(i,1)=a1 +! abcx(i,2)=b1 +! abcx(i,3)=c1 +! abcx(i,4)=x01 +! abcx(i,5)=a2 +! abcx(i,6)=b2 +! abcx(i,7)=c2 +! abcx(i,8)=x02 + + NParam=1 + do i=1,nphenocycl + if(iphenodowhat(i).eq.1)then +! all parameters in the two exp functions + abcx(i,1)=BETA(NParam+1) + abcx(i,2)=BETA(NParam+2) + abcx(i,3)=BETA(NParam+3) + abcx(i,4)=BETA(NParam+4) + abcx(i,5)=BETA(NParam+5) + abcx(i,6)=BETA(NParam+6) + abcx(i,7)=BETA(NParam+7) + abcx(i,8)=BETA(NParam+8) + NParam=NParam+8 + endif + if(iphenodowhat(i).eq.2)then +! c1=c2=1.0 + abcx(i,1)=BETA(NParam+1) + abcx(i,2)=BETA(NParam+2) + abcx(i,3)=1.0d0 + abcx(i,4)=BETA(NParam+3) + abcx(i,5)=BETA(NParam+4) + abcx(i,6)=BETA(NParam+5) + abcx(i,7)=1.0d0 + abcx(i,8)=BETA(NParam+6) + NParam=NParam+6 + endif + if(iphenodowhat(i).eq.3)then +! c1=c2=1.0 +! a1=a2 + abcx(i,1)=BETA(NParam+1) + abcx(i,2)=BETA(NParam+2) + abcx(i,3)=1.0d0 + abcx(i,4)=BETA(NParam+3) + abcx(i,5)=abcx(i,1) + abcx(i,6)=BETA(NParam+4) + abcx(i,7)=1.0d0 + abcx(i,8)=BETA(NParam+5) + NParam=NParam+5 + endif + if(iphenodowhat(i).eq.4)then +! a1=a2 + abcx(i,1)=BETA(NParam+1) + abcx(i,2)=BETA(NParam+2) + abcx(i,3)=BETA(NParam+3) + abcx(i,4)=BETA(NParam+4) + abcx(i,5)=abcx(i,1) + abcx(i,6)=BETA(NParam+5) + abcx(i,7)=BETA(NParam+6) + abcx(i,8)=BETA(NParam+7) + NParam=NParam+7 + endif + if(iphenodowhat(i).eq.5)then +! single function, 4 parameters + abcx(i,1)=BETA(NParam+1) + abcx(i,2)=BETA(NParam+2) + abcx(i,3)=BETA(NParam+3) + abcx(i,4)=BETA(NParam+4) + abcx(i,5)=0.0d0 + abcx(i,6)=-0.9999d0 + abcx(i,7)=0.0d0 + abcx(i,8)=-0.9999d0 + NParam=NParam+4 + endif + if(iphenodowhat(i).eq.6)then +! single function, 3 parameters + abcx(i,1)=BETA(NParam+1) + abcx(i,2)=BETA(NParam+2) + abcx(i,3)=1.0d0 + abcx(i,4)=BETA(NParam+3) + abcx(i,5)=0.0d0 + abcx(i,6)=-0.9999d0 + abcx(i,7)=0.0d0 + abcx(i,8)=-0.9999d0 + NParam=NParam+3 + endif + enddo + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/optimization/pikaia.f b/dataassim/math/optimization/pikaia.f new file mode 100644 index 0000000..2e81d49 --- /dev/null +++ b/dataassim/math/optimization/pikaia.f @@ -0,0 +1,1317 @@ + program main +c====================================================================== +c Sample driver program for pikaia.f +c====================================================================== + implicit none + integer n, seed, i, icondi + parameter (n=2) + real ctrl(12), x(n), f, twod + external twod +c +c (twod is an example fitness function, a smooth 2-d landscape) +c +c First, initialize the random-number generator +c + 1 write(*,'(/A$)') ' Random number seed (I*4)? ' + read(*,*) seed + call rninit(seed) +c +c Set control variables (use defaults) + do 10 i=1,12 + ctrl(i) = -1 + 10 continue + ctrl(2)=50000 + +c Now call pikaia + call pikaia(twod,n,ctrl,x,f,icondi) +c +c Print the results + write(*,*) ' icondi: ',icondi + write(*,*) ' x: ',x + write(*,*) ' f: ',f + write(*,20) ctrl + 20 format( ' ctrl: ',6f9.5/10x,6f9.5) +c + goto 1 + end +c********************************************************************* + function twod(n,x) +c===================================================================== +c Compute sample fitness function (2-d landscape) +c===================================================================== + implicit none +c +c Input: + integer n + real x(n) +c +c Output + real twod +c +c Constant + real pi,sigma2 + integer nn + parameter (pi=3.1415926536,sigma2=0.15,nn=9) +c +c Local + real rr + + twod=(x(1)-0.5)**2+(x(2)-0.6)**2+1.0 + + twod=1.0/twod + + return + + if (x(1).gt.1..or.x(2).gt.1.) stop + rr=sqrt( (0.5-x(1))**2+ (0.5-x(2))**2) + twod=cos(rr*nn*pi)**2 *exp(-rr**2/sigma2) + + + + return + end +c********************************************************************* + function urand() +c===================================================================== +c Return the next pseudo-random deviate from a sequence which is +c uniformly distributed in the interval [0,1] +c +c Uses the function ran0, the "minimal standard" random number +c generator of Park and Miller (Comm. ACM 31, 1192-1201, Oct 1988; +c Comm. ACM 36 No. 7, 105-110, July 1993). +c===================================================================== + implicit none +c +c Input - none +c +c Output + real urand +c +c Local + integer iseed + real ran0 + external ran0 +c +c Common block to make iseed visible to rninit (and to save +c it between calls) + common /rnseed/ iseed +c + urand = ran0( iseed ) + return + end +c********************************************************************* + subroutine rninit( seed ) +c===================================================================== +c Initialize random number generator urand with given seed +c===================================================================== + implicit none +c +c Input + integer seed +c +c Output - none +c +c Local + integer iseed +c +c Common block to communicate with urand + common /rnseed/ iseed +c +c Set the seed value + iseed = seed + if(iseed.le.0) iseed=123456 + return + end +c********************************************************************* + function ran0( seed ) +c===================================================================== +c "Minimal standard" pseudo-random number generator of Park and +c Miller. Returns a uniform random deviate r s.t. 0 < r < 1.0. +c Set seed to any non-zero integer value to initialize a sequence, +c then do not change seed between calls for successive deviates +c in the sequence. +c +c References: +c Park, S. and Miller, K., "Random Number Generators: Good Ones +c are Hard to Find", Comm. ACM 31, 1192-1201 (Oct. 1988) +c Park, S. and Miller, K., in "Remarks on Choosing and Imple- +c menting Random Number Generators", Comm. ACM 36 No. 7, +c 105-110 (July 1993) +c===================================================================== +c *** Declaration section *** +c + implicit none +c +c Input/Output: + integer seed +c +c Output: + real ran0 +c +c Constants: + integer A,M,Q,R + parameter (A=48271,M=2147483647,Q=44488,R=3399) + real SCALE,EPS,RNMX + parameter (SCALE=1./M,EPS=1.2e-7,RNMX=1.-EPS) +c +c Local: + integer j +c +c *** Executable section *** +c + j = seed/Q + seed = A*(seed-j*Q)-R*j + if (seed .lt. 0) seed = seed+M + ran0 = min(seed*SCALE,RNMX) + return + end +c********************************************************************** + subroutine rqsort(n,a,p) +c====================================================================== +c Return integer array p which indexes array a in increasing order. +c Array a is not disturbed. The Quicksort algorithm is used. +c +c B. G. Knapp, 86/12/23 +c +c Reference: N. Wirth, Algorithms and Data Structures, +c Prentice-Hall, 1986 +c====================================================================== + implicit none + +c Input: + integer n + real a(n) + +c Output: + integer p(n) + +c Constants + integer LGN, Q + parameter (LGN=32, Q=11) +c (LGN = log base 2 of maximum n; +c Q = smallest subfile to use quicksort on) + +c Local: + real x + integer stackl(LGN),stackr(LGN),s,t,l,m,r,i,j + +c Initialize the stack + stackl(1)=1 + stackr(1)=n + s=1 + +c Initialize the pointer array + do 1 i=1,n + p(i)=i + 1 continue + + 2 if (s.gt.0) then + l=stackl(s) + r=stackr(s) + s=s-1 + + 3 if ((r-l).lt.Q) then + +c Use straight insertion + do 6 i=l+1,r + t = p(i) + x = a(t) + do 4 j=i-1,l,-1 + if (a(p(j)).le.x) goto 5 + p(j+1) = p(j) + 4 continue + j=l-1 + 5 p(j+1) = t + 6 continue + else + +c Use quicksort, with pivot as median of a(l), a(m), a(r) + m=(l+r)/2 + t=p(m) + if (a(t).lt.a(p(l))) then + p(m)=p(l) + p(l)=t + t=p(m) + endif + if (a(t).gt.a(p(r))) then + p(m)=p(r) + p(r)=t + t=p(m) + if (a(t).lt.a(p(l))) then + p(m)=p(l) + p(l)=t + t=p(m) + endif + endif + +c Partition + x=a(t) + i=l+1 + j=r-1 + 7 if (i.le.j) then + 8 if (a(p(i)).lt.x) then + i=i+1 + goto 8 + endif + 9 if (x.lt.a(p(j))) then + j=j-1 + goto 9 + endif + if (i.le.j) then + t=p(i) + p(i)=p(j) + p(j)=t + i=i+1 + j=j-1 + endif + goto 7 + endif + +c Stack the larger subfile + s=s+1 + if ((j-l).gt.(r-i)) then + stackl(s)=l + stackr(s)=j + l=i + else + stackl(s)=i + stackr(s)=r + r=j + endif + goto 3 + endif + goto 2 + endif + return + end +c*********************************************************************** + subroutine pikaia(ff,n,ctrl,x,f,icondi) +c======================================================================= +c Optimization (maximization) of user-supplied "fitness" function +c ff over n-dimensional parameter space x using a basic genetic +c algorithm method. +c +c Paul Charbonneau & Barry Knapp +c High Altitude Observatory +c National Center for Atmospheric Research +c Boulder CO 80307-3000 +c +c +c +c Version 1.2 [ 2002 April 3 ] +c +c Genetic algorithms are heuristic search techniques that +c incorporate in a computational setting, the biological notion +c of evolution by means of natural selection. This subroutine +c implements the three basic operations of selection, crossover, +c and mutation, operating on "genotypes" encoded as strings. +c +c Version 1.2 differs from version 1.0 (December 1995) in that +c it includes (1) two-point crossover, (2) creep mutation, and +c (3) dynamical adjustment of the mutation rate based on metric +c distance in parameter space. +c +c References: +c +c Charbonneau, Paul. "An introduction to gemetic algorithms for +c numerical optimization", NCAR Technical Note TN-450+IA +c (April 2002) +c +c Charbonneau, Paul. "Release Notes for PIKAIA 1.2", +c NCAR Technical Note TN-451+STR (April 2002) +c +c Charbonneau, Paul, and Knapp, Barry. "A User's Guide +c to PIKAIA 1.0" NCAR Technical Note TN-418+IA +c (December 1995) +c +c Goldberg, David E. Genetic Algorithms in Search, Optimization, +c & Machine Learning. Addison-Wesley, 1989. +c +c Davis, Lawrence, ed. Handbook of Genetic Algorithms. +c Van Nostrand Reinhold, 1991. +c +c======================================================================= +c USES: ff, urand, setctl, report, rnkpop, select, encode, decode, +c cross, mutate, genrep, stdrep, newpop, adjmut + implicit none + +c Input: + integer n + real ff + external ff +c +c o Integer n is the parameter space dimension, i.e., the number +c of adjustable parameters. +c +c o Function ff is a user-supplied scalar function of n vari- +c ables, which must have the calling sequence f = ff(n,x), where +c x is a real parameter array of length n. This function must +c be written so as to bound all parameters to the interval [0,1]; +c that is, the user must determine a priori bounds for the para- +c meter space, and ff must use these bounds to perform the appro- +c priate scalings to recover true parameter values in the +c a priori ranges. +c +c By convention, ff should return higher values for more optimal +c parameter values (i.e., individuals which are more "fit"). +c For example, in fitting a function through data points, ff +c could return the inverse of chi**2. +c +c In most cases initialization code will have to be written +c (either in a driver or in a separate subroutine) which loads +c in data values and communicates with ff via one or more labeled +c common blocks. An example exercise driver and fitness function +c are provided in the accompanying file, xpkaia.f. +c +c +c Input/Output: + real ctrl(12) +c +c o Array ctrl is an array of control flags and parameters, to +c control the genetic behavior of the algorithm, and also printed +c output. A default value will be used for any control variable +c which is supplied with a value less than zero. On exit, ctrl +c contains the actual values used as control variables. The +c elements of ctrl and their defaults are: +c +c ctrl( 1) - number of individuals in a population (default +c is 100) +c ctrl( 2) - number of generations over which solution is +c to evolve (default is 500) +c ctrl( 3) - number of significant digits (i.e., number of +c genes) retained in chromosomal encoding (default +c is 6) (Note: This number is limited by the +c machine floating point precision. Most 32-bit +c floating point representations have only 6 full +c digits of precision. To achieve greater preci- +c sion this routine could be converted to double +c precision, but note that this would also require +c a double precision random number generator, which +c likely would not have more than 9 digits of +c precision if it used 4-byte integers internally.) +c ctrl( 4) - crossover probability; must be <= 1.0 (default +c is 0.85). If crossover takes place, either one +c or two splicing points are used, with equal +c probabilities +c ctrl( 5) - mutation mode; 1/2/3/4/5 (default is 2) +c 1=one-point mutation, fixed rate +c 2=one-point, adjustable rate based on fitness +c 3=one-point, adjustable rate based on distance +c 4=one-point+creep, fixed rate +c 5=one-point+creep, adjustable rate based on fitness +c 6=one-point+creep, adjustable rate based on distance +c ctrl( 6) - initial mutation rate; should be small (default +c is 0.005) (Note: the mutation rate is the proba- +c bility that any one gene locus will mutate in +c any one generation.) +c ctrl( 7) - minimum mutation rate; must be >= 0.0 (default +c is 0.0005) +c ctrl( 8) - maximum mutation rate; must be <= 1.0 (default +c is 0.25) +c ctrl( 9) - relative fitness differential; range from 0 +c (none) to 1 (maximum). (default is 1.) +c ctrl(10) - reproduction plan; 1/2/3=Full generational +c replacement/Steady-state-replace-random/Steady- +c state-replace-worst (default is 3) +c ctrl(11) - elitism flag; 0/1=off/on (default is 0) +c (Applies only to reproduction plans 1 and 2) +c ctrl(12) - printed output 0/1/2=None/Minimal/Verbose +c (default is 0) +c +c +c Output: + real x(n), f + integer icondi +c +c o Array x(1:n) is the "fittest" (optimal) solution found, +c i.e., the solution which maximizes fitness function ff +c +c o Scalar f is the value of the fitness function at x +c +c o Integer icondi is an indicator of the success or failure +c of the call to pikaia (0=success; non-zero=failure) +c +c +c Constants + integer NMAX, PMAX, DMAX + parameter (NMAX = 32, PMAX = 128, DMAX = 6) +c +c o NMAX is the maximum number of adjustable parameters +c (n <= NMAX) +c +c o PMAX is the maximum population (ctrl(1) <= PMAX) +c +c o DMAX is the maximum number of Genes (digits) per Chromosome +c segement (parameter) (ctrl(3) <= DMAX) +c +c +c Local variables + integer np, nd, ngen, imut, irep, ielite, ivrb, k, ip, ig, + + ip1, ip2, new, newtot + real pcross, pmut, pmutmn, pmutmx, fdif +c + real ph(NMAX,2), oldph(NMAX,PMAX), newph(NMAX,PMAX) +c + integer gn1(NMAX*DMAX), gn2(NMAX*DMAX) + integer ifit(PMAX), jfit(PMAX) + real fitns(PMAX) +c +c User-supplied uniform random number generator + real urand + external urand +c +c Function urand should not take any arguments. If the user wishes +c to be able to initialize urand, so that the same sequence of +c random numbers can be repeated, this capability could be imple- +c mented with a separate subroutine, and called from the user's +c driver program. An example urand function (and initialization +c subroutine) which uses the function ran0 (the "minimal standard" +c random number generator of Park and Miller [Comm. ACM 31, 1192- +c 1201, Oct 1988; Comm. ACM 36 No. 7, 105-110, July 1993]) is +c provided. +c +c +c Set control variables from input and defaults + call setctl + + (ctrl,n,np,ngen,nd,pcross,pmutmn,pmutmx,pmut,imut, + + fdif,irep,ielite,ivrb,icondi) + if (icondi .ne. 0) then + write(*,*) ' Control vector (ctrl) argument(s) invalid' + return + endif + +c Make sure locally-dimensioned arrays are big enough + if (n.gt.NMAX .or. np.gt.PMAX .or. nd.gt.DMAX) then + write(*,*) + + ' Number of parameters, population, or genes too large' + icondi = -1 + return + endif + +c Compute initial (random but bounded) phenotypes + do 1 ip=1,np + do 2 k=1,n + oldph(k,ip)=urand() + 2 continue + fitns(ip) = ff(n,oldph(1,ip)) + 1 continue + +c Rank initial population by fitness order + call rnkpop(np,fitns,ifit,jfit) + +c Main Generation Loop + do 10 ig=1,ngen + +c Main Population Loop + newtot=0 + do 20 ip=1,np/2 + +c 1. pick two parents + call select(np,jfit,fdif,ip1) + 21 call select(np,jfit,fdif,ip2) + if (ip1.eq.ip2) goto 21 + +c 2. encode parent phenotypes + call encode(n,nd,oldph(1,ip1),gn1) + call encode(n,nd,oldph(1,ip2),gn2) + +c 3. breed + call cross(n,nd,pcross,gn1,gn2) + call mutate(n,nd,pmut,gn1,imut) + call mutate(n,nd,pmut,gn2,imut) + +c 4. decode offspring genotypes + call decode(n,nd,gn1,ph(1,1)) + call decode(n,nd,gn2,ph(1,2)) + +c 5. insert into population + if (irep.eq.1) then + call genrep(NMAX,n,np,ip,ph,newph) + else + call stdrep(ff,NMAX,n,np,irep,ielite, + + ph,oldph,fitns,ifit,jfit,new) + newtot = newtot+new + endif + +c End of Main Population Loop + 20 continue + +c if running full generational replacement: swap populations + if (irep.eq.1) + + call newpop(ff,ielite,NMAX,n,np,oldph,newph, + + ifit,jfit,fitns,newtot) + +c adjust mutation rate? + if (imut.eq.2 .or. imut.eq.3 .or. imut.eq.5 .or. imut.eq.6) + + call adjmut(NMAX,n,np,oldph,fitns,ifit,pmutmn,pmutmx, + + pmut,imut) +c + if (ivrb.gt.0) call report + + (ivrb,NMAX,n,np,nd,oldph,fitns,ifit,pmut,ig,newtot) + +c End of Main Generation Loop + 10 continue +c +c Return best phenotype and its fitness + do 30 k=1,n + x(k) = oldph(k,ifit(np)) + 30 continue + f = fitns(ifit(np)) +c + end +c******************************************************************** + subroutine setctl + + (ctrl,n,np,ngen,nd,pcross,pmutmn,pmutmx,pmut,imut, + + fdif,irep,ielite,ivrb,icondi) +c=================================================================== +c Set control variables and flags from input and defaults +c=================================================================== + implicit none +c +c Input + integer n +c +c Input/Output + real ctrl(12) +c +c Output + integer np, ngen, nd, imut, irep, ielite, ivrb, icondi + real pcross, pmutmn, pmutmx, pmut, fdif +c +c Local + integer i + real DFAULT(12) + save DFAULT + data DFAULT /100,500,5,.85,2,.005,.0005,.25,1,1,1,0/ +c + do 1 i=1,12 + if (ctrl(i).lt.0.) ctrl(i)=DFAULT(i) + 1 continue + + np = ctrl(1) + ngen = ctrl(2) + nd = ctrl(3) + pcross = ctrl(4) + imut = ctrl(5) + pmut = ctrl(6) + pmutmn = ctrl(7) + pmutmx = ctrl(8) + fdif = ctrl(9) + irep = ctrl(10) + ielite = ctrl(11) + ivrb = ctrl(12) + icondi = 0 +c +c Print a header + if (ivrb.gt.0) then + + write(*,2) ngen,np,n,nd,pcross,pmut,pmutmn,pmutmx,fdif + 2 format(/1x,60('*'),/, + + ' *',13x,'PIKAIA Genetic Algorithm Report ',13x,'*',/, + + 1x,60('*'),//, + + ' Number of Generations evolving: ',i4,/, + + ' Individuals per generation: ',i4,/, + + ' Number of Chromosome segments: ',i4,/, + + ' Length of Chromosome segments: ',i4,/, + + ' Crossover probability: ',f9.4,/, + + ' Initial mutation rate: ',f9.4,/, + + ' Minimum mutation rate: ',f9.4,/, + + ' Maximum mutation rate: ',f9.4,/, + + ' Relative fitness differential: ',f9.4) + if (imut.eq.1) write(*,3) 'Uniform, Constant Rate' + if (imut.eq.2) write(*,3) 'Uniform, Variable Rate (F)' + if (imut.eq.3) write(*,3) 'Uniform, Variable Rate (D)' + if (imut.eq.4) write(*,3) 'Uniform+Creep, Constant Rate' + if (imut.eq.5) write(*,3) 'Uniform+Creep, Variable Rate (F)' + if (imut.eq.6) write(*,3) 'Uniform+Creep, Variable Rate (D)' + 3 format( + + ' Mutation Mode: ',A) + if (irep.eq.1) write(*,4) 'Full generational replacement' + if (irep.eq.2) write(*,4) 'Steady-state-replace-random' + if (irep.eq.3) write(*,4) 'Steady-state-replace-worst' + 4 format( + + ' Reproduction Plan: ',A) + endif + +c Check some control values + if (imut.ne.1 .and. imut.ne.2 .and. imut.ne.3 .and. imut.ne.4 + + .and. imut.ne.5 .and. imut.ne.6) then + write(*,10) + icondi = 5 + endif + 10 format(' ERROR: illegal value for imut (ctrl(5))') + + if (fdif.gt.1.) then + write(*,11) + icondi = 9 + endif + 11 format(' ERROR: illegal value for fdif (ctrl(9))') + + if (irep.ne.1 .and. irep.ne.2 .and. irep.ne.3) then + write(*,12) + icondi = 10 + endif + 12 format(' ERROR: illegal value for irep (ctrl(10))') + + if (pcross.gt.1.0 .or. pcross.lt.0.) then + write(*,13) + icondi = 4 + endif + 13 format(' ERROR: illegal value for pcross (ctrl(4))') + + if (ielite.ne.0 .and. ielite.ne.1) then + write(*,14) + icondi = 11 + endif + 14 format(' ERROR: illegal value for ielite (ctrl(11))') + + if (irep.eq.1 .and. imut.eq.1 .and. pmut.gt.0.5 .and. + + ielite.eq.0) then + write(*,15) + endif + 15 format(' WARNING: dangerously high value for pmut (ctrl(6));', + + /' (Should enforce elitism with ctrl(11)=1.)') + + if (irep.eq.1 .and. imut.eq.2 .and. pmutmx.gt.0.5 .and. + + ielite.eq.0) then + write(*,16) + endif + 16 format(' WARNING: dangerously high value for pmutmx (ctrl(8));', + + /' (Should enforce elitism with ctrl(11)=1.)') + + if (fdif.lt.0.33 .and. irep.ne.3) then + write(*,17) + endif + 17 format(' WARNING: dangerously low value of fdif (ctrl(9))') + + if (mod(np,2).gt.0) then + np=np-1 + write(*,18) np + endif + 18 format(' WARNING: decreasing population size (ctrl(1)) to np=',i4) + + return + end +c******************************************************************** + subroutine report + + (ivrb,ndim,n,np,nd,oldph,fitns,ifit,pmut,ig,nnew) +c +c Write generation report to standard output +c + implicit none + +c Input: + integer np,ifit(np),ivrb,ndim,n,nd,ig,nnew + real oldph(ndim,np),fitns(np),pmut +c +c Output: none +c +c Local + real bestft,pmutpv + save bestft,pmutpv + integer ndpwr,k + logical rpt + data bestft,pmutpv /0,0/ +c + rpt=.false. + + if (pmut.ne.pmutpv) then + pmutpv=pmut + rpt=.true. + endif + + if (fitns(ifit(np)).ne.bestft) then + bestft=fitns(ifit(np)) + rpt=.true. + endif + + if (rpt .or. ivrb.ge.2) then + +c Power of 10 to make integer genotypes for display + ndpwr = nint(10.**nd) + + write(*,'(/i6,i6,f10.6,4f10.6)') ig,nnew,pmut, + + fitns(ifit(np)), fitns(ifit(np-1)), fitns(ifit(np/2)) + do 15 k=1,n + write(*,'(22x,3i10)') + + nint(ndpwr*oldph(k,ifit(np ))), + + nint(ndpwr*oldph(k,ifit(np-1))), + + nint(ndpwr*oldph(k,ifit(np/2))) + 15 continue + + endif + end + +c********************************************************************** +c GENETICS MODULE +c********************************************************************** +c +c ENCODE: encodes phenotype into genotype +c called by: PIKAIA +c +c DECODE: decodes genotype into phenotype +c called by: PIKAIA +c +c CROSS: Breeds two offspring from two parents +c called by: PIKAIA +c +c MUTATE: Introduces random mutation in a genotype +c called by: PIKAIA +c +c ADJMUT: Implements variable mutation rate +c called by: PIKAIA +c +c********************************************************************** + subroutine encode(n,nd,ph,gn) +c====================================================================== +c encode phenotype parameters into integer genotype +c ph(k) are x,y coordinates [ 0 < x,y < 1 ] +c====================================================================== +c + implicit none +c +c Inputs: + integer n, nd + real ph(n) +c +c Output: + integer gn(n*nd) +c +c Local: + integer ip, i, j, ii + real z +c + z=10.**nd + ii=0 + do 1 i=1,n + ip=int(ph(i)*z) + do 2 j=nd,1,-1 + gn(ii+j)=mod(ip,10) + ip=ip/10 + 2 continue + ii=ii+nd + 1 continue + + return + end + +c********************************************************************** + subroutine decode(n,nd,gn,ph) +c====================================================================== +c decode genotype into phenotype parameters +c ph(k) are x,y coordinates [ 0 < x,y < 1 ] +c====================================================================== +c + implicit none +c +c Inputs: + integer n, nd, gn(n*nd) +c +c Output: + real ph(n) +c +c Local: + integer ip, i, j, ii + real z +c + z=10.**(-nd) + ii=0 + do 1 i=1,n + ip=0 + do 2 j=1,nd + ip=10*ip+gn(ii+j) + 2 continue + ph(i)=ip*z + ii=ii+nd + 1 continue + + return + end + +c********************************************************************** + subroutine cross(n,nd,pcross,gn1,gn2) +c====================================================================== +c breeds two parent chromosomes into two offspring chromosomes +c breeding occurs through crossover. If the crossover probability +c test yields true (crossover taking place), either one-point or +c two-point crossover is used, with equal probabilities. +c +c Compatibility with version 1.0: To enforce 100% use of one-point +c crossover, un-comment appropriate line in source code below +c====================================================================== +c + implicit none +c +c Inputs: + integer n, nd + real pcross +c +c Input/Output: + integer gn1(n*nd), gn2(n*nd) +c +c Local: + integer i, ispl, ispl2, itmp, t +c +c Function + real urand + external urand + + +c Use crossover probability to decide whether a crossover occurs + if (urand().lt.pcross) then + +c Compute first crossover point + ispl=int(urand()*n*nd)+1 + +c Now choose between one-point and two-point crossover + if (urand().lt.0.5) then + ispl2=n*nd + else + ispl2=int(urand()*n*nd)+1 +c Un-comment following line to enforce one-point crossover +c ispl2=n*nd + if (ispl2.lt.ispl) then + itmp=ispl2 + ispl2=ispl + ispl=itmp + endif + endif + +c Swap genes from ispl to ispl2 + do 10 i=ispl,ispl2 + t=gn2(i) + gn2(i)=gn1(i) + gn1(i)=t + 10 continue + endif + + return + end + +c********************************************************************** + subroutine mutate(n,nd,pmut,gn,imut) +c====================================================================== +c Mutations occur at rate pmut at all gene loci +c imut=1 Uniform mutation, constant rate +c imut=2 Uniform mutation, variable rate based on fitness +c imut=3 Uniform mutation, variable rate based on distance +c imut=4 Uniform or creep mutation, constant rate +c imut=5 Uniform or creep mutation, variable rate based on +c fitness +c imut=6 Uniform or creep mutation, variable rate based on +c distance +c====================================================================== +c + implicit none +c +c Input: + integer n, nd, imut + real pmut +c +c Input/Output: + integer gn(n*nd) +c +c Local: + integer i,j,k,l,ist,inc,loc,kk + +c +c Function: + real urand + external urand +c +c Decide which type of mutation is to occur + if(imut.ge.4.and.urand().le.0.5)then + +c CREEP MUTATION OPERATOR +c Subject each locus to random +/- 1 increment at the rate pmut + do 1 i=1,n + do 2 j=1,nd + if (urand().lt.pmut) then +c Construct integer + loc=(i-1)*nd+j + inc=nint ( urand() )*2-1 + ist=(i-1)*nd+1 + gn(loc)=gn(loc)+inc +c write(*,*) ist,loc,inc +c This is where we carry over the one (up to two digits) +c first take care of decrement below 0 case + if(inc.lt.0 .and. gn(loc).lt.0)then + if(j.eq.1)then + gn(loc)=0 + else + do 3 k=loc,ist+1,-1 + gn(k)=9 + gn(k-1)=gn(k-1)-1 + if( gn(k-1).ge.0 )goto 4 + 3 continue +c we popped under 0.00000 lower bound; fix it up + if( gn(ist).lt.0.)then + do 5 l=ist,loc + gn(l)=0 + 5 continue + endif + 4 continue + endif + endif + if(inc.gt.0 .and. gn(loc).gt.9)then + if(j.eq.1)then + gn(loc)=9 + else + do 6 k=loc,ist+1,-1 + gn(k)=0 + gn(k-1)=gn(k-1)+1 + if( gn(k-1).le.9 )goto 7 + 6 continue +c we popped over 9.99999 upper bound; fix it up + if( gn(ist).gt.9 )then + do 8 l=ist,loc + gn(l)=9 + 8 continue + endif + 7 continue + endif + endif + endif + 2 continue + 1 continue + + else + +c UNIFORM MUTATION OPERATOR +c Subject each locus to random mutation at the rate pmut + do 10 i=1,n*nd + if (urand().lt.pmut) then + gn(i)=int(urand()*10.) + endif + 10 continue + endif + + return + end + +c********************************************************************** + subroutine adjmut(ndim,n,np,oldph,fitns,ifit,pmutmn,pmutmx, + + pmut,imut) +c====================================================================== +c dynamical adjustment of mutation rate; +c imut=2 or imut=5 : adjustment based on fitness differential +c between best and median individuals +c imut=3 or imut=6 : adjustment based on metric distance +c between best and median individuals +c====================================================================== +c + implicit none +c +c Input: + integer n, ndim, np, ifit(np), imut + real oldph(ndim,np), fitns(np), pmutmn, pmutmx +c +c Input/Output: + real pmut +c +c Local: + integer i + real rdif, rdiflo, rdifhi, delta + parameter (rdiflo=0.05, rdifhi=0.25, delta=1.5) + + if(imut.eq.2.or.imut.eq.5)then +c Adjustment based on fitness differential + rdif=abs(fitns(ifit(np))-fitns(ifit(np/2)))/ + + (fitns(ifit(np))+fitns(ifit(np/2))) + else if(imut.eq.3.or.imut.eq.6)then +c Adjustment based on normalized metric distance + rdif=0. + do 1 i=1,n + rdif=rdif+( oldph(i,ifit(np))-oldph(i,ifit(np/2)) )**2 + 1 continue + rdif=sqrt( rdif ) / float(n) + endif + + if(rdif.le.rdiflo)then + pmut=min(pmutmx,pmut*delta) + else if(rdif.ge.rdifhi)then + pmut=max(pmutmn,pmut/delta) + endif + + return + end + + +c********************************************************************** +c REPRODUCTION MODULE +c********************************************************************** +c +c SELECT: Parent selection by roulette wheel algorithm +c called by: PIKAIA +c +c RNKPOP: Ranks initial population +c called by: PIKAIA, NEWPOP +c +c GENREP: Inserts offspring into population, for full +c generational replacement +c called by: PIKAIA +c +c STDREP: Inserts offspring into population, for steady-state +c reproduction +c called by: PIKAIA +c calls: FF +c +c NEWPOP: Replaces old generation with new generation +c called by: PIKAIA +c calls: FF, RNKPOP +c +c********************************************************************** + subroutine select(np,jfit,fdif,idad) +c====================================================================== +c Selects a parent from the population, using roulette wheel +c algorithm with the relative fitnesses of the phenotypes as +c the "hit" probabilities [see Davis 1991, chap. 1]. +c====================================================================== +c USES: urand + implicit none +c +c Input: + integer np, jfit(np) + real fdif +c +c Output: + integer idad +c +c Local: + integer np1, i + real dice, rtfit +c +c Function: + real urand + external urand +c +c + np1 = np+1 + dice = urand()*np*np1 + rtfit = 0. + do 1 i=1,np + rtfit = rtfit+np1+fdif*(np1-2*jfit(i)) + if (rtfit.ge.dice) then + idad=i + goto 2 + endif + 1 continue +c Assert: loop will never exit by falling through + + 2 return + end + +c********************************************************************** + subroutine rnkpop(n,arrin,indx,rank) +c====================================================================== +c Calls external sort routine to produce key index and rank order +c of input array arrin (which is not altered). +c====================================================================== +c USES: rqsort + implicit none +c +c Input + integer n + real arrin(n) +c +c Output + integer indx(n),rank(n) +c +c Local + integer i +c +c External sort subroutine + external rqsort +c +c +c Compute the key index + call rqsort(n,arrin,indx) +c +c ...and the rank order + do 1 i=1,n + rank(indx(i)) = n-i+1 + 1 continue + return + end + +c*********************************************************************** + subroutine genrep(ndim,n,np,ip,ph,newph) +c======================================================================= +c full generational replacement: accumulate offspring into new +c population array +c======================================================================= +c + implicit none + +c Input: + integer ndim, n, np, ip + real ph(ndim,2) +c +c Output: + real newph(ndim,np) +c +c Local: + integer i1, i2, k +c +c +c Insert one offspring pair into new population + i1=2*ip-1 + i2=i1+1 + do 1 k=1,n + newph(k,i1)=ph(k,1) + newph(k,i2)=ph(k,2) + 1 continue + + return + end + +c********************************************************************** + subroutine stdrep + + (ff,ndim,n,np,irep,ielite,ph,oldph,fitns,ifit,jfit,nnew) +c====================================================================== +c steady-state reproduction: insert offspring pair into population +c only if they are fit enough (replace-random if irep=2 or +c replace-worst if irep=3). +c====================================================================== +c USES: ff, urand + implicit none +c +c Input: + integer ndim, n, np, irep, ielite + real ff, ph(ndim,2) + external ff +c +c Input/Output: + real oldph(ndim,np), fitns(np) + integer ifit(np), jfit(np) +c +c Output: + integer nnew + +c Local: + integer i, j, k, i1, if1 + real fit +c +c External function + real urand + external urand +c +c + nnew = 0 + do 1 j=1,2 + +c 1. compute offspring fitness (with caller's fitness function) + fit=ff(n,ph(1,j)) + +c 2. if fit enough, insert in population + do 20 i=np,1,-1 + if (fit.gt.fitns(ifit(i))) then + +c make sure the phenotype is not already in the population + if (i.lt.np) then + do 5 k=1,n + if (oldph(k,ifit(i+1)).ne.ph(k,j)) goto 6 + 5 continue + goto 1 + 6 continue + endif + +c offspring is fit enough for insertion, and is unique + +c (i) insert phenotype at appropriate place in population + if (irep.eq.3) then + i1=1 + else if (ielite.eq.0 .or. i.eq.np) then + i1=int(urand()*np)+1 + else + i1=int(urand()*(np-1))+1 + endif + if1 = ifit(i1) + fitns(if1)=fit + do 21 k=1,n + oldph(k,if1)=ph(k,j) + 21 continue + +c (ii) shift and update ranking arrays + if (i.lt.i1) then + +c shift up + jfit(if1)=np-i + do 22 k=i1-1,i+1,-1 + jfit(ifit(k))=jfit(ifit(k))-1 + ifit(k+1)=ifit(k) + 22 continue + ifit(i+1)=if1 + else + +c shift down + jfit(if1)=np-i+1 + do 23 k=i1+1,i + jfit(ifit(k))=jfit(ifit(k))+1 + ifit(k-1)=ifit(k) + 23 continue + ifit(i)=if1 + endif + nnew = nnew+1 + goto 1 + endif + 20 continue + + 1 continue + + return + end + +c********************************************************************** + subroutine newpop + + (ff,ielite,ndim,n,np,oldph,newph,ifit,jfit,fitns,nnew) +c====================================================================== +c replaces old population by new; recomputes fitnesses & ranks +c====================================================================== +c USES: ff, rnkpop + implicit none +c +c Input: + integer ndim, np, n, ielite + real ff + external ff +c +c Input/Output: + real oldph(ndim,np), newph(ndim,np) +c +c Output: + integer ifit(np), jfit(np), nnew + real fitns(np) +c +c Local: + integer i, k +c +c + nnew = np + +c if using elitism, introduce in new population fittest of old +c population (if greater than fitness of the individual it is +c to replace) + if (ielite.eq.1 .and. ff(n,newph(1,1)).lt.fitns(ifit(np))) then + do 1 k=1,n + newph(k,1)=oldph(k,ifit(np)) + 1 continue + nnew = nnew-1 + endif + +c replace population + do 2 i=1,np + do 3 k=1,n + oldph(k,i)=newph(k,i) + 3 continue + +c get fitness using caller's fitness function + fitns(i)=ff(n,oldph(1,i)) + 2 continue + +c compute new population fitness rank order + call rnkpop(np,fitns,ifit,jfit) + + return + end + diff --git a/dataassim/math/optimization/planarfit.f b/dataassim/math/optimization/planarfit.f new file mode 100644 index 0000000..6ac3de6 --- /dev/null +++ b/dataassim/math/optimization/planarfit.f @@ -0,0 +1,52 @@ + subroutine planarfit(nsamp,x,y,z,a,b,d,fatbeta) +!fit a plane in the form of ax+by+cz+d=0 where c is set to 1. +!Because we set c=1, we cannot fit for vertical planes in parallel to the +!x-z or y-z planes. But perfectly flat planes in parallel to the x-y plane can be included. +!no initial guess for a, b and d are needed + implicit none + integer nsamp,i + double precision x(nsamp),y(nsamp),z(nsamp), + & a,b,d,fatbeta,p1,p2,p3,q1,q2,q3,xmean,ymean, + & zmean,x2mean,y2mean,xymean,xzmean,yzmean +!-------------------------------------------------------- + xmean=0.0d0 + ymean=0.0d0 + zmean=0.0d0 + x2mean=0.0d0 + y2mean=0.0d0 + xymean=0.0d0 + xzmean=0.0d0 + yzmean=0.0d0 + do i=1,nsamp + xmean=xmean+x(i) + ymean=ymean+y(i) + zmean=zmean+z(i) + x2mean=x2mean+x(i)*x(i) + y2mean=y2mean+y(i)*y(i) + xymean=xymean+x(i)*y(i) + xzmean=xzmean+x(i)*z(i) + yzmean=yzmean+y(i)*z(i) + enddo + xmean=xmean/dble(nsamp) + ymean=ymean/dble(nsamp) + zmean=zmean/dble(nsamp) + x2mean=x2mean/dble(nsamp) + y2mean=y2mean/dble(nsamp) + xymean=xymean/dble(nsamp) + xzmean=xzmean/dble(nsamp) + yzmean=yzmean/dble(nsamp) + p1=x2mean-xmean*xmean + p2=xymean-xmean*ymean + p3=xmean*zmean-xzmean + q1=xymean-xmean*ymean + q2=y2mean-ymean*ymean + q3=ymean*zmean-yzmean + call linearsys_dim2(p1,p2,p3,q1,q2,q3,a,b) + d=-(a*xmean+b*ymean+zmean) + fatbeta=0.0d0 + do i=1,nsamp + fatbeta=fatbeta+(a*x(i)+b*y(i)+z(i)+d)* + & (a*x(i)+b*y(i)+z(i)+d) + enddo + return + end diff --git a/dataassim/math/optimization/powell.f b/dataassim/math/optimization/powell.f new file mode 100644 index 0000000..bfab820 --- /dev/null +++ b/dataassim/math/optimization/powell.f @@ -0,0 +1,548 @@ + SUBROUTINE powell(p,xi,n,np,ftol,fret,pmin,pmax, + & funkmin,f1dim,ITMAX) +! fret must be given on entry + implicit none + INTEGER iter,n,np,NMAX,ITMAX + double precision fret,ftol,p(np),xi(np,np),TINY, + & pmin(np),pmax(np) + PARAMETER (NMAX=1000,TINY=1.0d-25) +CU USES funkmin,linmin + INTEGER i,ibig,j + double precision del,fp,fptt,t,pt(NMAX), + & ptt(NMAX),xit(NMAX) + external funkmin,f1dim + do 11 j=1,n + pt(j)=p(j) +11 continue + iter=0 +1 iter=iter+1 + fp=fret + ibig=0 + del=0.0d0 + do 13 i=1,n + do 12 j=1,n + xit(j)=xi(j,i) +12 continue + fptt=fret + call linmin(p,pmin,pmax,xit,n,f1dim,fret) + if(fptt-fret.gt.del)then + del=fptt-fret + ibig=i + endif +13 continue + if(2.0d0*(fp-fret).le.ftol*(dabs(fp)+dabs(fret))+TINY)return + if(iter.eq.ITMAX)then +! write(*,*)'powell exceeding maximum iterations' + return + endif + do 14 j=1,n + ptt(j)=2.0d0*p(j)-pt(j) + xit(j)=p(j)-pt(j) + pt(j)=p(j) +14 continue + call funkmin(n,ptt,fptt) + if(fptt.ge.fp)goto 1 + t=2.0d0*(fp-2.0d0*fret+fptt)*(fp-fret-del)**2- + & del*(fp-fptt)**2 + if(t.ge.0.0d0)goto 1 + call linmin(p,pmin,pmax,xit,n,f1dim,fret) + if(ibig.eq.0)return + do 15 j=1,n + xi(j,ibig)=xi(j,n) + xi(j,n)=xit(j) +15 continue + goto 1 + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + SUBROUTINE linmin(p,pmin,pmax,xi,n,f1dim,fret) + implicit none + INTEGER n + double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n) + PARAMETER (TOL=1.0d-8) +CU USES brent,f1dim,mnbrak + INTEGER j,k,ierr + double precision ax,bx,fa,fb,fx,xmin,xx,brent,xxmin,xxmax +!(((((((((((((((((((((((((((((((((((((((((((((((((((( +!It is essential NMAX must be set to 1000 in f1dim! + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /f1com/ pcom,xicom,ncom + save /f1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + EXTERNAL f1dim + ncom=n + do j=1,n + pcom(j)=p(j) + xicom(j)=xi(j) + enddo + xxmax=1.0d+100 + xxmin=-1.0d+100 + do j=1,n + if(xicom(j).gt.1.0d-100)then +! if(xicom(j).gt.0.0d0)then + xx=(pmax(j)-pcom(j))/xicom(j) + ax=(pmin(j)-pcom(j))/xicom(j) + else + if(xicom(j).lt.(-1.0d-100))then +! if(xicom(j).lt.0.0d0)then + ax=(pmax(j)-pcom(j))/xicom(j) + xx=(pmin(j)-pcom(j))/xicom(j) + else + xx=1.0d+100 + ax=-1.0d+100 + endif + endif + if(xxmax.gt.xx)then + xxmax=xx + endif + if(xxmin.lt.ax)then + xxmin=ax + endif + enddo + ax=0.0d0 + if(dabs(xxmax).gt.dabs(xxmin))then + xx=0.25d0*xxmax + else + xx=0.25d0*xxmin + endif + call mnbrak(ax,xx,bx,fa,fx,fb,xxmin,xxmax,ierr,f1dim) + if(ierr.eq.0)then + fret=brent(ax,xx,bx,f1dim,TOL,xmin) + else + xmin=xx + fret=fx + endif + do 12 j=1,n + xi(j)=xmin*xi(j) + p(j)=p(j)+xi(j) +12 continue + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. +! +! + double precision function brent(ax,bx,cx,f,tol,xmin) + INTEGER ITMAX + double precision ax,bx,cx,tol,xmin,f,CGOLD,ZEPS + EXTERNAL f + PARAMETER (ITMAX=10000,CGOLD=.381966d0,ZEPS=1.0d-10) + INTEGER iter + double precision a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1, + & tol2,u,v,w,x,xm + a=dmin1(ax,cx) + b=dmax1(ax,cx) + v=bx + w=v + x=v + e=0.0d0 + fx=f(x) + fv=fx + fw=fx + do 11 iter=1,ITMAX + xm=0.5d0*(a+b) + tol1=tol*dabs(x)+ZEPS + tol2=2.0d0*tol1 + if(dabs(x-xm).le.(tol2-.5d0*(b-a))) goto 3 + if(dabs(e).gt.tol1) then + r=(x-w)*(fx-fv) + q=(x-v)*(fx-fw) + p=(x-v)*q-(x-w)*r + q=2.0d0*(q-r) + if(q.gt.0.0d0) p=-p + q=dabs(q) + etemp=e + e=d + if(dabs(p).ge.dabs(.5d0*q*etemp).or. + & p.le.q*(a-x).or.p.ge.q*(b-x))goto 1 + d=p/q + u=x+d + if(u-a.lt.tol2.or.b-u.lt.tol2)d=dsign(tol1,xm-x) + goto 2 + endif +1 if(x.ge.xm)then + e=a-x + else + e=b-x + endif + d=CGOLD*e +2 if(dabs(d).ge.tol1) then + u=x+d + else + u=x+dsign(tol1,d) + endif + fu=f(u) + if(fu.le.fx)then + if(u.ge.x)then + a=x + else + b=x + endif + v=w + fv=fw + w=x + fw=fx + x=u + fx=fu + else + if(u.lt.x) then + a=u + else + b=u + endif + if(fu.le.fw.or.w.eq.x)then + v=w + fv=fw + w=u + fw=fu + else if(fu.le.fv.or.v.eq.x.or.v.eq.w)then + v=u + fv=fu + endif + endif +11 continue +! write(*,*) 'brent exceed maximum iterations' +3 xmin=x + brent=fx + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + +! double precision function f1dim(x) +! implicit none +! double precision x +!CU USES funkmin +! INTEGER j +! +!(((((((((((((((((((((((((((((((((((((((((((((((((((( +! integer NMAX,ncom +! parameter(NMAX=1000) +! double precision pcom(NMAX),xicom(NMAX) +! COMMON /f1com/ pcom,xicom,ncom +! save /f1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) +! double precision xt(NMAX) +! do 11 j=1,ncom +! xt(j)=pcom(j)+x*xicom(j) +!11 continue +! call funkmin(ncom,xt,f1dim) +! return +! END +!C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,xxmin,xxmax, + & ierr,func) + implicit none + double precision ax,bx,cx,fa,fb,fc, + & func,GOLD,GLIMIT,TINY + EXTERNAL func + PARAMETER(GOLD=1.618034d0,GLIMIT=100.0d0,TINY=1.0d-20) + double precision dum,fu,q,r,u,ulim,xxmin,xxmax + integer ierr + ierr=0 + fa=func(ax) + fb=func(bx) + if(fb.gt.fa)then + dum=ax + ax=bx + bx=dum + dum=fb + fb=fa + fa=dum +!from ax to bx, f decreases + endif + if(fa.eq.fb)then + cx=(bx+ax)/2.0d0 + fc=func(cx) + if(fc.le.fa)return + endif + cx=bx+GOLD*(bx-ax) + if(cx.le.xxmin)then + cx=0.5d0*(dmin1(ax,bx)+xxmin) + endif + if(cx.ge.xxmax)then + cx=0.5d0*(dmax1(ax,bx)+xxmax) + endif + fc=func(cx) +1 if(fb.ge.fc)then + r=(bx-ax)*(fb-fc) + q=(bx-cx)*(fb-fa) + u=bx-((bx-cx)*q-(bx-ax)*r)/ + & (2.0d0*dsign(dmax1(dabs(q-r),TINY),q-r)) + ulim=bx+GLIMIT*(cx-bx) + if(ulim.ge.xxmax)then + ulim=xxmax-TINY + endif + if(ulim.le.xxmin)then + ulim=xxmin+TINY + endif + if((bx-u)*(u-cx).gt.0.0d0)then + fu=func(u) + if(fu.lt.fc)then + ax=bx + fa=fb + bx=u + fb=fu + return + elseif(fu.gt.fb)then + cx=u + fc=fu + return + endif + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fu=func(u) + elseif((cx-u)*(u-ulim).gt.0.0d0)then + fu=func(u) + if(fu.lt.fc)then + bx=cx + cx=u + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fb=fc + fc=fu + fu=func(u) + endif + else if((u-ulim)*(ulim-cx).ge.0.0d0)then + u=ulim + fu=func(u) + else + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fu=func(u) + endif + ax=bx + bx=cx + cx=u + fa=fb + fb=fc + fc=fu + r=dmin1(dabs(ax-bx),dabs(ax-cx)) + r=dmin1(r,dabs(bx-cx)) + if(r.lt.TINY)then +! bracketing failed + ierr=1 + return + endif + goto 1 + endif + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + SUBROUTINE leafmnbrak(ax,bx,cx,fa,fb,fc,xxmin,xxmax, + & ierr,func) + implicit none + double precision ax,bx,cx,fa,fb,fc, + & func,GOLD,GLIMIT,TINY + EXTERNAL func + PARAMETER(GOLD=1.618034d0,GLIMIT=100.0d0,TINY=1.0d-20) + double precision dum,fu,q,r,u,ulim,xxmin,xxmax + integer ierr + ierr=0 + fa=func(ax) + fb=func(bx) + if(fb.gt.fa)then + dum=ax + ax=bx + bx=dum + dum=fb + fb=fa + fa=dum +!from ax to bx, f decreases + endif + if(fa.eq.fb)then + cx=(bx+ax)/2.0d0 + fc=func(cx) + if(fc.le.fa)return + endif + cx=bx+GOLD*(bx-ax) + if(cx.le.xxmin)then + cx=0.5d0*(dmin1(ax,bx)+xxmin) + endif + if(cx.ge.xxmax)then + cx=0.5d0*(dmax1(ax,bx)+xxmax) + endif + fc=func(cx) +1 if(fb.ge.fc)then + r=(bx-ax)*(fb-fc) + q=(bx-cx)*(fb-fa) + u=bx-((bx-cx)*q-(bx-ax)*r)/ + & (2.0d0*dsign(dmax1(dabs(q-r),TINY),q-r)) + ulim=bx+GLIMIT*(cx-bx) + if(ulim.ge.xxmax)then + ulim=xxmax-TINY + endif + if(ulim.le.xxmin)then + ulim=xxmin+TINY + endif + if((bx-u)*(u-cx).gt.0.0d0)then + fu=func(u) + if(fu.lt.fc)then + ax=bx + fa=fb + bx=u + fb=fu + return + elseif(fu.gt.fb)then + cx=u + fc=fu + return + endif + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fu=func(u) + elseif((cx-u)*(u-ulim).gt.0.0d0)then + fu=func(u) + if(fu.lt.fc)then + bx=cx + cx=u + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fb=fc + fc=fu + fu=func(u) + endif + else if((u-ulim)*(ulim-cx).ge.0.0d0)then + u=ulim + fu=func(u) + else + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fu=func(u) + endif + ax=bx + bx=cx + cx=u + fa=fb + fb=fc + fc=fu + r=dmin1(dabs(ax-bx),dabs(ax-cx)) + r=dmin1(r,dabs(bx-cx)) + if(r.lt.TINY)then +! bracketing failed + ierr=1 + return + endif + goto 1 + endif + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + double precision function leafbrent(ax,bx,cx,f,tol,xmin) + INTEGER ITMAX + double precision ax,bx,cx,tol,xmin,f,CGOLD,ZEPS + EXTERNAL f + PARAMETER (ITMAX=10000,CGOLD=.381966d0,ZEPS=1.0d-10) + INTEGER iter + double precision a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1, + & tol2,u,v,w,x,xm + a=dmin1(ax,cx) + b=dmax1(ax,cx) + v=bx + w=v + x=v + e=0.0d0 + fx=f(x) + fv=fx + fw=fx + do 11 iter=1,ITMAX + xm=0.5d0*(a+b) + tol1=tol*dabs(x)+ZEPS + tol2=2.0d0*tol1 + if(dabs(x-xm).le.(tol2-.5d0*(b-a))) goto 3 + if(dabs(e).gt.tol1) then + r=(x-w)*(fx-fv) + q=(x-v)*(fx-fw) + p=(x-v)*q-(x-w)*r + q=2.0d0*(q-r) + if(q.gt.0.0d0) p=-p + q=dabs(q) + etemp=e + e=d + if(dabs(p).ge.dabs(.5d0*q*etemp).or. + & p.le.q*(a-x).or.p.ge.q*(b-x))goto 1 + d=p/q + u=x+d + if(u-a.lt.tol2.or.b-u.lt.tol2)d=dsign(tol1,xm-x) + goto 2 + endif +1 if(x.ge.xm)then + e=a-x + else + e=b-x + endif + d=CGOLD*e +2 if(dabs(d).ge.tol1) then + u=x+d + else + u=x+dsign(tol1,d) + endif + fu=f(u) + if(fu.le.fx)then + if(u.ge.x)then + a=x + else + b=x + endif + v=w + fv=fw + w=x + fw=fx + x=u + fx=fu + else + if(u.lt.x) then + a=u + else + b=u + endif + if(fu.le.fw.or.w.eq.x)then + v=w + fv=fw + w=u + fw=fu + else if(fu.le.fv.or.v.eq.x.or.v.eq.w)then + v=u + fv=fu + endif + endif +11 continue +! write(*,*) 'brent exceed maximum iterations' +3 xmin=x + leafbrent=fx + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. diff --git a/dataassim/math/optimization/powellann.f b/dataassim/math/optimization/powellann.f new file mode 100644 index 0000000..1a4b342 --- /dev/null +++ b/dataassim/math/optimization/powellann.f @@ -0,0 +1,403 @@ + SUBROUTINE powellann(p,xi,n,np,ftol,fret,pmin,pmax, + & funkmin,f1dim,ITMAX) +! fret must be given on entry + + implicit none + INTEGER iter,n,np,NMAX,ITMAX + double precision fret,ftol,p(np),xi(np,np),TINY, + & pmin(np),pmax(np) + + PARAMETER (NMAX=50,TINY=1.0d-25) +CU USES funkmin,annlinmin + INTEGER i,ibig,j + double precision del,fp,fptt,t,pt(NMAX), + & ptt(NMAX),xit(NMAX) + external funkmin,f1dim + + do 11 j=1,n + pt(j)=p(j) +11 continue + iter=0 +1 iter=iter+1 + fp=fret + ibig=0 + del=0.0d0 + do 13 i=1,n + do 12 j=1,n + xit(j)=xi(j,i) +12 continue + fptt=fret + + call annlinmin(p,pmin,pmax,xit,n,f1dim,fret) + if(fptt-fret.gt.del)then + del=fptt-fret + ibig=i + endif +13 continue + if(2.0d0*(fp-fret).le.ftol*(dabs(fp)+dabs(fret))+TINY)return + if(iter.eq.ITMAX)then + write(*,*)'powell exceeding maximum iterations' + return + endif + do 14 j=1,n + ptt(j)=2.0d0*p(j)-pt(j) + xit(j)=p(j)-pt(j) + pt(j)=p(j) +14 continue + call funkmin(n,ptt,fptt) + if(fptt.ge.fp)goto 1 + t=2.0d0*(fp-2.0d0*fret+fptt)*(fp-fret-del)**2- + & del*(fp-fptt)**2 + if(t.ge.0.0d0)goto 1 + + call annlinmin(p,pmin,pmax,xit,n,f1dim,fret) + + do 15 j=1,n + xi(j,ibig)=xi(j,n) + xi(j,n)=xit(j) +15 continue + goto 1 + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + SUBROUTINE annlinmin(p,pmin,pmax,xi,n,f1dim,fret) + implicit none + INTEGER n,NMAX + double precision fret,p(n),xi(n),ftol,pmin(n),pmax(n) + PARAMETER (NMAX=1000,ftol=1.0d-6) +CU USES brent,f1dim,mnbrak + INTEGER j,ncom,k,ierr + double precision ax,bx,fa,fb,fx,xmin,xx,pcom(NMAX), + & xicom(NMAX),xxmin,xxmax,term,w(2),bph(2), + & paramnormsk,paramnormsb,ynorm,q(2),bend,terma, + & termb,termc,delta,reducer,root,f1dim,postannfunc + parameter(reducer=0.25d0) + + COMMON /f1com/ pcom,xicom,ncom + + integer maxm1dsamp,m1dsamp + parameter(maxm1dsamp=1000) + common /intannlinmin/m1dsamp + double precision y1dsamp(maxm1dsamp),params1d(maxm1dsamp) + common /dbleannlinmin/y1dsamp,params1d + + EXTERNAL f1dim + + ncom=n + delta=0.5d0 + + do j=1,n + pcom(j)=p(j) + xicom(j)=xi(j) + enddo + + xxmax=1.0d+100 + xxmin=-1.0d+100 + do j=1,n + if(xicom(j).gt.1.0d-100)then +! if(xicom(j).gt.0.0d0)then + xx=(pmax(j)-pcom(j))/xicom(j) + ax=(pmin(j)-pcom(j))/xicom(j) + else + if(xicom(j).lt.(-1.0d-100))then +! if(xicom(j).lt.0.0d0)then + ax=(pmax(j)-pcom(j))/xicom(j) + xx=(pmin(j)-pcom(j))/xicom(j) + else + xx=1.0d+100 + ax=-1.0d+100 + endif + endif + if(xxmax.gt.xx)then + xxmax=xx + endif + if(xxmin.lt.ax)then + xxmin=ax + endif + enddo + ax=0.0d0 + if(dabs(xxmax).gt.dabs(xxmin))then + xx=0.25d0*xxmax + else + xx=0.25d0*xxmin + endif + + m1dsamp=0 + call mnbrak(ax,xx,bx,fa,fx,fb,xxmin,xxmax,ierr,f1dim) + if(ierr.ne.0)then +! bracketing failed + fret=fx + do j=1,n + xi(j)=xx*xi(j) + p(j)=p(j)+xi(j) + enddo + return + endif + + if(ax.gt.xx)then + xxmax=ax + xxmin=bx + else + xxmax=bx + xxmin=ax + endif + + write(*,*)m1dsamp + + if(m1dsamp.lt.6)then + term=xx+(xxmax-xx)*(delta+1.0d0)/2.0d0 + fret=f1dim(term) + if(fret.lt.fx)then + xxmin=xx + xx=term + fx=fret + else + xxmax=term + endif + term=xx+(xxmax-xx)*(1.0d0-delta)/2.0d0 + fret=f1dim(term) + if(fret.lt.fx)then + xxmin=xx + xx=term + fx=fret + else + xxmax=term + endif + term=xx-(xx-xxmin)*(1.0d0+delta)/2.0d0 + fret=f1dim(term) + if(fret.lt.fx)then + xxmax=xx + xx=term + fx=fret + else + xxmin=term + endif + term=xx-(xx-xxmin)*(1.0d0-delta)/2.0d0 + fret=f1dim(term) + if(fret.lt.fx)then + xxmax=xx + xx=term + fx=fret + else + xxmin=term + endif + endif + + w(1)=0.75334d0 + w(2)=0.13425d0 + bph(1)=0.01d0 + bph(2)=-0.07d0 + q(1)=1.2d0 + q(2)=-2.0d0 + +100 call annfitting1d(m1dsamp,params1d,y1dsamp,paramnormsk, + & paramnormsb,ynorm,w,bph,q,bend) + + + term=q(1)*w(1) + fret=q(2)*w(2) + terma=term*w(2)*w(2)+fret*w(1)*w(1) + termb=2.0d0*(term*w(2)*bph(2)+fret*w(1)*bph(1)) + termc=term*(1.0d0+bph(2)*bph(2))+ + & fret*(1.0d0+bph(1)*bph(1)) + + if(terma.eq.0.0d0)then + if(termb.eq.0.0d0)goto 200 + root=-termc/termb + goto 110 + endif + fret=termb*termb-4.0d0*terma*termc + if(fret.lt.0.0d0)goto 200 + term=-0.5d0*(termb+dsign(1.0d0,termb)*dsqrt(fret)) + root=termc/term + root=(root-paramnormsb)/paramnormsk + if(root.lt.xxmax.and.root.gt.xxmin)then + if(dabs(root-xx).lt.ftol)goto 1000 + fret=f1dim(root) + if(fret.lt.fx)then + if(root.lt.xx)then + xxmax=xx + else + xxmin=xx + endif + xx=root + fx=fret + goto 100 + else + if(root.lt.xx)then + xxmin=root + else + xxmax=root + endif + endif + endif + root=term/terma +110 root=(root-paramnormsb)/paramnormsk + if(root.lt.xxmax.and.root.gt.xxmin)then + if(dabs(root-xx).lt.ftol)goto 1000 + fret=f1dim(root) + if(fret.lt.fx)then + if(root.lt.xx)then + xxmax=xx + else + xxmin=xx + endif + xx=root + fx=fret + goto 100 + else + if(root.lt.xx)then + xxmin=root + else + xxmax=root + endif + endif + endif + +200 term=xx+delta*(xxmax-xx) + + write(*,*)'ann failed' + + fret=f1dim(term) + if(fret.lt.fx)then + xxmin=xx + fx=fret + xx=term + goto 100 + endif + xxmax=term + term=xx-delta*(xx-xxmin) + fret=f1dim(term) + if(fret.lt.fx)then + xxmax=xx + fx=fret + xx=term + goto 100 + endif + xxmin=term + delta=delta*reducer + if(delta.gt.ftol)goto 200 + +1000 fret=fx + do j=1,n + xi(j)=xx*xi(j) + p(j)=p(j)+xi(j) + enddo + + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. + + SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,xxmin,xxmax, + & ierr,func) + implicit none + double precision ax,bx,cx,fa,fb,fc, + & func,GOLD,GLIMIT,TINY + EXTERNAL func + PARAMETER(GOLD=1.618034d0,GLIMIT=100.0d0,TINY=1.0d-20) + double precision dum,fu,q,r,u,ulim,xxmin,xxmax + integer ierr + ierr=0 + fa=func(ax) + fb=func(bx) + if(fb.gt.fa)then + dum=ax + ax=bx + bx=dum + dum=fb + fb=fa + fa=dum + endif + if(fa.eq.fb)then + cx=(bx+ax)/2.0d0 + fc=func(cx) + if(fc.le.fa)return + endif + cx=bx+GOLD*(bx-ax) + if(cx.le.xxmin)then + cx=0.5d0*(dmin1(ax,bx)+xxmin) + endif + if(cx.ge.xxmax)then + cx=0.5d0*(dmax1(ax,bx)+xxmax) + endif + fc=func(cx) +1 if(fb.ge.fc)then + r=(bx-ax)*(fb-fc) + q=(bx-cx)*(fb-fa) + u=bx-((bx-cx)*q-(bx-ax)*r)/ + & (2.0d0*dsign(dmax1(dabs(q-r),TINY),q-r)) + ulim=bx+GLIMIT*(cx-bx) + if(ulim.ge.xxmax)then + ulim=xxmax-tiny + endif + if(ulim.le.xxmin)then + ulim=xxmin+tiny + endif + if((bx-u)*(u-cx).gt.0.0d0)then + fu=func(u) + if(fu.lt.fc)then + ax=bx + fa=fb + bx=u + fb=fu + return + elseif(fu.gt.fb)then + cx=u + fc=fu + return + endif + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fu=func(u) + elseif((cx-u)*(u-ulim).gt.0.0d0)then + fu=func(u) + if(fu.lt.fc)then + bx=cx + cx=u + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fb=fc + fc=fu + fu=func(u) + endif + else if((u-ulim)*(ulim-cx).ge.0.0d0)then + u=ulim + fu=func(u) + else + u=cx+GOLD*(cx-bx) + if(u.gt.xxmax)then + u=cx+0.5d0*(xxmax-cx) + endif + if(u.lt.xxmin)then + u=cx+0.5d0*(xxmin-cx) + endif + fu=func(u) + endif + ax=bx + bx=cx + cx=u + fa=fb + fb=fc + fc=fu + r=dmin1(dabs(ax-bx),dabs(ax-cx)) + r=dmin1(r,dabs(bx-cx)) + if(r.lt.tiny)then +! bracketing failed + ierr=1 + return + endif + goto 1 + endif + return + END +C (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3. diff --git a/dataassim/math/optimization/randpermut_dim_samp.f b/dataassim/math/optimization/randpermut_dim_samp.f new file mode 100644 index 0000000..5b8ab51 --- /dev/null +++ b/dataassim/math/optimization/randpermut_dim_samp.f @@ -0,0 +1,102 @@ + + subroutine randpermut_dim_samp(npoints,ndim,x) + implicit none +! +! conduct random permutation + integer npoints,ndim,i,j,k,iextreme,index,ibad,ngood, + & istore(npoints) + double precision x(ndim,npoints),xtemp(npoints), + & ran2_reset,temp,bmin(ndim),bmax(ndim) + + do i=1,ndim + do j=1,npoints + xtemp(j)=x(i,j) + enddo + do j=1,npoints + index=int(dble(npoints-j+1)*ran2_reset()+1.0d0) + x(i,j)=xtemp(index) + xtemp(index)=xtemp(npoints-j+1) + enddo + enddo + + if(ndim.eq.1)return + if(npoints.le.3)return + +! now check to see if all extreme values are togather + do i=1,ndim + bmax(i)=x(i,1) + bmin(i)=x(i,1) + enddo + do i=2,npoints + do j=1,ndim + if(bmax(j).lt.x(j,i))then + bmax(j)=x(j,i) + endif + if(bmin(j).gt.x(j,i))then + bmin(j)=x(j,i) + endif + enddo + enddo + do i=1,npoints + iextreme=0 + do j=1,ndim + if(dabs(x(j,i)-bmax(j)).lt.1.0d-9.or. + & dabs(x(j,i)-bmin(j)).lt.1.0d-9)then + iextreme=iextreme+1 + endif + enddo + + if(iextreme.ge.(ndim/2+1))then +! more than half take extreme values, need to change +! find ones without any extremes + ngood=0 + do j=1,i + ibad=0 + do k=1,ndim + if(dabs(x(k,j)-bmax(k)).lt.1.0d-9.or. + & dabs(x(k,j)-bmin(k)).lt.1.0d-9)then + ibad=1 + endif + enddo + if(ibad.eq.0)then + ngood=ngood+1 + istore(ngood)=j + endif + enddo + do j=1+i,npoints + ibad=0 + do k=1,ndim + if(dabs(x(k,j)-bmax(k)).lt.1.0d-9.or. + & dabs(x(k,j)-bmin(k)).lt.1.0d-9)then + ibad=1 + endif + enddo + if(ibad.eq.0)then + ngood=ngood+1 + istore(ngood)=j + endif + enddo + if(ngood.ge.1)then + index=int(dble(ngood)*ran2_reset()+1.0d0) + index=istore(index) + else +! there is no single point that does not take any extremes + index=int(dble(npoints)*ran2_reset()+1.0d0) + if(index.eq.i)then + if(i.eq.1)then + index=npoints + else + index=1 + endif + endif + endif + do j=1,ndim,2 + temp=x(j,i) + x(j,i)=x(j,index) + x(j,index)=temp + enddo + endif + enddo + return + end +c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& diff --git a/dataassim/math/optimization/samplingscheme.f b/dataassim/math/optimization/samplingscheme.f new file mode 100644 index 0000000..75de749 --- /dev/null +++ b/dataassim/math/optimization/samplingscheme.f @@ -0,0 +1,144 @@ + + subroutine samplingscheme(sampfunc,nparams,msamp, + & bestguess,guessconfid0,bmax,bmin,params,ysamp) +! +! This subroutine conducts samples from a given function using both random and +! systematic strategies. In the random strategy, sampled points randomly scatter +! around the bestguess point. The closeness to the bestguess depends on the confidence +! on the bestguess. For any given parameter, the width of the last interval is +! guessconfid0 X the width of the first interval. In the systematic strategy, two values +! for each parameter are determined with the new bestguess after +! the random sampling in the middle. The two determined values of all parameters +! are systematically combined to form new additional sampling points. +! +! After the two sampling strategies, the latest best guess is the first point in params. + + + implicit none + integer nparams,msamp + double precision bestguess(nparams),guessconfid0, + & bmax(nparams),bmin(nparams),params(nparams,msamp), + & ysamp(msamp),guessconfid + integer i,nright,nleft,ibest,msamptemp + double precision accum,x1,delta,j,ybest,temp + + external sampfunc + + guessconfid=dmax1(1.0d0,guessconfid0) + + do i=1,nparams + if(bestguess(i).lt.bmin(i).or.bestguess(i).gt. + & bmax(i))then + write(*,*)'best guess out of bounds, sampling stops' + stop + endif + enddo + msamptemp=msamp-1-2*nparams + + if(msamptemp.lt.0)then + write(*,*)'sampling number must be larger than', + & (1+2*nparams) + stop + endif + if(msamptemp.gt.0)then + if(msamptemp.ge.3)then + if(mod(msamptemp,2).eq.0)then + nright=msamptemp/2 + nleft=msamptemp/2 + else + nright=msamptemp/2+1 + nleft=msamptemp/2 + endif + do i=1,nparams +!first divide the right + x1=2.0d0*(bmax(i)-bestguess(i))/ + & (dble(nright)*(guessconfid+1.0d0)) + delta=x1*(guessconfid-1.0d0)/dble(nright-1) + accum=0.0d0 + do j=1,nright + accum=accum+x1+dble(j-1)*delta + params(i,j)=accum+bestguess(i) + enddo +! +!then divide the left + x1=2.0d0*(bestguess(i)-bmin(i))/ + & (dble(nleft)*(guessconfid+1.0d0)) + delta=x1*(guessconfid-1.0d0)/dble(nleft-1) + accum=0.0d0 + do j=1,nleft + accum=accum+x1+dble(j-1)*delta + params(i,j+nright)=bestguess(i)-accum + enddo + enddo + else + if(msamptemp.eq.1)then + do i=1,nparams +! arbitrarily take one value + params(i,1)=bestguess(i)+(bmax(i)-bestguess(i)) + & *0.339354235d0 + enddo + endif + if(msamptemp.eq.2)then + do i=1,nparams +! arbitrarily take two values + params(i,1)=bestguess(i)+(bmax(i)-bestguess(i)) + & *0.339354235d0 + params(i,2)=bestguess(i)-(bestguess(i)-bmin(i)) + & *0.339354235d0 + enddo + endif + endif + call randpermut_dim_samp(msamptemp,nparams, + & params(1:nparams,1:msamptemp)) + endif + msamptemp=msamptemp+1 + do i=1,nparams + params(i,msamptemp)=bestguess(i) + enddo + do i=1,msamptemp + call sampfunc(nparams,params(1:nparams,i:i),ysamp(i)) + enddo + + ibest=1 + ybest=ysamp(ibest) + do i=2,msamptemp + if(ysamp(i).lt.ybest)then + ibest=i + ybest=ysamp(i) + endif + enddo + + do i=1,nparams + msamptemp=msamptemp+1 + params(i,msamptemp)=params(i,ibest)+ + & (bmax(i)-params(i,ibest))/(1.0d0+guessconfid) + msamptemp=msamptemp+1 + params(i,msamptemp)=params(i,ibest)- + & (params(i,ibest)-bmin(i))/(1.0d0+guessconfid) + do j=1,i-1 + params(j,msamptemp-1)=params(j,ibest) + params(j,msamptemp)=params(j,ibest) + enddo + do j=i+1,nparams + params(j,msamptemp-1)=params(j,ibest) + params(j,msamptemp)=params(j,ibest) + enddo + enddo + do i=msamptemp-2*nparams+1,msamptemp + call sampfunc(nparams,params(1:nparams,i:i),ysamp(i)) + if(ysamp(i).lt.ybest)then + ibest=i + ybest=ysamp(i) + endif + enddo + do i=1,nparams + temp=params(i,1) + params(i,1)=params(i,ibest) + params(i,ibest)=temp + enddo + temp=ysamp(1) + ysamp(1)=ysamp(ibest) + ysamp(ibest)=temp + + return + end diff --git a/dataassim/math/optimization/shortestdist.f b/dataassim/math/optimization/shortestdist.f new file mode 100644 index 0000000..6ae7736 --- /dev/null +++ b/dataassim/math/optimization/shortestdist.f @@ -0,0 +1,51 @@ + subroutine shortestdist(my0,nx,pointy, + & pointx,xmin,xmax,nparams0,params0, + & iknowder0,shorty,shortx) +!find the point on the surface that has the shortest distance from a given point + implicit none + include 'leastdistance.h' + integer my0,nx,nparams0,iknowder0 + double precision pointy(my0),shorty(my0),pointx(nx), + & shortx(nx),xmin(nx),xmax(nx),params0(nparams0) +!------------------Locals---------------------------------- + integer i,iwhichsolver,idowhat,notfound + parameter(notfound=-9999) + double precision s2,s2cp, + & f1dimsqsum_distcenter,f1dims2_distcenter, + & shortf(nx),dydxp(my0,(nx+nparams0)),xtol,ftol + parameter(xtol=1.0d-10,ftol=1.0d-10) + external distcentersys,fsqsum_distcenter, + & f1dimsqsum_distcenter,s2_distcenter, + & f1dims2_distcenter +!---------------------------------------------------------- + my=my0 + nparams=nparams0 + iknowder=iknowder0 + do i=1,nx + targetx(i)=pointx(i) + enddo + do i=1,my + targety(i)=pointy(i) + enddo + do i=1,nparams + params(i)=params0(i) + enddo + call cpnonsyssolver(distcentersys,fsqsum_distcenter, + & f1dimsqsum_distcenter,xmin,pointx,shortx,xmax, + & shortf,nx,iwhichsolver) + if(iwhichsolver.eq.notfound)then + call s2_distcenter(nx,shortx,s2) + s2cp=s2 + call cpnongradopt(nx,s2_distcenter, + & f1dims2_distcenter,shortx,xmin,xmax,ftol,s2) + if(dabs(s2cp-s2).gt.ftol)then + call cpRepeatCompassSearch(nx,shortx,s2,xmin, + & xmax,s2_distcenter,f1dims2_distcenter,xtol) + endif + endif + idowhat=0 + call surffunc(my,shorty,nx,shortx,nparams, + & params,dydxp(1:my,1:(nx+nparams)),idowhat) + return + end subroutine shortestdist +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/optimization/testregres.f b/dataassim/math/optimization/testregres.f new file mode 100644 index 0000000..17b4ccf --- /dev/null +++ b/dataassim/math/optimization/testregres.f @@ -0,0 +1,20 @@ + program test + implicit none + integer npoints,i + double precision x(100),y(100),z(100),A,B,D, + & ran2,fatbeta + A=0.009d0 + B=0.01d0 + D=0.2d0 + npoints=100 + do i=1,npoints + x(i)=3000.0d0*ran2() + y(i)=20.0d0*ran2() + z(i)=-D-A*x(i)-B*y(i) + enddo + A=1.0d0 + B=1.0d0 + D=1.0d0 + call planarfit(npoints,x,y,z,A,B,D,fatbeta) + write(*,*)A,B,D,fatbeta + end diff --git a/dataassim/math/othersupmath/AsymGaussians.f b/dataassim/math/othersupmath/AsymGaussians.f new file mode 100644 index 0000000..176d733 --- /dev/null +++ b/dataassim/math/othersupmath/AsymGaussians.f @@ -0,0 +1,114 @@ +!This file contains gaussian functions even though the subroutine names are sigmoid + double precision function sigmoidfunc(y0,a,b,c,x0,x) + implicit none +!y=y0+a*exp(-((x-x0)/b)**c)) for x > x0 or y=y0+a*exp(-((x0-x)/b)**c)) for x < x0 + double precision y0,a,b,c,x0,x + if(x.gt.x0)then + sigmoidfunc=y0+a*dexp(-((x-x0)/b)**c) + else + sigmoidfunc=y0+a*dexp(-((x0-x)/b)**c) + endif + return + end +!------------------------------------------------------------------- + subroutine gradsigmoidfunc(y0,a,b,c,x0,x,grad) + implicit none + double precision y0,a,b,c,x0,x,grad(6),term,term1 + +! a<->grad(1) +! b<->grad(2) +! c<->grad(3) +! x0<->grad(4) +! y0<->grad(5) +! x<->grad(6) + grad(5)=1.0d0 + if(x.gt.x0)then + term=dexp(-((x-x0)/b)**c) + term1=-((x-x0)/b)**(c-1.0d0) + grad(1)=term + grad(6)=term*c*term1/b + grad(4)=-term*c*term1/b + grad(2)=-term*c*term1*(x-x0)/(b*b) + grad(3)=term*(-((x-x0)/b)**c)*dlog((x-x0)/b) + else + term=dexp(-((x0-x)/b)**c) + term1=-((x0-x)/b)**(c-1.0d0) + grad(1)=term + grad(6)=-term*c*term1/b + grad(4)=term*c*term1/b + grad(2)=-term*c*term1*(x0-x)/(b*b) + grad(3)=term*(-((x0-x)/b)**c)*dlog((x0-x)/b) + endif + return + end +!-------------------------------------------------------------------- + double precision function twoexpfunc(y0,a1,b1,c1,x01, + &a2,b2,c2,x02,x) + implicit none + double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,sigmoidfunc, + &x0,a,b,c +!In Asymmetrical Gaussians, c1 and c2 have no use. +!y=y0+a1*exp(-((x-x01)/b1)**a2)) for x > x01 or y=y0+a1*exp(-((x01-x)/b2)**x02)) for x < x01 + x0=x01 + a=a1 + if(x.gt.x01)then + b=b1 + c=a2 + else + b=b2 + c=x02 + endif + twoexpfunc=sigmoidfunc(y0,a,b,c,x0,x) + return + end +!--------------------------------------------------------------------- + subroutine gradtwoexp(y0,a1,b1,c1,x01,a2,b2,c2,x02,x,grad) + implicit none + double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,grad(10),grad6(6), + &x0,a,b,c + integer i +! a1<->grad(1) +! b1<->grad(2) +! c1<->grad(3) +! x01<->grad(4) +! y0<->grad(5) +! x<->grad(6) +! a2<->grad(7) +! b2<->grad(8) +! c2<->grad(9) +! x02<->grad(10) + do i=1,10 + grad(i)=0.0d0 + enddo + x0=x01 + a=a1 + if(x.gt.x01)then + b=b1 + c=a2 + call gradsigmoidfunc(y0,a,b,c,x0,x,grad6) +! a<->grad6(1) +! b<->grad6(2) +! c<->grad6(3) +! x0<->grad6(4) +! y0<->grad6(5) +! x<->grad6(6) + grad(1)=grad6(1) + grad(2)=grad6(2) + grad(4)=grad6(4) + grad(5)=grad6(5) + grad(6)=grad6(6) + grad(7)=grad6(3) + else + b=b2 + c=x02 + call gradsigmoidfunc(y0,a,b,c,x0,x,grad6) + grad(1)=grad6(1) + grad(4)=grad6(4) + grad(5)=grad6(5) + grad(6)=grad6(6) + grad(8)=grad6(2) + grad(10)=grad6(3) + endif + return + end +!------------------------------------------------------------------------------ diff --git a/dataassim/math/othersupmath/CharToNumeric.f b/dataassim/math/othersupmath/CharToNumeric.f new file mode 100644 index 0000000..6d98fec --- /dev/null +++ b/dataassim/math/othersupmath/CharToNumeric.f @@ -0,0 +1,126 @@ + subroutine CharToNumeric(astring,f) + implicit none +! +! transform a string consisting all numbers in time representation (1234 or 12:34 or +! 12:23:15,or 12.19) into a number + character*20 astring + character*1,c + character*2,HH,MM,SS + character*4 MMSS + + double precision f,f11,f22,f33 + integer ipos1,ipos2,ideci,k,j,ndigit,i + + ipos1=1 +190 if(astring(ipos1:ipos1).ne.' ')goto 200 + ipos1=ipos1+1 + goto 190 +200 ipos2=ipos1+1 +202 if(astring(ipos2:ipos2).eq.' ')goto 204 + ipos2=ipos2+1 + goto 202 +204 ipos2=ipos2-1 + + if(astring(ipos1:ipos1).eq.'-')then + ipos1=ipos1+1 + endif + + ideci=index(astring,'.') + if(ideci.eq.0)then +!1234 or 12:34 or 12:34:50 type + f=-9999.0d0 + if(index(astring,':').eq.0)then +! an integer number + ndigit=ipos2-ipos1+1 + if(ndigit.ge.3.and.ndigit.le.6)then + f33=-99.0d0 + c=astring(ipos2:ipos2) + f11=dble(ichar(c)-48) + c=astring(ipos2-1:ipos2-1) + f11=f11+dble((ichar(c)-48)*10) + + c=astring(ipos2-2:ipos2-2) + f22=dble(ichar(c)-48) + if(ndigit.ge.4)then + c=astring(ipos2-3:ipos2-3) + f22=f22+dble((ichar(c)-48)*10) + endif + + if(ndigit.ge.5)then + c=astring(ipos2-4:ipos2-4) + f33=dble(ichar(c)-48) + endif + + if(ndigit.eq.6)then + c=astring(ipos2-5:ipos2-5) + f33=f33+dble((ichar(c)-48)*10) + endif + + if(f33.lt.0.0d0)then + if(f11.le.60.0d0.and.f22.le.24.0d0)then + f=f22+f11/60.0d0 + endif + else + if(f33.le.24.0d0.and.f22.le.60.0d0.and. + & f11.le.60.0d0)then + f=f33+f22/60.0d0+f11/3600.0d0 + endif + endif + endif + else +!HH:MM or HH:MM:SS type + k=index(astring,':') + HH=astring(ipos1:k-1) + MMSS=astring(k+1:ipos2) + j=index(MMSS,':') + if(j.eq.0)then + MM=MMSS + else + MM=MMSS(1:j-1) + SS=MMSS(j+1:) + endif + + f33=dble((ichar(HH(1:1))-48)) + if(HH(2:2).ne.' ')then + f33=f33*10.0d0+dble(ichar(HH(2:2))-48) + endif + + f22=dble((ichar(MM(1:1))-48)) + if(MM(2:2).ne.' ')then + f22=f22*10.0d0+dble(ichar(MM(2:2))-48) + endif + + if(j.ne.0)then + f11=dble((ichar(SS(1:1))-48)) + if(SS(2:2).ne.' ')then + f11=f11*10.0d0+dble(ichar(SS(2:2))-48) + endif + endif + + if(f33.le.24.0d0.and.f22.le.60.0d0)then + f=f33+f22/60.0d0 + if(j.ne.0)then + if(f11.le.60.0d0)then + f=f+f11/3600.0d0 + endif + endif + endif + endif + else +!18.27 type of character + f=0.0d0 + do i=ipos1,ideci-1 + c=astring(i:i) + f=f+dble(ichar(c)-48)* + & dble(10**(ideci-ipos1-(i-ipos1)-1)) + enddo + do i=ideci+1,ipos2 + c=astring(i:i) + f=f+dble(ichar(c)-48)/dble(10**(i-ideci)) + enddo + endif + if(index(astring,'-').ne.0)then + f=-f + endif + return + end diff --git a/dataassim/math/othersupmath/NumberToChar.f b/dataassim/math/othersupmath/NumberToChar.f new file mode 100644 index 0000000..03eab4f --- /dev/null +++ b/dataassim/math/othersupmath/NumberToChar.f @@ -0,0 +1,30 @@ + subroutine NumberToChar(numitis,numchar,acharitis) + implicit none +!Convert the number numitis to a character whose units are the digits in numitis +!and whose length is numchar. if the number of digits in numitis is less than +!numchar, pad with 0 in the front, e.g. 1 -> 001 and 23 -> 023 if numchar=3 + integer numitis,numchar + character acharitis*(*) + character*1 onechar(numchar) + integer n,i,j,k(numchar) + n=numitis + i=0 +10 i=i+1 + k(i)=mod(n,10) + n=(n-k(i))/10 + if(n.ne.0)goto 10 + if(i.lt.numchar)then + do j=i+1,numchar + k(j)=0 + enddo + endif + do j=1,numchar + acharitis(numchar-j+1:numchar-j+1)=char(k(j)+48) + enddo + n=len(acharitis) + do j=numchar+1,n + acharitis(j:j)='' + enddo + acharitis=trim(acharitis) + return + end subroutine NumberToChar diff --git a/dataassim/math/othersupmath/QuarticRoot.f b/dataassim/math/othersupmath/QuarticRoot.f new file mode 100644 index 0000000..e1032e8 --- /dev/null +++ b/dataassim/math/othersupmath/QuarticRoot.f @@ -0,0 +1,190 @@ +C ***QUARTIC************************************************25.03.98 +C Solution of a quartic equation: + +! dd(0)+dd(1)*z+dd(2)*z**2+dd(3)*z**3+dd(4)*z**4=0 + +C ref.: J. E. Hacke, Amer. Math. Monthly, Vol. 48, 327-328, (1941) +C NO WARRANTY, ALWAYS TEST THIS SUBROUTINE AFTER DOWNLOADING +C ****************************************************************** +C dd(0:4) (i) vector containing the polynomial coefficients +C sol(1:4) (o) results, real part +C soli(1:4) (o) results, imaginary part +C Nsol (o) number of real solutions +C ================================================================== + subroutine quartic(dd,sol,soli,Nsol) + implicit double precision (a-h,o-z) + dimension dd(0:4),sol(4),soli(4) + dimension AA(0:3),z(3) +C + Nsol = 0 + a = dd(4) + b = dd(3) + c = dd(2) + d = dd(1) + e = dd(0) +C + if (dd(4).eq.0.0d+0) then + write(*,*)'ERROR: NOT A QUARTIC EQUATION' + return + endif +C + p=-(3.0d0/8.0d0)*(b/a)*(b/a)+c/a + q =(b/a)*(b/a)*(b/a)/8.0d0-(b/a)*(c/a)/2.0d0+d/a + r =(-3.0d0/256.0d0)*(b/a)*(b/a)*(b/a)*(b/a)+ + & (b/a)*(b/a)*(c/a)/16.0d0-(b/a)*(d/a)/4.0d0+ + & e/a + +! +! solve cubic resolvent + AA(3) = 8.0d0 + AA(2) = -4.0d0*p + AA(1) = -8.0d0*r + AA(0) = 4.0d0*p*r - q*q + call cubic(AA,z,ncube) +C + zsol = -1.0d99 + do 5 i=1,ncube + zsol = dmax1(zsol,z(i)) +5 continue + z(1) = zsol + xK2 = 2.0d0 * z(1) - p + xK = dsqrt(xK2) +C----------------------------------------------- + if (xK.eq.0.0d0) then + xL2 = z(1)*z(1) - r + if (xL2.lt.0.0d0) then + write(*,*)'Sorry, no solution' + return + endif + xL = dsqrt(xL2) + else + xL = q/(2.0d0 * xK) + endif +C----------------------------------------------- + sqp = xK2 - 4.0d0*(z(1) + xL) + sqm = xK2 - 4.0d0*(z(1) - xL) +C + do 10 i=1,4 + soli(i) = 0.0d0 +10 continue + if (sqp.ge.0.0d0 .and. sqm.ge.0.0d0) then + sol(1) = 0.5d+0*( xK + dsqrt(sqp)) + sol(2) = 0.5d+0*( xK - dsqrt(sqp)) + sol(3) = 0.5d+0*(-xK + dsqrt(sqm)) + sol(4) = 0.5d+0*(-xK - dsqrt(sqm)) + Nsol = 4 + else if (sqp.ge.0.d+0 .and. sqm.lt.0.d+0) then + sol(1) = 0.5d+0*(xK + dsqrt(sqp)) + sol(2) = 0.5d+0*(xK - dsqrt(sqp)) + sol(3) = -0.5d+0*xK + sol(4) = -0.5d+0*xK + soli(3) = dsqrt(-0.25d+0 * sqm) + soli(4) = -dsqrt(-0.25d+0 * sqm) + Nsol = 2 + else if (sqp.lt.0.d+0 .and. sqm.ge.0.d+0) then + sol(1) = 0.5d+0*(-xK + dsqrt(sqm)) + sol(2) = 0.5d+0*(-xK - dsqrt(sqm)) + sol(3) = 0.5d+0*xK + sol(4) = 0.5d+0*xK + soli(3) = dsqrt(-0.25d+0 * sqp) + soli(4) = -dsqrt(-0.25d+0 * sqp) + Nsol = 2 + else if (sqp.lt.0.d+0 .and. sqm.lt.0.d+0) then + sol(1) = -0.5d+0*xK + sol(2) = -0.5d+0*xK + soli(1) = dsqrt(-0.25d+0 * sqm) + soli(2) = -dsqrt(-0.25d+0 * sqm) + sol(3) = 0.5d+0*xK + sol(4) = 0.5d+0*xK + soli(3) = dsqrt(-0.25d+0 * sqp) + soli(4) = -dsqrt(-0.25d+0 * sqp) + Nsol = 0 + endif + do 20 i=1,4 + sol(i) = sol(i) - b/(4.d+0*a) +20 continue +C + return + END + +C ***CUBIC************************************************08.11.1986 +C Solution of a cubic equation +C Equations of lesser degree are solved by the appropriate formulas. +C The solutions are arranged in ascending order. +C NO WARRANTY, ALWAYS TEST THIS SUBROUTINE AFTER DOWNLOADING +C ****************************************************************** +C A(0:3) (i) vector containing the polynomial coefficients +C X(1:L) (o) results +C L (o) number of valid solutions (beginning with X(1)) +C ================================================================== + SUBROUTINE CUBIC(A,X,L) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION A(0:3),X(3),U(3) + PARAMETER(PI=3.1415926535897932D+0,THIRD=1.D+0/3.D+0) + INTRINSIC DMIN1,DMAX1,DACOS +C +C define cubic root as statement function + CBRT(Z)=DSIGN(DABS(Z)**THIRD,Z) +C +C ==== determine the degree of the polynomial ==== +C + IF (A(3).NE.0.D+0) THEN +C +C cubic problem + W=A(2)/A(3)*THIRD + P=(A(1)/A(3)*THIRD-W**2)**3 + Q=-.5D+0*(2.D+0*W**3-(A(1)*W-A(0))/A(3)) + DIS=Q**2+P + IF (DIS.LT.0.D+0) THEN +C three real solutions! +C Confine the argument of ACOS to the interval [-1;1]! + PHI=DACOS(DMIN1(1.D+0,DMAX1(-1.D+0,Q/DSQRT(-P)))) + P=2.D+0*(-P)**(5.D-1*THIRD) + DO 100 I=1,3 + U(I)=P*DCOS((PHI+DBLE(2*I)*PI)*THIRD)-W +100 continue + X(1)=DMIN1(U(1),U(2),U(3)) + X(2)=DMAX1(DMIN1(U(1),U(2)),DMIN1(U(1),U(3)),DMIN1(U(2),U(3))) + X(3)=DMAX1(U(1),U(2),U(3)) + L=3 + ELSE +C only one real solution! + DIS=DSQRT(DIS) + X(1)=CBRT(Q+DIS)+CBRT(Q-DIS)-W + L=1 + END IF +C + ELSE IF (A(2).NE.0.D+0) THEN +C +C quadratic problem + P=5.D-1*A(1)/A(2) + DIS=P**2-A(0)/A(2) + IF (DIS.GE.0.D+0) THEN +C two real solutions! + X(1)=-P-DSQRT(DIS) + X(2)=-P+DSQRT(DIS) + L=2 + ELSE +C no real solution! + L=0 + END IF +C + ELSE IF (A(1).NE.0.D+0) THEN +C +C linear equation + X(1)=-A(0)/A(1) + L=1 +C + ELSE +C no equation + L=0 + END IF +C +C ==== perform one step of a newton iteration in order to minimize +C round-off errors ==== + DO 110 I=1,L + X(I)=X(I)-(A(0)+X(I)*(A(1)+X(I)*(A(2)+X(I)*A(3)))) + * /(A(1)+X(I)*(2.D+0*A(2)+X(I)*3.D+0*A(3))) + 110 CONTINUE + RETURN + END diff --git a/dataassim/math/othersupmath/VariabilityIndices.f b/dataassim/math/othersupmath/VariabilityIndices.f new file mode 100644 index 0000000..561f849 --- /dev/null +++ b/dataassim/math/othersupmath/VariabilityIndices.f @@ -0,0 +1,125 @@ + subroutine VariabilityIndicies(nsamp,xvar,nthresh,threshold, + &shannon,coefvar,xmean,total,unevenness,standunevenness, + &arearatio,pvindex,meaninterval,maxinterval,xintensity) + implicit none + integer nsamp,i,nthresh,j,k + double precision xvar(nsamp),shannon,coefvar,xmean,total, + &unevenness,standunevenness,arearatio,cumline(nsamp), + &evenline(nsamp),areacum,areaeven,trans(nsamp),avetrans, + &pvindex,meaninterval(nthresh),maxinterval(nthresh), + &finterval(nsamp),fstart,threshold(nthresh),recumline(nsamp), + &repvi,retrans(nsamp),averetrans,xintensity +! + cumline(1)=xvar(1) + recumline(1)=xvar(nsamp) + k=0 + if(xvar(1).gt.0.0d0)k=1 + do i=2,nsamp + cumline(i)=cumline(i-1)+xvar(i) + recumline(i)=recumline(i-1)+xvar(nsamp-i+1) + if(xvar(i).gt.0.0d0)k=k+1 + enddo + total=cumline(nsamp) + xmean=total/dble(nsamp) + if(k.gt.0)then + xintensity=total/dble(k) + else + xintensity=-9999.0d0 + endif + if(nsamp.eq.1.or.total.le.0.0d0)then + shannon=-9999.0d0 + coefvar=-9999.0d0 + unevenness=-9999.0d0 + standunevenness=-9999.0d0 + arearatio=-9999.0d0 + pvindex=-9999.0d0 + repvi=-9999.0d0 + do i=1,nthresh + meaninterval(i)=-9999.0d0 + maxinterval(i)=-9999.0d0 + enddo + return + endif + do i=1,nsamp + evenline(i)=xmean*dble(i) + enddo + unevenness=0.0d0 + shannon=0.0d0 + coefvar=0.0d0 + avetrans=0.0d0 + averetrans=0.0d0 + do i=1,nsamp + unevenness=unevenness+(cumline(i)-evenline(i))* + &(cumline(i)-evenline(i)) + trans(i)=(cumline(i)-evenline(i))/evenline(i) +! trans(i)=2.0d0*(cumline(i)-evenline(i))/(xmean*dble((nsamp+1))) + retrans(i)=(recumline(i)-evenline(i))/evenline(i) + avetrans=avetrans+trans(i) + averetrans=averetrans+retrans(i) + if(dabs(xvar(i)).gt.1.0d-10)then + shannon=shannon+(xvar(i)/total)*dlog(xvar(i)/total) + endif + coefvar=coefvar+(xvar(i)-xmean)*(xvar(i)-xmean) + enddo + +! avetrans=0.0d0 +! do i=1,nsamp +! trans(i)=trans(i)*retrans(nsamp-i+1) +! if(trans(i).lt.0.0d0)then +! trans(i)=-dsqrt(-trans(i)) +! else +! trans(i)=dsqrt(trans(i)) +! endif +! avetrans=avetrans+trans(i) +! enddo + + coefvar=dsqrt(coefvar/dble(nsamp-1))/xmean + unevenness=dsqrt(unevenness/dble(nsamp)) + standunevenness=unevenness/xmean + shannon=-shannon/dlog(dble(nsamp)) + avetrans=avetrans/dble(nsamp) + averetrans=averetrans/dble(nsamp) + pvindex=0.0d0 + repvi=0.0d0 + do i=1,nsamp + pvindex=pvindex+(trans(i)-avetrans)*(trans(i)-avetrans) + repvi=repvi+(retrans(i)-averetrans)*(retrans(i)-averetrans) + enddo + pvindex=dsqrt(pvindex/dble(nsamp)) + repvi=dsqrt(repvi/dble(nsamp)) + +! pvindex=(pvindex+repvi)/2.0d0 + + areacum=0.0d0 + areaeven=0.0d0 + do i=2,nsamp + areacum=areacum+(cumline(i)+cumline(i-1))*0.5d0 + areaeven=areaeven+(evenline(i)+evenline(i-1))*0.5d0 + enddo + arearatio=areacum/areaeven +!intervals + do i=1,nthresh + fstart=0.0d0 + k=1 + do j=1,nsamp + if(xvar(j).ge.threshold(i))then + finterval(k)=dble(j)-fstart-1.0d0 + fstart=dble(j) + k=k+1 + endif + enddo + if((dble(nsamp)-fstart).gt.0.5d0)then + finterval(k)=dble(nsamp)-fstart + else + k=k-1 + endif + maxinterval(i)=finterval(1) + meaninterval(i)=finterval(1) + do j=2,k + if(finterval(j).gt.maxinterval(i))maxinterval(i)=finterval(j) + meaninterval(i)=meaninterval(i)+finterval(j) + enddo + meaninterval(i)=meaninterval(i)/dble(k) + enddo + return + end subroutine VariabilityIndicies diff --git a/dataassim/math/othersupmath/autocorr.f b/dataassim/math/othersupmath/autocorr.f new file mode 100644 index 0000000..7f8dcf8 --- /dev/null +++ b/dataassim/math/othersupmath/autocorr.f @@ -0,0 +1,75 @@ +c autocorrelation function +c + subroutine autocorr(nsamp,xvar,yvar,step,rcorr,ncorr) + implicit none + integer nsamp,ncorr + double precision xvar(nsamp),yvar(nsamp),step(nsamp), + & rcorr(nsamp) + + double precision ymean,sum,hmin,sig0,crit + integer i,j,k,n + + sum=0.0d0 + do i=1,nsamp + sum=sum+yvar(i) + enddo + ymean=sum/dble(nsamp) + + step(1)=0.0d0 + rcorr(1)=1.0d0 + sum=0.0d0 + do i=1,nsamp + sum=sum+(yvar(i)-ymean)*(yvar(i)-ymean) + enddo + sig0=sum/dble(nsamp) + if(sig0.eq.0.0d0)then + do i=1,nsamp + step(i)=-9999.0d0 + rcorr(i)=-9999.0d0 + enddo + return + endif + + hmin=xvar(2)-xvar(1) + do i=2,nsamp-1 + if((xvar(i+1)-xvar(i)).lt.hmin)then + hmin=xvar(i+1)-xvar(i) + endif + enddo + crit=0.01d0*hmin + + + i=2 + step(i)=hmin + + +10 j=1 + n=0 + sum=0.0d0 +100 do k=j+1,nsamp + if((xvar(k)-xvar(j)).lt.(step(i)+crit).and. + & (xvar(k)-xvar(j)).gt.(step(i)-crit))then + n=n+1 + sum=sum+(yvar(k)-ymean)*(yvar(j)-ymean) + endif + enddo + if(j.lt.nsamp-1)then + j=j+1 + goto 100 + endif + if(n.le.1)then + step(i)=step(i)+hmin + else +! this form of autocorrelation has less bias + rcorr(i)=sum/(dble(n)*sig0) + +! but this form is more common in statistic literature because it has certain +! desirable properties +! rcorr(i)=sum/(dble(nsamp)*sig0) + i=i+1 + step(i)=step(i-1)+hmin + endif + if((xvar(1)+step(i)).lt.xvar(nsamp))goto 10 + ncorr=i-1 + return + end \ No newline at end of file diff --git a/dataassim/math/othersupmath/blcokgapfilling.f b/dataassim/math/othersupmath/blcokgapfilling.f new file mode 100644 index 0000000..5db9938 --- /dev/null +++ b/dataassim/math/othersupmath/blcokgapfilling.f @@ -0,0 +1,84 @@ +!This subroutine fills gaps in the y variable based on neural network regression + subroutine blockgapfilling(nx,nobs,xsamp,ysamp,nmax) + implicit none +!Gaps must be represented by -9999 +!It is ok to have missing values in xsamp. If any dimension in xsamp is missing, that dimension +!is not used as the independent variable for the gap in y. For different gaps in y, the dimensions used +!in x may be different. + integer nx,nobs,nmax + double precision xsamp(1:nobs,1:nx),ysamp(1:nobs) +!Locals + integer i,j,k,n,idowhat,nh,nxfit,nobsfit,ixuse(nx), + &iposdif,itakethis,iposfit(nobs),iuseit + + parameter(nh=3) + double precision w(1:nx,1:nh),bph(nh),q(nh),bend,c(nh),xnew(nx), + &calvalue(nobs),fn9999,tiny,xfit(nobs,nx),yfit(nobs),rsq + parameter(fn9999=-9999.0d0,tiny=1.0d-6) +! + do i=1,nobs + if(dabs(ysamp(i)-fn9999).gt.tiny)goto 1000 +!a gap + nxfit=0 + do j=1,nx + if(dabs(xsamp(i,j)-fn9999).lt.tiny)then +!this x dimension is not used + ixuse(j)=0 + else +!this x dimension is used + nxfit=nxfit+1 + xnew(nxfit)=xsamp(i,j) + ixuse(j)=1 + endif + enddo + if(nxfit.eq.0)goto 1000 +!Fill this gap by choosing the nmax valid points that are closest to i for the fitting + nobsfit=0 +10 iposdif=10000000 + do n=1,nobs + if(n.ne.i.and.dabs(ysamp(n)-fn9999).gt.tiny)then + iuseit=1 +!make sure it is not one that has been already selected + do k=1,nobsfit + if(n.eq.iposfit(k))iuseit=0 + enddo + if(iuseit.eq.1)then +!make sure it has the x dimensions needed + do j=1,nx + if(ixuse(j).eq.1)then + if(dabs(xsamp(n,j)-fn9999).lt.tiny)iuseit=0 + endif + enddo + endif + if(iuseit.eq.1)then +!make sure the distance is smaller than the current miminum + if(iabs(n-i).lt.iposdif)then + iposdif=iabs(n-i) + itakethis=n + endif + endif + endif + enddo + nobsfit=nobsfit+1 + iposfit(nobsfit)=itakethis + yfit(nobsfit)=ysamp(itakethis) + n=0 + do j=1,nx + if(ixuse(j).eq.1)then + n=n+1 + xfit(nobsfit,n)=xsamp(itakethis,j) + endif + enddo + if(nobsfit.lt.nmax)goto 10 + idowhat=1 + call NeuralNetRegres(idowhat,nxfit,nobsfit,nh, + &xfit(1:nobsfit,1:nxfit),yfit,calvalue,rsq, + &w(1:nxfit,1:nh),bph,q,bend,c,xnew,ysamp(i)) + idowhat=2 + call NeuralNetRegres(idowhat,nxfit,1,nh, + &xfit(1:1,1:nxfit),yfit,calvalue,rsq, + &w(1:nxfit,1:nh),bph,q,bend,c,xnew,ysamp(i)) +1000 continue + enddo + return + end subroutine blockgapfilling diff --git a/dataassim/math/othersupmath/boundary.f b/dataassim/math/othersupmath/boundary.f new file mode 100644 index 0000000..3d27c1b --- /dev/null +++ b/dataassim/math/othersupmath/boundary.f @@ -0,0 +1,91 @@ + program main + implicit none +! integer C_flag1,C_flag2,TA1_flag1,TA1_flag2,TA1_flag3, +! & Ta1_flag4,P_flag1,P_flag2,P_flag3,P_flag4 +! double precision Year,month,DoY,Hour,seq_day_90,seq_time_90, +! & obs_NEE,obs_FCO2,fco2_corr,ustar,nee,Resp_e,gee, +! & obs_Ta_27m,Ta_27m_filled,Ta_2_5m,Ta_2_5m_filled, +! & PAR_28m,PAR_28m_filled + double precision daycurrent,gppmax,dataraw(33),datapick(33), + & work(50000,33),gppsamp(50),std,fmean + integer i,j,ntotal,nwindow,nstart,nend + + nwindow=7 + daycurrent=301.0d0 + gppmax=-1.0d+10 + open(unit=1,file='HF_9204_filled') + read(1,*) + read(1,*) + read(1,*) + read(1,*) + open(unit=2,file='HF_9204_gppmax') +10 read(1,*,end=100)dataraw + if(dabs(daycurrent-dataraw(3)).lt.0.01d0)then + dataraw(13)=dabs(dataraw(13)) + if(dataraw(13).lt.150.0d0)then + if(dataraw(13).gt.gppmax)then + gppmax=dataraw(13) + do i=1,33 + datapick(i)=dataraw(i) + enddo + endif + endif + else + if(dabs(gppmax).lt.150.0d0)then + write(2,310)datapick + endif + daycurrent=dataraw(3) + dataraw(13)=dabs(dataraw(13)) + if(dataraw(13).lt.150.0d0)then + gppmax=dataraw(13) + do i=1,33 + datapick(i)=dataraw(i) + enddo + else + gppmax=-1.0d+10 + endif + endif + goto 10 +100 write(2,310)datapick + close(1) + close(2) + open(unit=1,file='HF_9204_gppmax') + open(unit=2,file='HF_9204_gppmax_clean') + i=1 +110 read(1,*,end=200)(work(i,j),j=1,33) + i=i+1 + goto 110 +200 close(1) + ntotal=i-1 + do i=1,ntotal + nstart=i-nwindow/2 + if(nstart.lt.1)then + nstart=1 + endif + nend=i+nwindow/2 + if(nend.gt.ntotal)then + nend=ntotal + endif + if((nend-nstart+1).lt.nwindow)then + if(nstart.eq.1)then + nend=nend+nwindow-(nend-nstart+1) + else + nstart=nstart-(nwindow-(nend-nstart+1)) + endif + endif + fmean=0.0d0 + do j=nstart,nend + fmean=fmean+work(j,13) + enddo + fmean=fmean/dble(nwindow) + std=0.0d0 + do j=nstart,nend + std=std+(work(j,13)-fmean)*(work(j,13)-fmean) + enddo + std=dsqrt(std/dble(nwindow-1)) + if((fmean-work(i,13)).lt.std.or.work(i,13).lt.1.0d-8)then + write(2,310)(work(i,j),j=1,33) + endif + enddo +310 format(33f15.7) + end diff --git a/dataassim/math/othersupmath/charlineparser.f b/dataassim/math/othersupmath/charlineparser.f new file mode 100644 index 0000000..d8c3ef6 --- /dev/null +++ b/dataassim/math/othersupmath/charlineparser.f @@ -0,0 +1,103 @@ + subroutine charlineparser(longchar,nmax,charvars,n) + implicit none +!7 Sept 2013, revised version +!parse a long line of chars into char variables with the following assumptions: +!1. Each cell is separated by a separating character which can be either a ',', blank space(s) or anything +!with the ASCII code less than and including 032 or larger than and including 127 +!2. Any separating characters at the end of the line are discarded, i.e. +! '1,2,3,4,a,b,c,,,,,,,,,, ,'='1,2,3,4,a,b,c' +!3. If there is no entry between two non-comma separating characters,these two separating characters are treated as one. +! i.e. '1 2 3 4 a b c'='1,2,3,4,a,b,c' +!4. If there is no entry between two commas that are not positioned in the end of the line, a missing value is assumed to +!exist between these two commas and this missing value is denoted with -9999, i.e. +! i.e. '1,,3,4,a,b,c'='1,-9999,3,4,a,b,c' +!5. Comma has priotity as a separating characer. E.g commas and blank spaces are not used simultaneously as +! separating characters in a single line. When both commas and blank spaces appear in the line, comma is +! the saparating character and blank spaces are repalced with '_' + integer nmax,n + character longchar*(*),charvars(nmax+100)*50 + integer i,k,pos1,pos2,leng,posindex(0:nmax+100),itiscomma +! + leng=LEN_TRIM(longchar) + i=leng +5 k=ichar(longchar(i:i)) + if(k.eq.44.or.k.le.32.or.k.ge.127)then + longchar(i:i)=char(32) + i=i-1 + if(i.gt.1)goto 5 +!empty line + n=0 + return + endif + leng=i + + itiscomma=0 + do i=1,leng + if(ichar(longchar(i:i)).eq.44)itiscomma=itiscomma+1 + enddo + if(itiscomma.gt.0)then +!If the line contains at least one comma, it is assumed a comma separated line + n=0 + do i=1,leng + if(ichar(longchar(i:i)).eq.44)then + n=n+1 + posindex(n)=i + endif + enddo + n=n+1 + posindex(0)=0 + posindex(n)=leng+1 + do i=1,n + pos1=posindex(i-1)+1 + pos2=posindex(i)-1 + If(pos1.gt.pos2)goto 50 +30 if(ichar(longchar(pos1:pos1)).ge.33.and. + &ichar(longchar(pos1:pos1)).le.126)goto 40 + if(pos1.lt.pos2)then + pos1=pos1+1 + goto 30 + endif +!pos1=pos2 and missing entry + pos1=pos2+1 + goto 50 +40 if(ichar(longchar(pos2:pos2)).ge.33.and. + &ichar(longchar(pos2:pos2)).le.126)goto 50 + if(pos2.gt.pos1)then + pos2=pos2-1 + goto 40 + endif + pos1=pos2+1 +50 If(pos1.gt.pos2)then + charvars(i)='-9999' + else + do k=pos1+1,pos2-1 + if(ichar(longchar(k:k)).le.32.or. + &ichar(longchar(k:k)).ge.127)longchar(k:k)='_' + enddo + charvars(i)=longchar(pos1:pos2) + endif + enddo + return + endif +!non-comma separated file + n=0 + pos1=0 +10 pos1=pos1+1 + if(pos1.gt.leng)return + if(ichar(longchar(pos1:pos1)).le.32.or. + &ichar(longchar(pos1:pos1)).ge.127)goto 10 +!pos1 is the first character in the character variable. +!now locate the end character + pos2=pos1 +20 pos2=pos2+1 + if(ichar(longchar(pos2:pos2)).ge.33.and. + &ichar(longchar(pos2:pos2)).le.126)then + if(pos2.le.leng)goto 20 + endif + pos2=pos2-1 + n=n+1 + charvars(n)=longchar(pos1:pos2) + pos1=pos2 + goto 10 + return + end subroutine charlineparser diff --git a/dataassim/math/othersupmath/clustering.f b/dataassim/math/othersupmath/clustering.f new file mode 100644 index 0000000..fa6e81c --- /dev/null +++ b/dataassim/math/othersupmath/clustering.f @@ -0,0 +1,159 @@ + subroutine testclustering + implicit none + integer nsamp,ndim,i,ibelong(20),ngroups + double precision value(20,20),stdvalue(20,20),critdist + value(1,1)=2.105d0 + value(1,2)=2.301d0 + value(2,1)=1.902d0 + value(2,2)=1.8203d0 + value(3,1)=2.202d0 + value(3,2)=1.9508d0 + value(4,1)=1.861111d0 + value(4,2)=2.05232323d0 + + value(5,1)=1.1d0 + value(5,2)=1.3d0 + value(6,1)=0.9d0 + value(6,2)=0.82d0 + value(7,1)=1.2d0 + value(7,2)=0.95d0 + value(8,1)=0.86d0 + value(8,2)=1.05d0 + + value(9,1)=10.1d0 + value(9,2)=10.3d0 + value(10,1)=10.9d0 + value(10,2)=0.82d0 + value(11,1)=-11.2d0 + value(11,2)=0.95d0 + value(12,1)=-20.85d0 + value(12,2)=1.05d0 + critdist=0.5d0 + nsamp=12 + ndim=2 + + call clustering(nsamp,ndim,value(1:nsamp,1:ndim), + &critdist,ngroups,ibelong) + call aftercluster(nsamp,ndim,value(1:nsamp,1:ndim), + &ngroups,ibelong,stdvalue(1:ngroups,1:ndim)) + do i=1,ngroups + write(*,*)i,value(i,1),value(i,2) + enddo + write(*,*)i + do i=1,ngroups + write(*,*)i,stdvalue(i,1),stdvalue(i,2) + enddo + + end + +!Cluster points with values differing less than a critical distance value + subroutine clustering(nsamp,ndim,value,critdist,ngroups,ibelong) + implicit none + integer nsamp,ndim,ibelong(nsamp),ngroups + double precision value(nsamp,ndim),critdist +!critdist: critical distance. if negative, the criterion is a percentage value +! from the origin (%) +!outputs: +!ngroups: the number of groups in the input data (value) +!ibelong: which group a point belongs + integer i,j,k,matrix(nsamp,nsamp),nsum(nsamp) + double precision dif,radius(nsamp) + + ngroups=nsamp + if(nsamp.le.1)return + + do i=1,nsamp + ibelong(i)=-9999 + if(critdist.lt.0.0d0)then + radius(i)=0.0d0 + do j=1,ndim + radius(i)=radius(i)+value(i,j)**2 + enddo + radius(i)=dsqrt(radius(i))*(-critdist*0.01d0) + else + radius(i)=critdist + endif + enddo + do i=1,nsamp + do j=1,nsamp + matrix(i,j)=0 + if(i.ne.j)then + dif=0.0d0 + do k=1,ndim + dif=dif+(value(i,k)-value(j,k))**2 + enddo + dif=dsqrt(dif) + if(dif.le.radius(i))matrix(i,j)=1 + endif + enddo + nsum(i)=0 + do j=1,nsamp + nsum(i)=nsum(i)+matrix(i,j) + enddo + enddo + + ngroups=0 +!finding the point with the most crowded neighbors +50 k=1 + do i=2,nsamp + if(nsum(i).gt.nsum(k))k=i + enddo + if(nsum(k).eq.0)goto 100 + ngroups=ngroups+1 + ibelong(k)=ngroups + do i=1,nsamp + if(matrix(k,i).ne.0)then + ibelong(i)=ngroups + do j=1,nsamp + matrix(i,j)=0 + enddo + matrix(k,i)=0 + endif + enddo + do i=1,nsamp + nsum(i)=0 + do j=1,nsamp + nsum(i)=nsum(i)+matrix(i,j) + enddo + enddo + goto 50 +100 do i=1,nsamp + if(ibelong(i).lt.0)then + ngroups=ngroups+1 + ibelong(i)=ngroups + endif + enddo + return + end + + subroutine aftercluster(nsamp,ndim,value,ngroups,ibelong,stdvalue) + implicit none + integer nsamp,ndim,ibelong(nsamp),ngroups + double precision value(nsamp,ndim),stdvalue(ngroups,ndim) +!ngroups: the number of groups in the input data (value) +!ibelong: which group a point belongs +!replace the first ngroups in value by the group means and store std in stdvalue + integer i,j,k,n + double precision fn9999,vector(nsamp),fmean(ngroups,ndim), + &xmin,xmax + parameter(fn9999=-9999.0d0) + do i=1,ngroups + do j=1,ndim + n=0 + do k=1,nsamp + if(ibelong(k).eq.i)then + n=n+1 + vector(n)=value(k,j) + endif + enddo + call + &stdmaxmeanmin(n,vector,stdvalue(i,j),fmean(i,j),xmin,xmax) + enddo + enddo + do i=1,ngroups + do j=1,ndim + value(i,j)=fmean(i,j) + enddo + enddo + return + end diff --git a/dataassim/math/othersupmath/curvecrossing.f b/dataassim/math/othersupmath/curvecrossing.f new file mode 100644 index 0000000..ab3a01a --- /dev/null +++ b/dataassim/math/othersupmath/curvecrossing.f @@ -0,0 +1,173 @@ + subroutine curvecrossing(ncurves,nsamp,maxnsamp,xdata,ydata, + ¶ms,xcross,ycross) + implicit none +!fit ncurves curves from ncurves pairs of datasets and estimate the mean crossings of the curves + integer ncurves,nsamp(ncurves),maxnsamp,i,j,k,n,m,ndim, + &iderivative,INFO + double precision xdata(ncurves,maxnsamp),ydata(ncurves,maxnsamp), + &xcross,ycross,x(maxnsamp),y(maxnsamp),a(ncurves),b(ncurves), + &c(ncurves),d(ncurves),beta(10),betamin(10),betamax(10), + &weitx(maxnsamp),weity(maxnsamp),xmin(maxnsamp),xmax(maxnsamp), + &y_pred(maxnsamp),x_pred(maxnsamp),sumsquare, + ¶ms(ncurves,4) + + k=0 + do i=1,ncurves + do j=1,4 + params(i,j)=-9999.0d0 + enddo + n=0 + do j=1,nsamp(i) + if(dabs(xdata(i,j)+9999.0d0).gt.1.0d-8.and. + &dabs(ydata(i,j)+9999.0d0).gt.1.0d-8)then + n=n+1 + x(n)=xdata(i,j) + y(n)=ydata(i,j) + endif + enddo + if(n.gt.1)then + k=k+1 + beta(1)=30.0d0 + betamin(1)=0.0d0 + betamax(1)=200.0d0 + beta(2)=-4.0d0 + betamin(2)=-100.0d0 + betamax(2)=0.0d0 + beta(3)=8.0d0 + betamin(3)=0.0d0 + betamax(3)=200.0d0 + beta(4)=-0.5d0 + betamin(4)=-10.0d0 + betamax(4)=0.0d0 + do j=1,n + weitx(j)=1.0d0 + weity(j)=1.0d0 + xmin(j)=0.0d0 + xmax(j)=x(j)+20.0d0 + enddo + ndim=4 + iderivative=1 + call GenericRegres(n,1,y,1,x,weity,weitx,ndim,beta,betamin, + &betamax,xmin,xmax,iderivative,0,y_pred,x_pred,sumsquare) + a(k)=beta(1) + b(k)=beta(2) + c(k)=beta(3) + d(k)=beta(4) + do j=1,ndim + params(i,j)=beta(j) + enddo + endif + enddo + if(k.gt.0)then + call curmeancrossing(k,a,b,c,d,xcross,ycross) + else + xcross=-9999.0d0 + ycross=-9999.0d0 + endif + return + end + + subroutine curmeancrossing(ncurves,a,b,c,d,xcross,ycross) + implicit none +!calculate the average crossing point of the ncurves curves. + integer ncurves,i,j,k + double precision a(ncurves),b(ncurves),c(ncurves),d(ncurves), + &xcross,ycross,x(ncurves),y(ncurves),a1,b1,c1,d1,a2,b2,c2,d2, + &p,q,u,root1,root2,small,term,x1_root1,x2_root1,x1_root2,x2_root2, + &x_root1,x_root2 + parameter(small=1.0d-7) + k=0 + do i=1,ncurves-1 + do j=i+1,ncurves + a1=a(i) + b1=b(i) + c1=c(i) + d1=d(i) + a2=a(j) + b2=b(j) + c2=c(j) + d2=d(j) + term=dabs(a1-a2)+dabs(b1-b2)+dabs(c1-c2) + if(term.lt.small)goto 100 + p=a1-a2+d1-d2 + q=a1*(c2+b1)-a2*(c1+b2)+(d1-d2)*(c2+c1) + u=a1*b1*c2-a2*b2*c1+(d1-d2)*c1*c2 + call quadraticroots(p,q,u,root1,root2) + if(root1.gt.0.0d0.or.root2.gt.0.0d0)then + k=k+1 + if(root1.gt.0.0d0.and.root2.gt.0.0d0)then + x(k)=root1 + else + if(root1.gt.0.0d0)then + x(k)=root1 + else + x(k)=root2 + endif + endif + y(k)=a1*(x(k)+b1)/(x(k)+c1)+d1 + else + if(dabs(b1-c1).gt.small)then + term=a2*(b2-c2)/(a1*(b1-c1)) + if(term.ge.0.0d0)then + term=dsqrt(term) + root1=((d1+a1)*term+d2+a2)/(term+1.0d0) + if(dabs(term-1.0d0).gt.small)then + root2=((d1+a1)*term-d2-a2)/(term-1.0d0) + else + root2=-9999.0d0 + endif + x1_root1=-c1+a1*(b1-c1)/(root1-d1-a1) + x2_root1=-c2+a2*(b2-c2)/(root1-d2-a2) + if(dabs(root2+9999.0d0).gt.small)then + x1_root2=-c1+a1*(b1-c1)/(root2-d1-a1) + x2_root2=-c2+a2*(b2-c2)/(root2-d2-a2) + else + x1_root2=-9999.0d0 + x2_root2=-9999.0d0 + endif + if(x1_root1.gt.0.0d0.and.x2_root1.gt.0.0d0)then + x_root1=(x1_root1+x2_root1)/2.0d0 + else + x_root1=-9999.0d0 + endif + if(x1_root2.gt.0.0d0.and.x2_root2.gt.0.0d0)then + x_root2=(x1_root2+x2_root2)/2.0d0 + else + x_root2=-9999.0d0 + endif + if(x_root1.gt.0.0d0.or.x_root2.gt.0.0d0)then + k=k+1 + if(x_root1.gt.0.0d0.and.x_root2.gt.0.0d0)then + x(k)=x_root2 + y(k)=root2 + else + if(x_root1.gt.0.0d0)then + x(k)=x_root1 + y(k)=root1 + else + x(k)=x_root2 + y(k)=root2 + endif + endif + endif + endif + endif + endif +100 continue + enddo + enddo + if(k.gt.0)then + xcross=0.0d0 + ycross=0.0d0 + do i=1,k + xcross=xcross+x(i) + ycross=ycross+y(i) + enddo + xcross=xcross/dble(k) + ycross=ycross/dble(k) + else + xcross=-9999.0d0 + ycross=-9999.0d0 + endif + return + end diff --git a/dataassim/math/othersupmath/doy_to_monthday.f b/dataassim/math/othersupmath/doy_to_monthday.f new file mode 100644 index 0000000..0818cfe --- /dev/null +++ b/dataassim/math/othersupmath/doy_to_monthday.f @@ -0,0 +1,32 @@ + subroutine doy_to_monthday(month,monthday,year,idoy) +!extract month,day of month from year and day of year + implicit none + integer month,monthday,year,idoy,isitaleapyear, + &i,j,k,ndays(12) + ndays(1)=31 + ndays(2)=28+isitaleapyear(year) + ndays(3)=31 + ndays(4)=30 + ndays(5)=31 + ndays(6)=30 + ndays(7)=31 + ndays(8)=31 + ndays(9)=30 + ndays(10)=31 + ndays(11)=30 + ndays(12)=31 + k=0 + do i=1,12 + do j=1,ndays(i) + k=k+1 + if(k.eq.idoy)then + month=i + monthday=j + return + endif + enddo + enddo + month=-9999 + monthday=-9999 + return + end diff --git a/dataassim/math/othersupmath/extCharToFloatNum.f b/dataassim/math/othersupmath/extCharToFloatNum.f new file mode 100644 index 0000000..1c40dbf --- /dev/null +++ b/dataassim/math/othersupmath/extCharToFloatNum.f @@ -0,0 +1,190 @@ + subroutine extCharToFloatNum(numchar0,cpastring,f,ierr) + implicit none +!Transform a string of length numchar consisting all numbers (e.g. 1234 or 12.19, .123, +!or 12.89d+5 or 12.89d-5, d could have been D, e, or E) into a double precision float +!number. +!ierr=0, successful conversion +! =1, conversion failed + character astring*50,cpastring*(*),c*1,d*1 + double precision f,fsign,factor + integer ipos1,ipos2,ideci,k,j,i,m,numchar0, + & numchar,ierr,ispartnum,nlength + + nlength=len(trim(cpastring)) +! +!return error with empty string + if(nlength.eq.0)then + f=-9999.0d0 + ierr=1 + return + endif + if(index(cpastring,'n').ne.0)then +!in case of 'nan' + f=-9999.0d0 + ierr=1 + return + endif + if(index(cpastring,'N').ne.0)then +!in case of 'NAN' + f=-9999.0d0 + ierr=1 + return + endif +!First remove space and change '.123' to '0.123' + ipos1=0 + numchar=0 + i=0 +10 i=i+1 + if(numchar.eq.nlength)goto 11 + c=cpastring(i:i) + if(ispartnum(c).eq.1)then + if(ipos1.eq.0)ipos1=i + numchar=numchar+1 + goto 10 + else + if(numchar.eq.0)goto 10 + endif +11 astring=cpastring(ipos1:(ipos1+numchar-1)) + if(astring(numchar:numchar).eq.'.')then + astring=astring(1:numchar)//'0' + numchar=numchar+1 + endif + if(astring(1:1).eq.'.')then + astring='0'//astring(1:numchar) + numchar=numchar+1 + endif + if(astring(1:2).eq.'-.')then + astring='-0.'//astring(3:numchar) + numchar=numchar+1 + endif + if(astring(1:2).eq.'+.')then + astring='0.'//astring(3:numchar) + endif + ierr=1 + f=-9999.0d0 + fsign=1.0d0 + ipos1=1 +190 c=astring(ipos1:ipos1) + if(ispartnum(c).eq.1)goto 200 + ipos1=ipos1+1 + goto 190 +200 ipos2=ipos1+numchar-1 + if(astring(ipos1:ipos1).eq.'-')then + ipos1=ipos1+1 + fsign=-1.0d0 + else + if(astring(ipos1:ipos1).eq.'+')ipos1=ipos1+1 + endif + ideci=index(astring,'.') + if(ideci.eq.0)then +!1234, 1234e+6, 1234e-6,1234e6, e can be E, d, or D + m=ipos2 + else + m=ideci-1 + endif + factor=1.0d0 + k=0 + j=0 + i=m +210 c=astring(i:i) + if(c.eq.'+'.or.c.eq.'-')then + if(i.eq.m)return + if(i.gt.(ipos1+1))then + i=i-1 + d=astring(i:i) + if(d.eq.'e'.or.d.eq.'E'.or.d.eq.'d'.or.d.eq.'D')then + if(c.eq.'+')then + factor=10.0d0**(dble(k)) + else + factor=10.0d0**(dble(-k)) + endif + else + return + endif + k=0 + j=0 + else + return + endif + else + if(c.eq.'e'.or.c.eq.'E'.or.c.eq.'d'.or.c.eq.'D')then + if(i.eq.m)return + if(i.gt.ipos1)then + factor=10.0d0**(dble(k)) + k=0 + j=0 + else + return + endif + else + if((ichar(c)-48).ge.0.and.(ichar(c)-48).le.9)then + k=k+(ichar(c)-48)*(10**j) + j=j+1 + else + return + endif + endif + endif + if(i.gt.ipos1)then + i=i-1 + goto 210 + endif + f=dble(k)*factor + k=0 + if(ideci.gt.0)then +!18.27 type of character + i=ideci+1 +220 c=astring(i:i) + if((ichar(c)-48).ge.0.and.(ichar(c)-48).le.9)then + k=k+1 + f=f+dble(ichar(c)-48)*(10.0d0**(-k)) + if(i.lt.ipos2)then + i=i+1 + goto 220 + endif + else + if(c.eq.'e'.or.c.eq.'E'.or.c.eq.'d'.or.c.eq.'D')then + if(i.eq.ipos2)return + if(astring(ipos2:ipos2).eq.'+'.or. + & astring(ipos2:ipos2).eq.'-')return + i=i+1 + c=astring(i:i) + ipos1=i+1 + if(c.eq.'-')then + m=0 + else + m=1 + if(c.ne.'+')then + if((ichar(c)-48).ge.0.and.(ichar(c)-48).le.9)then + ipos1=i + else + return + endif + endif + endif + k=0 + j=0 + do i=ipos2,ipos1,-1 + c=astring(i:i) + if((ichar(c)-48).ge.0.and.(ichar(c)-48).le.9)then + k=k+(ichar(c)-48)*(10**j) + j=j+1 + else + return + endif + enddo + if(m.eq.0)then + f=f/(10.0d0**dble(k)) + else + f=f*(10.0d0**dble(k)) + endif + else + return + endif + endif + endif + f=f*fsign + ierr=0 + return + end subroutine extCharToFloatNum + diff --git a/dataassim/math/othersupmath/findplateau.f b/dataassim/math/othersupmath/findplateau.f new file mode 100644 index 0000000..985db48 --- /dev/null +++ b/dataassim/math/othersupmath/findplateau.f @@ -0,0 +1,305 @@ +!Identifying the flat portion of a curve by computing the mean slope of +!all possible pairs. Data must be ranked with xvar from low to high + subroutine findplateau(npoints,xvar,yvar,iflat, + & flatmean,radius) + implicit none + integer npoints,iflat(npoints),isoutlier_1side + double precision xvar(npoints),yvar(npoints), + & flatmean,radius,t0,ymax + integer i,j,k,m,n,nstart,nend,isslopezero,no1,no2, + & no3,nset + double precision der(npoints*(npoints-1)/2),std,term, + & student_t,slopemin,Sign_Level,coeffvar,coeffvarmin, + & xx(npoints),yy(npoints),ainter,bslope,r,eps + parameter(Sign_Level=0.90d0,eps=1.0d-6,nset=3) + + do i=1,npoints + iflat(i)=1 + enddo + nend=-9999 + nstart=0 + slopemin=1.0d+9 + coeffvarmin=1.0d+9 + flatmean=-9999.0d0 + radius=-9999.0d0 + + ymax=0.0d0 + do i=1,nset + ymax=ymax+yvar(i) + enddo + ymax=ymax/dble(nset) + nstart=1 + do i=2,npoints-nset+1 + term=0.0d0 + do j=i,i+nset-1 + term=term+yvar(j) + enddo + term=term/dble(nset) + if(term.ge.ymax)then + ymax=term + nstart=i + endif + enddo + no1=nstart + do i=nstart+1,nstart+nset-1 + if(yvar(i).ge.yvar(no1))then + no1=i + endif + enddo + nstart=1 +500 k=no1-nstart+1 + if(k.lt.3)then + nstart=no1 + goto 510 + endif + do i=nstart,no1 + xx(i-nstart+1)=xvar(i) + yy(i-nstart+1)=yvar(i) + enddo + call linregres(k,xx,yy,Sign_Level,ainter, + & bslope,r,radius,isslopezero) + if(isslopezero.eq.-1)then + nstart=nstart+1 + goto 500 + endif +510 nend=no1 + if((nend-nstart+1).le.4)then + k=nstart + do i=1,k-1 + do j=k,nend + if(yvar(j).lt.yvar(i))then + nstart=no1 + endif + enddo + enddo + endif + nend=npoints +600 k=nend-no1+1 + if(k.lt.3)then + nend=no1 + goto 610 + endif + do i=no1,nend + xx(i-no1+1)=xvar(i) + yy(i-no1+1)=yvar(i) + enddo + call linregres(k,xx,yy,Sign_Level,ainter, + & bslope,r,radius,isslopezero) + if(isslopezero.eq.-1)then + nend=nend-1 + goto 600 + endif +610 if((nend-no1+1).le.4)then + k=nend + do i=k+1,npoints + do j=no1,k + if(yvar(j).lt.yvar(i))then + nend=no1 + endif + enddo + enddo + endif + if((nend-nstart).eq.0)then + if(no1.eq.npoints)return + if(no1.eq.1)then + do i=1,npoints + iflat(i)=3 + enddo + return + endif + nstart=no1-1 + nend=no1 + endif + goto 100 + +!find the three largest value in yvar + if(yvar(1).lt.yvar(2))then + no1=2 + no2=1 + else + no1=1 + no2=2 + endif + if(yvar(3).ge.yvar(no1))then + no3=no2 + no2=no1 + no1=3 + else + if(yvar(3).lt.yvar(no2))then + no3=3 + else + no3=no2 + no2=3 + endif + endif + do i=4,npoints + if(yvar(i).ge.yvar(no1))then + no3=no2 + no2=no1 + no1=i + else + if(yvar(i).ge.yvar(no2))then + no3=no2 + no2=i + else + if(yvar(i).ge.yvar(no3))then + no3=i + endif + endif + endif + enddo + If(no1.gt.no2.and.no1.gt.no3)then + nend=no1 + if(no2.gt.no3)then + nstart=no3 + else + nstart=no2 + endif + endif + If(no2.gt.no1.and.no2.gt.no3)then + nend=no2 + if(no1.gt.no3)then + nstart=no3 + else + nstart=no1 + endif + endif + If(no3.gt.no1.and.no3.gt.no2)then + nend=no3 + if(no1.gt.no2)then + nstart=no2 + else + nstart=no1 + endif + endif + if(nstart.gt.1)then + i=1 +2 if(dabs(yvar(i)-yvar(no1)).lt.eps.or. + & dabs(yvar(i)-yvar(no2)).lt.eps.or. + & dabs(yvar(i)-yvar(no3)).lt.eps)then + nstart=i + goto 1 + endif + i=i+1 + if(i.eq.nstart)goto 1 + goto 2 + endif +1 if(nend.lt.npoints)then + i=nend+1 +3 if(dabs(yvar(i)-yvar(no1)).lt.eps.or. + & dabs(yvar(i)-yvar(no2)).lt.eps.or. + & dabs(yvar(i)-yvar(no3)).lt.eps)then + nend=i + endif + if(i.eq.npoints)goto 4 + i=i+1 + goto 3 + endif +4 do i=nstart,nend + xx(i-nstart+1)=xvar(i) + yy(i-nstart+1)=yvar(i) + enddo + k=nend-nstart+1 + call linregres(k,xx,yy,Sign_Level,ainter, + & bslope,r,radius,isslopezero) + if(isslopezero.eq.-1)then + if(no1.eq.npoints)return + if(no1.eq.nstart)then + nstart=no1 + nend=no1 + goto 100 + endif + if(no1.gt.no2)then + nstart=no2 + nend=no1 + else + nstart=no1 + nend=no2 + endif + goto 100 + endif + slopemin=dabs(bslope) + call stdmean(k,yy,std,flatmean) + coeffvarmin=std/flatmean +10 if(nend.eq.npoints)goto 50 + if(no1.eq.nend)then + if(dabs(yvar(nend+1)-yvar(no1)).lt.eps.or. + & dabs(yvar(nend+1)-yvar(no2)).lt.eps.or. + & dabs(yvar(nend+1)-yvar(no3)).lt.eps)then + nend=nend+1 + goto 10 + else + goto 50 + endif + endif + do k=no1,nend+1 + xx(k-no1+1)=xvar(k) + yy(k-no1+1)=yvar(k) + enddo + k=nend+1-no1+1 + call linregres(k,xx,yy,Sign_Level,ainter,bslope, + & r,radius,isslopezero) + if(isslopezero.eq.-1)goto 50 + call stdmean(k,yy,std,flatmean) + coeffvar=std/flatmean + nend=nend+1 + goto 10 +50 if(nstart.eq.1)goto 100 + if(no1.eq.nstart)then + if(dabs(yvar(nstart-1)-yvar(no1)).lt.eps.or. + & dabs(yvar(nstart-1)-yvar(no2)).lt.eps.or. + & dabs(yvar(nstart-1)-yvar(no3)).lt.eps)then + nstart=nstart-1 + goto 50 + else + goto 100 + endif + endif + do k=nstart-1,no1 + xx(k-nstart+1+1)=xvar(k) + yy(k-nstart+1+1)=yvar(k) + enddo + k=no1-(nstart-1)+1 + call linregres(k,xx,yy,Sign_Level,ainter,bslope, + & r,radius,isslopezero) + if(isslopezero.eq.-1)goto 100 + call stdmean(k,yy,std,flatmean) + coeffvar=std/flatmean + nstart=nstart-1 + goto 50 + +100 if(nstart.le.nend)then + n=0 + do i=nstart,nend + n=n+1 + der(n)=yvar(i) + enddo + if(n.gt.1)then + call stdmean(n,der,std,flatmean) + t0=student_t(n-1,Sign_Level) + radius=t0*std/dsqrt(dble(n)) + else + flatmean=der(1) + radius=-9999.0d0 + endif + do i=1,nstart-1 + iflat(i)=1 + enddo + do i=nstart,nend + iflat(i)=2 + enddo + do i=nend+1,npoints + iflat(i)=3 + enddo + if(n.gt.2)then + k=isoutlier_1side(n,der,-1) + if(k.eq.1)then + iflat(nstart)=1 + endif + if(k.eq.n)then + iflat(nend)=3 + endif + endif + endif + return + end diff --git a/dataassim/math/othersupmath/fortranswap.f b/dataassim/math/othersupmath/fortranswap.f new file mode 100644 index 0000000..aac7b23 --- /dev/null +++ b/dataassim/math/othersupmath/fortranswap.f @@ -0,0 +1,11 @@ + subroutine fortranswap(n,x1,x2) + implicit none + integer n,i + double precision x1(n),x2(n),term + do i=1,n + term=x1(i) + x1(i)=x2(i) + x2(i)=term + enddo + return + end diff --git a/dataassim/math/othersupmath/ftest.f b/dataassim/math/othersupmath/ftest.f new file mode 100644 index 0000000..1df8beb --- /dev/null +++ b/dataassim/math/othersupmath/ftest.f @@ -0,0 +1,110 @@ + subroutine ftest(data1,n1,data2,n2,f,prob) + implicit none + integer n1,n2 + double precision f,prob,data1(n1),data2(n2) +!given the arrays data1 and data2, this routine returns the value of f +!and the significance as prob. Small values of prob indicate that the +!two arrays have significantly different variances + double precision ave1,ave2,df1,df2,var1,var2,betai, + &xmin,xmax + call stdmaxmeanmin(n1,data1,var1,ave1,xmin,xmax) + var1=var1*var1 + call stdmaxmeanmin(n2,data2,var2,ave2,xmin,xmax) + var2=var2*var2 + if(var1.gt.var2)then + f=var1/var2 + df1=dble(n1-1) + df2=dble(n2-1) + else + f=var2/var1 + df1=dble(n2-1) + df2=dble(n1-1) + endif + prob=2.0d0*betai(0.5d0*df2,0.5d0*df1,df2/(df2+df1*f)) + if(prob.gt.1.0d0)prob=2.0d0-prob + return + end + +c#################################################################### + subroutine ftestrsq_rms(ymeas,ypred,n0,nparams,rsq,rms,agrind, + &rmse_norm,rmse_perc,aic,aicc,f,prob) + implicit double precision (a-h,l,o-z) + dimension ymeas(n0),ypred(n0),y1(n0),y2(n0) + fn9999=-9999.0d0 + tiny=1.0d-7 + n=0 + do i=1,n0 + if(dabs(ymeas(i)-fn9999).gt.tiny.and. + &dabs(ypred(i)-fn9999).gt.tiny)then + n=n+1 + y1(n)=ymeas(i) + y2(n)=ypred(i) + endif + enddo + ymin=y1(1) + ymax=y1(1) + do i=2,n + if(y1(i).lt.ymin)ymin=y1(i) + if(y1(i).gt.ymax)ymax=y1(i) + enddo + sum=0.0d0 + rmse_perc=0.0d0 + do 10 i=1,n + sum=sum+(y1(i)-y2(i))*(y1(i)-y2(i)) + rmse_perc=rmse_perc+(y1(i)-y2(i))*(y1(i)-y2(i))/(y2(i)*y2(i)) +10 continue + rms=dsqrt(sum/dble(n)) + if(nparams.gt.0)then + aic=dble(n)*dlog(rms*rms)+2.0d0*dble(nparams) + aicc=aic+2.0d0*dble(nparams*(nparams+1))/dble(n-nparams-1) + else + aic=-9999.0d0 + aicc=-9999.0d0 + endif + rmse_norm=rms/(ymax-ymin) + rmse_perc=100.0d0*dsqrt(rmse_perc/dble(n)) + ymean1=0.0d0 + ymean2=0.0d0 + do 20 i=1,n + ymean1=ymean1+y1(i) + ymean2=ymean2+y2(i) +20 continue + ymean1=ymean1/dble(n) + ymean2=ymean2/dble(n) + sum1=0.0d0 + sum2=0.0d0 + sum3=0.0d0 + sum4=0.0d0 + sum5=0.0d0 + do 30 i=1,n + sum1=(y1(i)-ymean1)*(y2(i)-ymean2)+sum1 + sum2=(y1(i)-ymean1)*(y1(i)-ymean1)+sum2 + sum3=(y2(i)-ymean2)*(y2(i)-ymean2)+sum3 + sum4=(y1(i)-y2(i))*(y1(i)-y2(i))+sum4 + sum5=(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))* + &(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))+sum5 + sum6=sum6+(y2(i)-ymean1)*(y2(i)-ymean1) +30 continue + if((sum2*sum3).eq.0.0d0)then + rsq=-9999.0d0 + else + rsq=sum1/dsqrt(sum2*sum3) + rsq=rsq*rsq + endif + if(sum5.eq.0.0d0)then + agrind=-9999.0d0 + else + agrind=1.0d0-sum4/sum5 + endif + if(rsq.gt.0.0d0)then + df1=dble(nparams-1) + df2=dble(n-nparams) + f=(sum6/df1)/(sum4/df2) + prob=betai(0.5d0*df2,0.5d0*df1,df2/(df2+df1*f)) + else + f=-9999.0d0 + prob=-9999.0d0 + endif + return + end +!#################################################################### diff --git a/dataassim/math/othersupmath/gapfilling.f b/dataassim/math/othersupmath/gapfilling.f new file mode 100644 index 0000000..48589fa --- /dev/null +++ b/dataassim/math/othersupmath/gapfilling.f @@ -0,0 +1,148 @@ +!This subroutine fills gaps in the y variable based on neural network regression + subroutine gapfilling(nx,nobs,xsamp,ysamp,nmax,maxdist) + implicit none +!Gaps must be represented by -9999 +!It is ok to have missing values in xsamp. If any dimension in xsamp is missing, that dimension +!is not used as the independent variable for the gap in y. For different gaps in y, the dimensions used +!in x may be different. +!If a gap is less than maxdist points away from a previous gap for which a fit was conducted and if +!the dimension is the same, then the previous fit is used (a new fit is not conducted) + integer nx,nobs,nmax + double precision xsamp(1:nobs,1:nx),ysamp(1:nobs) +!Locals + integer i,j,k,n,idowhat,nh,nxfit,nobsfit,negobsfit,ixuse(nx), + &ipregap,iposfit(-nmax:nmax),iuseit,ixuse_pre(nx),maxdist + parameter(nh=15) + double precision w(1:nx,1:nh),bph(nh),q(nh),bend, + &xnew(nx),calvalue(nobs),fn9999,tiny,xfit(-nmax:nmax,nx), + &yfit(-nmax:nmax),rsq,ysamppred(nobs) + parameter(fn9999=-9999.0d0,tiny=1.0d-6) +! + bend=fn9999 + ipregap=-100000 + do i=1,nobs + ysamppred(i)=ysamp(i) + if(dabs(ysamp(i)-fn9999).gt.tiny)goto 1000 +!a gap + nxfit=0 + do j=1,nx + if(dabs(xsamp(i,j)-fn9999).lt.tiny)then +!this x dimension is not used + ixuse(j)=0 + else +!this x dimension is used + nxfit=nxfit+1 + xnew(nxfit)=xsamp(i,j) + ixuse(j)=1 + endif + enddo + if(nxfit.eq.0)goto 1000 + if((i-ipregap).lt.maxdist)then + iuseit=1 + do j=1,nx + if(ixuse(j).ne.ixuse_pre(j))iuseit=0 + enddo + if(iuseit.eq.1)goto 30 + endif + +!Fill this gap by choosing the nmax valid points that are closest to i for the fitting +!First pick up nmax points from the lower side, index positive + nobsfit=0 + n=i-1 +1 if(n.lt.1)goto 2 + if(dabs(ysamp(n)-fn9999).gt.tiny)then + iuseit=1 +!make sure it has the x dimensions needed + do j=1,nx + if(ixuse(j).eq.1)then + if(dabs(xsamp(n,j)-fn9999).lt.tiny)iuseit=0 + endif + enddo + if(iuseit.eq.1)then + nobsfit=nobsfit+1 + yfit(nobsfit)=ysamp(n) + iposfit(nobsfit)=n + k=0 + do j=1,nx + if(ixuse(j).eq.1)then + k=k+1 + xfit(nobsfit,k)=xsamp(n,j) + endif + enddo + endif + endif + if(nobsfit.lt.nmax)then + n=n-1 + goto 1 + endif +! +!now pick up nmax points form the higher side, index negative +2 negobsfit=1 + n=i+1 +3 if(n.gt.nobs)goto 4 + if(dabs(ysamp(n)-fn9999).gt.tiny)then + iuseit=1 +!make sure it has the x dimensions needed + do j=1,nx + if(ixuse(j).eq.1)then + if(dabs(xsamp(n,j)-fn9999).lt.tiny)iuseit=0 + endif + enddo + if(iuseit.eq.1)then + negobsfit=negobsfit-1 + yfit(negobsfit)=ysamp(n) + iposfit(negobsfit)=n + k=0 + do j=1,nx + if(ixuse(j).eq.1)then + k=k+1 + xfit(negobsfit,k)=xsamp(n,j) + endif + enddo + endif + endif + if(negobsfit.gt.-nmax)then + n=n+1 + goto 3 + endif + +!finally pick up the nmax closest points +4 if((nobsfit-negobsfit+1).le.nmax)goto 10 + if((i-iposfit(nobsfit)).gt.(iposfit(negobsfit)-i))then + nobsfit=nobsfit-1 + else + negobsfit=negobsfit+1 + endif + goto 4 +10 do n=negobsfit,0 + nobsfit=nobsfit+1 + yfit(nobsfit)=yfit(n) + do j=1,nxfit + xfit(nobsfit,j)=xfit(n,j) + enddo + enddo + idowhat=1 + call NeuralNetRegres(idowhat,nxfit,nobsfit,nh, + &xfit(1:nobsfit,1:nxfit),yfit,calvalue,rsq, + &w(1:nxfit,1:nh),bph,q,bend,xnew,ysamppred(i:i)) + + do j=1,nobsfit + write(122,*)j,yfit(j),calvalue(j) + enddo + + ipregap=i + do j=1,nxfit + ixuse_pre(j)=ixuse(j) + enddo +30 idowhat=2 + call NeuralNetRegres(idowhat,nxfit,1,nh, + &xfit(1:1,1:nxfit),yfit,calvalue,rsq, + &w(1:nxfit,1:nh),bph,q,bend,xnew,ysamppred(i:i)) +1000 continue + enddo + do i=1,nobs + ysamp(i)=ysamppred(i) + enddo +300 format(10f16.8) + return + end subroutine gapfilling diff --git a/dataassim/math/othersupmath/gapfillingold.f b/dataassim/math/othersupmath/gapfillingold.f new file mode 100644 index 0000000..deef7db --- /dev/null +++ b/dataassim/math/othersupmath/gapfillingold.f @@ -0,0 +1,103 @@ +!This subroutine fills gaps in the y variable based on neural network regression + subroutine gapfilling(nx,nobs,xsamp,ysamp,nmax) + implicit none +!Gaps must be represented by -9999 +!It is ok to have missing values in xsamp. If any dimension in xsamp is missing, that dimension +!is not used as the independent variable for the gap in y. For different gaps in y, the dimensions used +!in x may be different. + integer nx,nobs,nmax + double precision xsamp(1:nobs,1:nx),ysamp(1:nobs) +!Locals + integer i,j,k,n,idowhat,nh,nxfit,nobsfit,ixuse(nx), + &iposdif,itakethis,iposfit(nobs),iuseit + parameter(nh=5) + double precision w(1:nx,1:nh),bph(nh),q(nh),bend, + &xnew(nx),calvalue(nobs),fn9999,tiny,xfit(nobs,nx), + &yfit(nobs),rsq,x1pre(nmax),ysamppred(nobs) + parameter(fn9999=-9999.0d0,tiny=1.0d-6) +! + do i=1,nmax + x1pre(i)=fn9999 + enddo + bend=fn9999 + do i=1,nobs + ysamppred(i)=ysamp(i) + if(dabs(ysamp(i)-fn9999).gt.tiny)goto 1000 +!a gap + nxfit=0 + do j=1,nx + if(dabs(xsamp(i,j)-fn9999).lt.tiny)then +!this x dimension is not used + ixuse(j)=0 + else +!this x dimension is used + nxfit=nxfit+1 + xnew(nxfit)=xsamp(i,j) + ixuse(j)=1 + endif + enddo + if(nxfit.eq.0)goto 1000 +!Fill this gap by choosing the nmax valid points that are closest to i for the fitting + nobsfit=0 +10 iposdif=10000000 + do n=1,nobs + if(n.ne.i.and.dabs(ysamp(n)-fn9999).gt.tiny)then + iuseit=1 +!make sure it is not one that has been already selected + do k=1,nobsfit + if(n.eq.iposfit(k))iuseit=0 + enddo + if(iuseit.eq.1)then +!make sure it has the x dimensions needed + do j=1,nx + if(ixuse(j).eq.1)then + if(dabs(xsamp(n,j)-fn9999).lt.tiny)iuseit=0 + endif + enddo + endif + if(iuseit.eq.1)then +!make sure the distance is smaller than the current miminum + if(iabs(n-i).lt.iposdif)then + iposdif=iabs(n-i) + itakethis=n + endif + endif + endif + enddo + nobsfit=nobsfit+1 + iposfit(nobsfit)=itakethis + yfit(nobsfit)=ysamp(itakethis) + n=0 + do j=1,nx + if(ixuse(j).eq.1)then + n=n+1 + xfit(nobsfit,n)=xsamp(itakethis,j) + endif + enddo + if(nobsfit.lt.nmax)goto 10 +!We test to see if the same set has been used in the +!fitting before. + do n=1,nobsfit + if(dabs(xfit(n,1)-x1pre(n)).gt.tiny)goto 20 + enddo +!this set has been fit in the previous step + goto 30 +20 idowhat=1 + call NeuralNetRegres(idowhat,nxfit,nobsfit,nh, + &xfit(1:nobsfit,1:nxfit),yfit,calvalue,rsq, + &w(1:nxfit,1:nh),bph,q,bend,xnew,ysamppred(i:i)) + do n=1,nobsfit + x1pre(n)=xfit(n,1) + enddo +30 idowhat=2 + call NeuralNetRegres(idowhat,nxfit,1,nh, + &xfit(1:1,1:nxfit),yfit,calvalue,rsq, + &w(1:nxfit,1:nh),bph,q,bend,xnew,ysamppred(i:i)) +1000 continue + enddo + do i=1,nobs + ysamp(i)=ysamppred(i) + enddo +300 format(10f16.8) + return + end subroutine gapfilling diff --git a/dataassim/math/othersupmath/gasdev.f b/dataassim/math/othersupmath/gasdev.f new file mode 100644 index 0000000..bb24f3c --- /dev/null +++ b/dataassim/math/othersupmath/gasdev.f @@ -0,0 +1,109 @@ +! program main +! implicit none +! double precision gasdev2,x(2000),std1,fmean1, +! & std2,fmean2,gasdev +! integer idum,i,n +! idum=-1 +! do i=5,2000 +! do n=1,i +! x(n)=gasdev2() +! enddo +! call stdmean(i,x,std1,fmean1) +! do n=1,i +! x(n)=gasdev(idum) +! enddo +! call stdmean(i,x,std2,fmean2) +! write(2,310)i,std1,fmean1,std2,fmean2 +! enddo +!310 format(1x,i8,4f15.10) +! end +! + double precision function gasdev2() + implicit none +! +! Return a normally distributed deviate with zero mean and unit variance, +! + integer iset + double precision fac,gset,rsq,v1,v2,ran2 + save iset,gset + data iset/0/ + + if(iset.eq.0)then +1 v1=2.0d0*ran2()-1.0d0 + v2=2.0d0*ran2()-1.0d0 + rsq=v1*v1+v2*v2 + if(rsq.ge.1.0d0.or.rsq.eq.0.0d0)goto 1 + fac=dsqrt(-2.0d0*dlog(rsq)/rsq) + gset=v1*fac + gasdev2=v2*fac + iset=1 + else + gasdev2=gset + iset=0 + endif + return + end + + double precision function gasdev(idum) + implicit none + integer idum +! +! Return a normally distributed deviate with zero mean and unit variance, +! using ran1(idum) as the source of uniform deviates + integer iset + double precision fac,gset,rsq,v1,v2,ran1 + save iset,gset + data iset/0/ + if(idum.lt.0)iset=0 + if(iset.eq.0)then +1 v1=2.0d0*ran1(idum)-1.0d0 + v2=2.0d0*ran1(idum)-1.0d0 + rsq=v1*v1+v2*v2 + if(rsq.ge.1.0d0.or.rsq.eq.0.0d0)goto 1 + fac=dsqrt(-2.0d0*dlog(rsq)/rsq) + gset=v1*fac + gasdev=v2*fac + iset=1 + else + gasdev=gset + iset=0 + endif + return + end + + double precision function ran1(idum) + implicit none + integer idum,IA,IM,IQ,IR,NTAB,NDIV + double precision AM,EPS,RNMX + PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773, + & IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15, + & RNMX=1.0d0-EPS) +! +! Minimal random number generator of Park and Miller with Bays-Durham shuffle and +! added safegaurds. Return a uniform random deviate between 0.0 and 1.0, exclusive +! of the endpoint values. Call with idum a negative integer to initilize; +! thereafter, do not alter idum between successive deviates in a sequence. RNMX +! should approximate the largest floating value that is less than 1. +! + integer j,k,iv(NTAB),iy + save iv,iy + data iv /NTAB*0/,iy /0/ + if(idum.le.0.or.iy.eq.0)then + idum=max(-idum,1) + do j=NTAB+8,1,-1 + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if(idum.lt.0)idum=idum+IM + if(j.le.NTAB)iv(j)=idum + enddo + iy=iv(1) + endif + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if(idum.lt.0)idum=idum+IM + j=1+iy/NDIV + iy=iv(j) + iv(j)=idum + ran1=dmin1(AM*iy,RNMX) + return + end \ No newline at end of file diff --git a/dataassim/math/othersupmath/gridsampling.f b/dataassim/math/othersupmath/gridsampling.f new file mode 100644 index 0000000..365b4ce --- /dev/null +++ b/dataassim/math/othersupmath/gridsampling.f @@ -0,0 +1,128 @@ + subroutine gridsampling(sampfunc,ihowsamp,nparams, + & msect0,bestguess,yatguess,guessconfid0,bmax,bmin) + implicit none +! + integer nparams,msect0,ihowsamp + double precision bestguess(nparams),guessconfid0, + & bmax(nparams),bmin(nparams),params(nparams,msect0+1), + & guessconfid,yatguess,beta(nparams),fatbeta + integer i,nright,nleft,j,k,n,msect,m + double precision accum,x1,delta,eps + + logical resetran2 + common /ran2reset/resetran2 + + parameter(eps=1.0d-9) + external sampfunc +! + resetran2=.true. +! + msect=msect0 +! call sampfunc(nparams,bestguess,yatguess) +!assume calculation already done for initial guess + guessconfid=dmax1(1.0d0,guessconfid0) + j=0 + do i=1,nparams + if(bestguess(i).lt.bmin(i).or.bestguess(i).gt. + & bmax(i))then + j=1 + if(bestguess(i).lt.bmin(i))then + bestguess(i)=bmin(i) + else + bestguess(i)=bmax(i) + endif + endif + enddo + if(j.eq.1)call sampfunc(nparams,bestguess,yatguess) + do i=1,nparams + if(dabs(bmax(i)-bestguess(i)).lt.eps)then + nright=0 + nleft=msect+1 + else + if(dabs(bestguess(i)-bmin(i)).lt.eps)then + nright=msect+1 + nleft=0 + else + if(mod(msect,2).eq.0)then + nright=msect/2+1 + nleft=msect/2+1 + else + nright=msect/2+1+1 + nleft=msect/2+1 + endif + endif + endif +!first divide the right + if(nright.gt.0)then + x1=2.0d0*(bmax(i)-bestguess(i))/ + & (dble(nright)*(guessconfid+1.0d0)) + delta=x1*(guessconfid-1.0d0)/dble(nright-1) + accum=0.0d0 + do j=1,nright-1 + accum=accum+x1+dble(j-1)*delta + params(i,j)=accum+bestguess(i) + enddo + endif +!then divide the left + if(nleft.gt.0)then + x1=2.0d0*(bestguess(i)-bmin(i))/ + & (dble(nleft)*(guessconfid+1.0d0)) + delta=x1*(guessconfid-1.0d0)/dble(nleft-1) + accum=0.0d0 + do j=1,nleft-1 + accum=accum+x1+dble(j-1)*delta + if(nright.eq.0)then + params(i,j)=bestguess(i)-accum + else + params(i,j+nright-1)=bestguess(i)-accum + endif + enddo + endif + enddo + do i=1,nparams + params(i,msect+1)=bestguess(i) + enddo + msect=msect+1 + if(ihowsamp.eq.1)then +!Using random permutation + call randpermut_dim_samp(msect,nparams, + & params(1:nparams,1:msect)) + do i=1,msect + call sampfunc(nparams,params(1:nparams,i:i),fatbeta) + if(fatbeta.lt.yatguess)then + yatguess=fatbeta + do j=1,nparams + bestguess(j)=params(j,i) + enddo + endif + enddo + endif + if(ihowsamp.eq.2)then +!uniform grid sampling + do i=1,msect**nparams + do j=1,nparams +!the size of the larger repeated unit is msect**(nparams-j+1) + k=i/(msect**(nparams-j+1)) + n=mod(i,(msect**(nparams-j+1))) + if(n.eq.0)k=k-1 +!k is the number of repeated units before i (not include the unit i is in) + k=i-k*(msect**(nparams-j+1)) +!now k is the position in the larger repeated unit +! +!the size of the smaller repeated unit is (msect**(nparams-j+1))/msect + m=(msect**(nparams-j+1))/msect + n=k/m + if(mod(k,m).ne.0)n=n+1 + beta(j)=params(j,n) + enddo + call sampfunc(nparams,beta,fatbeta) + if(fatbeta.lt.yatguess)then + yatguess=fatbeta + do j=1,nparams + bestguess(j)=beta(j) + enddo + endif + enddo + endif + return + end subroutine gridsampling diff --git a/dataassim/math/othersupmath/gridscreator.f b/dataassim/math/othersupmath/gridscreator.f new file mode 100644 index 0000000..addb8a7 --- /dev/null +++ b/dataassim/math/othersupmath/gridscreator.f @@ -0,0 +1,26 @@ +!creating uniform grids + program test + implicit none + integer i,j,k,msect,nparams,ip(10),n,m + msect=4 + nparams=3 + do i=1,msect**nparams + do j=1,nparams +!the size of the larger repeated unit is msect**(nparams-j+1) + k=i/(msect**(nparams-j+1)) + n=mod(i,(msect**(nparams-j+1))) + if(n.eq.0)k=k-1 +!k is the number of repeated units before i (not include the unit i is in) + k=i-k*(msect**(nparams-j+1)) +!now k is the position in the larger repeated unit +! +!the size of the smaller repeated unit is (msect**(nparams-j+1))/msect + m=(msect**(nparams-j+1))/msect + n=k/m + if(mod(k,m).ne.0)n=n+1 + ip(j)=n + enddo + write(1,210)(ip(j),j=1,nparams) + enddo +210 format(1x,10i3) + end diff --git a/dataassim/math/othersupmath/grouping.f b/dataassim/math/othersupmath/grouping.f new file mode 100644 index 0000000..1ee217a --- /dev/null +++ b/dataassim/math/othersupmath/grouping.f @@ -0,0 +1,74 @@ +! optimally group a gappy order time series into different sections with an average +! length + subroutine grouping(numpoints,time,windowsize,minnum, + ×tart,timeend,nsections,nrange,confirmvar,rangemin) + implicit none + integer numpoints,nsections,minnum,n,i,ipass,j,nrange + double precision time(numpoints),timestart(numpoints), + & timeend(numpoints),gap,windowsize,diff,fmin(nrange), + & fmax(nrange),confirmvar(nrange,numpoints),rangemin(nrange) + +! the first mark is always time(1)-1.0d-9*time(1). time must be ordered from +! low to high +! rangemin is the minimum range of a variable in a section + + nsections=1 + n=0 + timestart(nsections)=time(1)-1.0d-9*time(1) + do j=1,nrange + fmin(j)=confirmvar(j,1) + fmax(j)=confirmvar(j,1) + enddo + do i=2,numpoints + gap=time(i)-time(i-1) + if(gap.ge.windowsize.and.nsections.gt.1)then +! there is a large gap. Put all members in the current section into the previous +! section and start the current section from time(i) + timeend(nsections-1)=time(i-1) + timestart(nsections)=time(i) + n=0 + do j=1,nrange + fmin(j)=confirmvar(j,i) + fmax(j)=confirmvar(j,i) + enddo + else + diff=time(i)-timestart(nsections) + do j=1,nrange + if(fmin(j).gt.confirmvar(j,i))then + fmin(j)=confirmvar(j,i) + endif + if(fmax(j).lt.confirmvar(j,i))then + fmax(j)=confirmvar(j,i) + endif + enddo + ipass=1 + if(diff.lt.windowsize)then + ipass=0 + endif + do j=1,nrange + if((fmax(j)-fmin(j)).lt.rangemin(j))then + ipass=0 + endif + enddo + if(ipass.eq.0)then + n=n+1 + else + if(n.ge.minnum)then + timeend(nsections)=time(i) + nsections=nsections+1 + timestart(nsections)=time(i) + n=0 + do j=1,nrange + fmin(j)=confirmvar(j,i) + fmax(j)=confirmvar(j,i) + enddo + else + n=n+1 + endif + endif + endif + enddo + nsections=nsections-1 + timeend(nsections)=time(numpoints) + return + end diff --git a/dataassim/math/othersupmath/histogram.f b/dataassim/math/othersupmath/histogram.f new file mode 100644 index 0000000..c421389 --- /dev/null +++ b/dataassim/math/othersupmath/histogram.f @@ -0,0 +1,83 @@ + subroutine histogram(npoints,datalabel,datavalue,ngroup, + &grouplabel,nhistmark,histmark,nfreq,ncumumark,cumumark, + &ncumu) + implicit none +!npoints: the total number of points of the whole series +!datalabel: the lable of each datum +!datavalue: the value of each datum +!ngroup: the number of different data labeles, each label represents a group +!grouplabel: the label of each group +!nhistmark: the number of histogram band marks in each group +!histmark: the value of each histogram mark +!nfreq: the number of points in each histogram bands +!ncumumark: the number of marks for cumulative distribution +!cumumark: the marks for the cumulative distribution +!ncumu: the cumulative distribution in each group + integer npoints,ngroup,nfreq(ngroup,npoints),nhistmark(ngroup), + &ncumumark(ngroup),ncumu(ngroup,npoints),iorder(npoints),i,j,n + character*50 datalabel(npoints),grouplabel(ngroup) + double precision datavalue(npoints),histmark(ngroup,npoints), + &cumumark(ngroup,npoints),vector(npoints) + do i=1,ngroup + do j=1,npoints + nfreq(i,j)=0 + ncumu(i,j)=0 + enddo + ncumumark(i)=0 + enddo + do k=1,npoints + do i=1,ngroup + if(trim(datalabel(k)).eq.trim(grouplabel(i))then +!initially we set the ncumumark to the total number of points in each group. Later we will +!merge points with the same value + ncumumark(i)=ncumumark(i)+1 + cumumark(i,ncumumark(i))=datavalue(k) + goto 10 + endif + enddo +10 continue + enddo + do i=1,ngroup + call sort_shell(ncumumark(i),cumumark(i:i,1:ncumumark(i)), + &iorder) + do k=1,ncumumark(i) + do j=1,nhistmark(i)-1 + if(j.eq.(nhistmark(i)-1))then + if(cumumark(i,k).ge.histmark(i,j).and.cumumark(i,k).le. + &histmark(i,j+1))then + nfreq(i,j)=nfreq(i,j)+1 + goto 20 + else + if(cumumark(i,k).ge.histmark(i,j).and.cumumark(i,k).lt. + &histmark(i,j+1))then + nfreq(i,j)=nfreq(i,j)+1 + goto 20 + endif + endif + enddo +20 continue + enddo +!cumulative distribution. we have to merge points with equal values + do j=1,ncumumark(i) + vector(j)=cumumark(i,j) + enddo + k=ncumumark(i) + ncumumark(i)=1 + cumumark(i,1)=vector(1) + do j=2,k + if(vector(j).ne.cumumark(i,ncumumark(i)))then + ncumumark(i)=ncumumark(i)+1 + cumumark(i,ncumumark(i))=vector(j) + endif + enddo + do j=1,ncumumark(i) + ncumu(i,j)=0 + do n=1,k + if(ivector(n).le.cumumark(i,j))then + ncumu(i,j)=ncumu(i,j)+1 + endif + enddo + enddo + enddo + return + end diff --git a/dataassim/math/othersupmath/isitaleapyear.f b/dataassim/math/othersupmath/isitaleapyear.f new file mode 100644 index 0000000..556c493 --- /dev/null +++ b/dataassim/math/othersupmath/isitaleapyear.f @@ -0,0 +1,17 @@ +!determine if year is a leap year + integer function isitaleapyear(year) +!isitaleapyear =0, not a leap year (365 days) +! =1, leap year (366 days) + implicit none + integer year + isitaleapyear=0 + if((mod(year,4).eq.0).and.(mod(year,100).gt.0)) + &isitaleapyear=1 + if((mod(year,4).eq.0).and.(mod(year,100).eq.0))then + if(mod(year,400).eq.0)isitaleapyear=1 + endif + return + end + + + diff --git a/dataassim/math/othersupmath/ispartnum.f b/dataassim/math/othersupmath/ispartnum.f new file mode 100644 index 0000000..a38b8a8 --- /dev/null +++ b/dataassim/math/othersupmath/ispartnum.f @@ -0,0 +1,19 @@ + integer function ispartnum(c) + implicit none +!ispartnum = 1, c is one of the following: 0 to 9, +, -, ., d, D, E, e, N, n, a, and A. +! = 0, otherwise + character c*1 + integer i +! + ispartnum=0 + i=ichar(c) + if(i.ge.48.and.i.le.57)ispartnum=1 + if(i.eq.43.or.i.eq.45.or.i.eq.46.or.i.eq.68.or. + &i.eq.69.or.i.eq.100.or.i.eq.101)ispartnum=1 + if(c.eq.'.'.or.c.eq.'+'.or.c.eq.'-')ispartnum=1 + if(c.eq.'d'.or.c.eq.'D'.or.c.eq.'e'.or.c.eq.'E') + &ispartnum=1 + if(c.eq.'n'.or.c.eq.'N'.or.c.eq.'a'.or.c.eq.'A') + &ispartnum=1 + return + end diff --git a/dataassim/math/othersupmath/jbtest.f b/dataassim/math/othersupmath/jbtest.f new file mode 100644 index 0000000..d1d326d --- /dev/null +++ b/dataassim/math/othersupmath/jbtest.f @@ -0,0 +1,288 @@ +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine jbtest(nsamp,x,alpha,h,p,jbstat,cv,hb) + implicit none + + double precision fn9999 + parameter(fn9999=-9999.0d0) + integer nsiglev + parameter(nsiglev=17) + + integer nsamp,h,hb +!h=1, reject the hypothesis of normal distribution +!h=0, fail to reject the nul hypothesis + + integer i,k + integer iorder(nsiglev) + + double precision x(nsamp),alpha,p,jbstat,cv, + &zscores(nsamp),skew,kurt,fstd,fmean,fmin,fmax + + double precision cvs(nsiglev),alphas(nsiglev),tmpy2(nsiglev), + &alphasort(nsiglev) + + data alphas/0.001, 0.0016681,0.0027826,0.0046416,0.0077426, + & 0.01, 0.012915, 0.021544, 0.025, 0.035938, + & 0.05, 0.059948, 0.1, 0.15, 0.2, + & 0.25, 0.50/ + + if (nsamp .lt. 2) then + write(*,*) 'stats:jbtest:NotEnoughData, + &Sample vector X must have at + &least 2 valid observations.' + h = fn9999 + p = fn9999 + jbstat = fn9999 + cv = fn9999 + hb=fn9999 + + elseif (nsamp .eq. 2) then + write(*,*) 'The J-B stat is a constant + &when the sample size is 2' + h = 0 + p = 1.0 + jbstat = 1.0/3.0 + cv = fn9999 + hb = 1 + else + + skew = 0.0 + kurt = 0.0 + + call stdmaxmeanmin(nsamp,x,fstd,fmean,fmin,fmax) + + ! readjust sample size from (n-1) to n according to matlab + + fstd = dsqrt(fstd*fstd*dble(nsamp-1)/dble(nsamp)) + do i=1,nsamp + zscores(i) = (x(i)-fmean)/fstd + enddo + + do i=1,nsamp + skew = skew + zscores(i)*zscores(i)*zscores(i) + kurt = kurt + zscores(i)*zscores(i)*zscores(i)*zscores(i) + enddo + + skew = skew/dble(nsamp) + kurt = kurt/dble(nsamp) - 3 + jbstat = nsamp*(skew*skew/6 + kurt*kurt/24) + + +! Get a row of the critical value table for the current sample size + call cvtbl(nsamp,cvs) + +! 1-D interpolation into the tabulated quantiles. + call SPLINE(alphas,cvs,nsiglev,1.0d+31,1.0d+31,tmpy2) + call SPLINT(alphas,cvs,tmpy2,nsiglev,alpha,cv) + +! Compute the P-value. Warn if the P-value is not found within the +! available 'alphas' of the table and return one of the extremes. + + if (jbstat < cvs(nsiglev)) then ! smallest critval at end + write(*,*) 'P is greater than the largest tabulated value' + p = alphas(nsiglev) + hb=1 + elseif (cvs(1) < jbstat) then ! largest critval at beginning + write(*,*) 'P is less than the smallest tabulated value' + p = alphas(1) + hb=1 + else + + call sort_shell(nsiglev,cvs,iorder) + do k=1,nsiglev + alphasort(k) = alphas(iorder(k)) + enddo + call SPLINE(cvs,alphasort,nsiglev,1.0d+31,1.0d+31,tmpy2) + call SPLINT(cvs,alphasort,tmpy2,nsiglev,jbstat,p) + + hb=0 + if(jbstat .gt. cv) then + h=1 + else + h=0 + endif + + endif + endif + + return + end + +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine cvtbl(n,cvs) + implicit none + + integer n,nsiglev,nsamples,i,j,k + parameter(nsiglev=17,nsamples=32) + integer sampleSizes(nsamples) !Sample sizes + double precision criticalValues(nsamples,nsiglev) !Critical value + double precision cvs(nsiglev) + + double precision x(nsamples),y(nsamples),y2(nsamples), + & ysort(nsamples),tmp(nsamples) + integer iorder(nsamples) + + data sampleSizes/3, 4, 5, 10, 15, 20, 25, 30, 35, + & 40, 45, 50, 60, 70, 80, 90, 100, 125, + & 150, 175, 200, 250, 300, 400, 500, 800, 1000, + & 1200,1400,1600,1800,2000/ + + data criticalValues/ 0.5312, 0.9606, 1.8289,10.9719, + & 19.5425,25.0722,28.4885,30.6106, + & 31.9343,32.7514,33.2273,33.4825, + & 33.5009,33.2610,32.8742,32.3418, + & 31.8884,30.6089,29.4290,28.4225, + & 27.5140,26.0239,24.8353,23.0771, + & 21.8170,19.5539,18.6707,18.0126, + & 17.5190,17.1305,16.8158,16.5585, + & 0.5312, 0.9590, 1.8053, 9.8430, + & 16.7207,21.0001,23.6332,25.2501, + & 26.2695,26.9025,27.2686,27.4765, + & 27.5458,27.3738,27.0975,26.7278, + & 26.3990,25.4748,24.6043,23.8582, + & 23.1914,22.0764,21.1758,19.8542, + & 18.9068,17.1748,16.4879,15.9830, + & 15.6036,15.3029,15.0600,14.8633, + & 0.5312, 0.9564, 1.7727, 8.6751, + & 14.0454,17.2981,19.2818,20.5242, + & 21.3105,21.8016,22.1030,22.2863, + & 22.3790,22.2848,22.1135,21.8770, + & 21.6407,21.0100,20.3979,19.8658, + & 19.3922,18.5877,17.9384,16.9669, + & 16.2666,14.9865,14.4745,14.0990, + & 13.8149,13.5883,13.4102,13.2657, + & 0.5312, 0.9520, 1.7276, 7.4815, + & 11.5527,13.9762,15.4635,16.4088, + & 17.0176,17.4145,17.6594,17.8172, + & 17.9431,17.9209,17.8305,17.6977, + & 17.5510,17.1460,16.7425,16.3846, + & 16.0635,15.5123,15.0633,14.3843, + & 13.8903,12.9765,12.6143,12.3493, + & 12.1501,11.9883,11.8682,11.7666, + & 0.5312, 0.9448, 1.6661, 6.2927, + & 9.2814,11.0602,12.1658,12.8805, + & 13.3572,13.6749,13.8848,14.0345, + & 14.1788,14.2092,14.1911,14.1283, + & 14.0491,13.8271,13.5878,13.3664, + & 13.1643,12.8124,12.5206,12.0743, + & 11.7469,11.1441,10.9072,10.7362, + & 10.6072,10.5059,10.4296,10.3636, + & 0.5312, 0.9396, 1.6275, 5.7077, + & 8.2365, 9.7531,10.7058,11.3263, + & 11.7488,12.0355,12.2302,12.3739, + & 12.5255,12.5801,12.5841,12.5542, + & 12.5067,12.3565,12.1804,12.0139, + & 11.8602,11.5923,11.3653,11.0157, + & 10.7604,10.2914,10.1106, 9.9803, + & 9.8811, 9.8072, 9.7478, 9.6981, + & 0.5311, 0.9329, 1.5828, 5.1350, + & 7.2613, 8.5489, 9.3658, 9.9063, + & 10.2818,10.5399,10.7201,10.8586, + & 11.0182,11.0884,11.1155,11.1112, + & 11.0882,10.9976,10.8779,10.7589, + & 10.6494,10.4542,10.2839,10.0226, + & 9.8318, 9.4852, 9.3521, 9.2587, + & 9.1869, 9.1333, 9.0911, 9.0549, + & 0.5310, 0.9133, 1.4723, 4.0456, + & 5.5238, 6.4401, 7.0389, 7.4472, + & 7.7395, 7.9520, 8.1098, 8.2340, + & 8.3968, 8.4921, 8.5520, 8.5850, + & 8.6004, 8.6020, 8.5719, 8.5307, + & 8.4904, 8.4114, 8.3384, 8.2266, + & 8.1454, 8.0027, 7.9501, 7.9127, + & 7.8828, 7.8611, 7.8446, 7.8296, + & 0.5309,0.9056,1.4343,3.7474, + & 5.0729,5.8998,6.4463,6.8222, + & 7.0942,7.2949,7.4469,7.5661, + & 7.7287,7.8286,7.8938,7.9361, + & 7.9589,7.9816,7.9718,7.9496, + & 7.9259,7.8751,7.8276,7.7526, + & 7.6984,7.6040,7.5691,7.5441, + & 7.5239,7.5089,7.4979,7.4872, + & 0.5305,0.8817,1.3294,3.0691, + & 4.0773,4.7176,5.1501,5.4578, + & 5.6856,5.8598,5.9945,6.1045, + & 6.2620,6.3696,6.4462,6.5028, + & 6.5429,6.6071,6.6387,6.6571, + & 6.6688,6.6803,6.6842,6.6877, + & 6.6882,6.6858,6.6847,6.6832, + & 6.6800,6.6789,6.6777,6.6763, + & 0.5297,0.8519,1.2185,2.5239, + & 3.2985,3.8011,4.1494,4.4039, + & 4.5973,4.7481,4.8689,4.9697, + & 5.1203,5.2305,5.3134,5.3796, + & 5.4314,5.5277,5.5919,5.6408, + & 5.6783,5.7343,5.7728,5.8248, + & 5.8581,5.9096,5.9282,5.9408, + & 5.9482,5.9546,5.9600,5.9635, + & 0.5290,0.8316,1.1516,2.2555, + & 2.9215,3.3596,3.6684,3.8968, + & 4.0734,4.2126,4.3258,4.4214, + & 4.5688,4.6803,4.7662,4.8378, + & 4.8957,5.0071,5.0863,5.1474, + & 5.1957,5.2681,5.3194,5.3889, + & 5.4336,5.5043,5.5296,5.5471, + & 5.5587,5.5677,5.5755,5.5806, + & 0.5251,0.7553,0.9442,1.6231, + & 2.0533,2.3505,2.5707,2.7431, + & 2.8827,2.9987,3.0973,3.1834, + & 3.3246,3.4374,3.5292,3.6071, + & 3.6730,3.8025,3.8987,3.9732, + & 4.0327,4.1224,4.1873,4.2748, + & 4.3320,4.4246,4.4580,4.4814, + & 4.4979,4.5105,4.5214,4.5289, + & 0.5176,0.6721,0.7945,1.2821, + & 1.5965,1.8239,1.9986,2.1390, + & 2.2547,2.3524,2.4361,2.5097, + & 2.6316,2.7298,2.8104,2.8788, + & 2.9372,3.0523,3.1384,3.2050, + & 3.2584,3.3402,3.3988,3.4790, + & 3.5318,3.6180,3.6500,3.6718, + & 3.6876,3.6997,3.7101,3.7173, + & 0.5074,0.6303,0.7302,1.1235, + & 1.3779,1.5631,1.7063,1.8216, + & 1.9172,1.9980,2.0674,2.1283, + & 2.2297,2.3115,2.3789,2.4361, + & 2.4851,2.5819,2.6543,2.7106, + & 2.7559,2.8250,2.8749,2.9434, + & 2.9886,3.0631,3.0907,3.1099, + & 3.1237,3.1345,3.1433,3.1499, + & 0.4946,0.5947,0.6878,1.0198, + & 1.2336,1.3885,1.5079,1.6040, + & 1.6835,1.7508,1.8085,1.8592, + & 1.9434,2.0114,2.0674,2.1151, + & 2.1557,2.2363,2.2964,2.3436, + & 2.3812,2.4388,2.4808,2.5382, + & 2.5760,2.6388,2.6624,2.6787, + & 2.6904,2.6996,2.7072,2.7129, + & 0.4063,0.4739,0.5285,0.6951, + & 0.7916,0.8577,0.9071,0.9457, + & 0.9771,1.0033,1.0256,1.0449, + & 1.0768,1.1023,1.1231,1.1408, + & 1.1557,1.1852,1.2072,1.2243, + & 1.2382,1.2591,1.2744,1.2956, + & 1.3097,1.3334,1.3421,1.3484, + & 1.3530,1.3564,1.3595,1.3619/ + + +! Interpolate a row of critical values for the given sample size. + do i=1,nsiglev + do j=1,nsamples + x(j) = 1.0/dble(sampleSizes(j)) + y(j) = criticalValues(j,i) + enddo + + call sort_shell(nsamples,x,iorder) + do k=1,nsamples + ysort(k) = y(iorder(k)) + enddo + + call SPLINE(x,ysort,nsamples,1.0d+31,1.0d+31,y2) + call SPLINT(x,ysort,y2,nsamples,1.0/dble(n),cvs(i)) + + enddo + + return + end + + + diff --git a/dataassim/math/othersupmath/linecrossing.f b/dataassim/math/othersupmath/linecrossing.f new file mode 100644 index 0000000..9a1cd7b --- /dev/null +++ b/dataassim/math/othersupmath/linecrossing.f @@ -0,0 +1,71 @@ + subroutine linecrossing(nlines,nsamp,maxnsamp,xdata,ydata, + ¶ms,xcross,ycross) + implicit none +!fit nlines lines from nlines pairs of datasets and estimate the mean crossings of the lines + integer nlines,nsamp(nlines),maxnsamp,i,j,k,n,m + double precision xdata(nlines,maxnsamp),ydata(nlines,maxnsamp), + &xcross,ycross,x(maxnsamp),y(maxnsamp),intercepts(nlines), + &slopes(nlines),params(nlines,2) + + k=0 + do i=1,nlines + n=0 + do j=1,nsamp(i) + if(dabs(xdata(i,j)+9999.0d0).gt.1.0d-8.and. + &dabs(ydata(i,j)+9999.0d0).gt.1.0d-8)then + n=n+1 + x(n)=xdata(i,j) + y(n)=ydata(i,j) + endif + enddo + if(n.gt.1)then + k=k+1 + call y_aPLUSbx(n,x,y,intercepts(k),slopes(k)) + params(i,1)=slopes(k) + params(i,2)=intercepts(k) + endif + enddo + if(k.gt.0)then + call meancrossing(k,slopes,intercepts,xcross,ycross) + else + xcross=-9999.0d0 + ycross=-9999.0d0 + endif + return + end + + subroutine meancrossing(nlines,slopes,intercepts,xcross,ycross) + implicit none +!calculate the average crossing point of the nlines lines. Parrell lines are excluded + integer nlines,i,j,k + double precision slopes(nlines),intercepts(nlines),xcross,ycross, + &x(nlines),y(nlines),a1,b1,a2,b2 + k=0 + do i=1,nlines-1 + do j=i+1,nlines + a1=slopes(i) + b1=intercepts(i) + a2=slopes(j) + b2=intercepts(j) + if(dabs(a1-a2).gt.1.0d-8)then + k=k+1 + x(k)=(b2-b1)/(a1-a2) + y(k)=a1*x(k)+b1 + endif + enddo + enddo + if(k.gt.0)then + xcross=0.0d0 + ycross=0.0d0 + do i=1,k + xcross=xcross+x(i) + ycross=ycross+y(i) + enddo + xcross=xcross/dble(k) + ycross=ycross/dble(k) + else + xcross=-9999.0d0 + ycross=-9999.0d0 + endif + return + end diff --git a/dataassim/math/othersupmath/linregres.f b/dataassim/math/othersupmath/linregres.f new file mode 100644 index 0000000..cfc5ff7 --- /dev/null +++ b/dataassim/math/othersupmath/linregres.f @@ -0,0 +1,54 @@ + subroutine linregres(npoints0,x0,y0,Sign_Level,a,b, + &r,bradius,isslopezero) + implicit none +!fit for y=a+bx + integer npoints0,isslopezero +!isslopezero=-1, slope differs from zero +!isslopezero=1, slope does not differ from zero + double precision x0(npoints0),y0(npoints0),r,a,b, + &bradius,Sign_Level + integer i,npoints + double precision xmean,ymean,lxx,lyy,lxy,seb,t0, + &tstat,tstatr,student_t,fn9999,tiny,x(npoints0),y(npoints0) + parameter(fn9999=-9999.0d0,tiny=1.0d-7) + + npoints=0 + do i=1,npoints0 + if(dabs(x0(i)-fn9999).gt.tiny.and. + &dabs(y0(i)-fn9999).gt.tiny)then + npoints=npoints+1 + x(npoints)=x0(i) + y(npoints)=y0(i) + endif + enddo + + xmean=0.0d0 + ymean=0.0d0 + do i=1,npoints + xmean=xmean+x(i) + ymean=ymean+y(i) + enddo + xmean=xmean/dble(npoints) + ymean=ymean/dble(npoints) + lxx=0.0d0 + lyy=0.0d0 + lxy=0.0d0 + do i=1,npoints + lxx=lxx+(x(i)-xmean)**2 + lyy=lyy+(y(i)-ymean)**2 + lxy=lxy+(x(i)-xmean)*(y(i)-ymean) + enddo + b=lxy/lxx + a=ymean-b*xmean + r=lxy/dsqrt(lxx*lyy) + seb=dsqrt((lyy-b*lxy)/(lxx*dble(npoints-2))) + t0=student_t(npoints-2,Sign_Level) + bradius=seb*t0 + tstat=dabs(b/seb) + if(tstat.gt.t0)then + isslopezero=-1 + else + isslopezero=1 + endif + return + end diff --git a/dataassim/math/othersupmath/linuncertainty.f b/dataassim/math/othersupmath/linuncertainty.f new file mode 100644 index 0000000..8616145 --- /dev/null +++ b/dataassim/math/othersupmath/linuncertainty.f @@ -0,0 +1,47 @@ + subroutine linuncertainty(nsamp,a1_mean,a1_sigma,b1_mean, + &b1_sigma,y1_mean,y1_sigma,a2_mean,a2_sigma,b2_mean,b2_sigma, + &y2_mean,y2_sigma,x1,x2,x1_mean,x1_sigma,x2_mean,x2_sigma) + implicit none +!given: +!y1=a1*x1+b1*x2 +!y2=a2*x1+b1*x2 +!y1 ~ (y1_mean, y1_sigma) +!y2 ~ (y2_mean, y2_sigma) +!a1 ~ (a1_mean, a1_sigma) +!b1 ~ (b1_mean, b1_sigma) +!a2 ~ (a2_mean, a2_sigma) +!b2 ~ (b2_mean, b2_sigma) +!find: +!x1 ~ (x1_mean, x1_sigma) +!x2 ~ (x2_mean, x2_sigma) + integer nsamp,i + double precision a1_mean,a1_sigma,b1_mean,b1_sigma,y1_mean, + &y1_sigma,a2_mean,a2_sigma,b2_mean,b2_sigma,y2_mean,y2_sigma, + &x1(nsamp),x2(nsamp),x1_mean,x1_sigma,x2_mean,x2_sigma,gasdev2, + &a1,b1,a2,b2,y1,y2 + x1_mean=0.0d0 + x2_mean=0.0d0 + do i=1,nsamp + y1=gasdev2()*y1_sigma+y1_mean + y2=gasdev2()*y2_sigma+y2_mean + a1=gasdev2()*a1_sigma+a1_mean + b1=gasdev2()*b1_sigma+b1_mean + a2=gasdev2()*a2_sigma+a2_mean + b2=gasdev2()*b2_sigma+b2_mean + x1(i)=(b2*y1-b1*y2)/(a1*b2-a2*b1) + x2(i)=(a1*y2-a2*y1)/(a1*b2-a2*b1) + x1_mean=x1_mean+x1(i) + x2_mean=x2_mean+x2(i) + enddo + x1_mean=x1_mean/dble(nsamp) + x2_mean=x2_mean/dble(nsamp) + x1_sigma=0.0d0 + x2_sigma=0.0d0 + do i=1,nsamp + x1_sigma=x1_sigma+(x1(i)-x1_mean)*(x1(i)-x1_mean) + x2_sigma=x2_sigma+(x2(i)-x2_mean)*(x2(i)-x2_mean) + enddo + x1_sigma=x1_sigma/dble(nsamp) + x2_sigma=x2_sigma/dble(nsamp) + return + end diff --git a/dataassim/math/othersupmath/meancyclegapfilling.f b/dataassim/math/othersupmath/meancyclegapfilling.f new file mode 100644 index 0000000..e7ba177 --- /dev/null +++ b/dataassim/math/othersupmath/meancyclegapfilling.f @@ -0,0 +1,59 @@ + subroutine meancyclegapfilling(nsamp,xvar,yvar0,nminno0) + implicit none +!Fill gaps in yvar with the mean cycle approach. xvar must be repeated cycles. + integer nsamp,nminno0,nk,nminno + double precision xvar(nsamp),yvar0(nsamp) + integer i,j,k,m,n + double precision yvector(nsamp),fn9999,tiny,yvar(nsamp) + parameter(fn9999=-9999.0d0,tiny=1.0d-7) +! + do i=1,nsamp + yvar(i)=yvar0(i) + enddo + do i=1,nsamp + nminno=nminno0 + if(dabs(yvar(i)-fn9999).gt.tiny)goto 70 +7 n=0 + k=i-1 + nk=0 +10 if(k.eq.0)goto 30 + if(dabs(xvar(k)-xvar(i)).gt.tiny)goto 20 + nk=nk+1 + if(dabs(yvar0(k)-fn9999).lt.tiny)goto 20 + n=n+1 + yvector(n)=yvar0(k) + if(nk.ge.nminno/2)goto 30 +20 k=k-1 + goto 10 +30 m=i+1 + nk=0 +40 if(m.gt.nsamp)goto 60 + if(dabs(xvar(m)-xvar(i)).gt.tiny)goto 50 + nk=nk+1 + if(dabs(yvar0(m)-fn9999).lt.tiny)goto 50 + n=n+1 + yvector(n)=yvar0(m) + if(nk.ge.nminno/2)goto 60 +50 m=m+1 + goto 40 +60 if(n.lt.nminno0)then + nminno=nminno+1 + goto 7 + endif + yvar(i)=0.0d0 + do m=1,n + yvar(i)=yvar(i)+yvector(m) + enddo + if(n.eq.0)then + yvar(i)=-9.999d+199 + else + yvar(i)=yvar(i)/dble(n) + endif +70 continue + enddo + do i=1,nsamp + yvar0(i)=yvar(i) + enddo + return + end +!#################################################################### diff --git a/dataassim/math/othersupmath/meancyclepattern.f b/dataassim/math/othersupmath/meancyclepattern.f new file mode 100644 index 0000000..8a2a1d1 --- /dev/null +++ b/dataassim/math/othersupmath/meancyclepattern.f @@ -0,0 +1,43 @@ + subroutine meancyclepattern(nsamp,xvar,yvar,ncyc,xcyc,ycyc,ystd) + implicit none +!Calculate mean cycle pattern. xvar must be repeated cycles. + integer nsamp,ncyc + double precision xvar(nsamp),yvar(nsamp),xcyc(nsamp), + &ycyc(nsamp),ystd(nsamp) + integer i,j,k,m,n,iorder(nsamp) + double precision yvector(nsamp),fn9999,tiny + parameter(fn9999=-9999.0d0,tiny=1.0d-7) +! + ncyc=1 + xcyc(ncyc)=xvar(1) + do i=2,nsamp + k=0 + do j=1,ncyc + if(dabs(xcyc(j)-xvar(i)).lt.tiny)k=1 + enddo + if(k.eq.0)then + ncyc=ncyc+1 + xcyc(ncyc)=xvar(i) + endif + enddo + call sort_shell(ncyc,xcyc,iorder) + do j=1,ncyc + k=0 + do i=1,nsamp + if(dabs(xvar(i)-xcyc(j)).lt.tiny)then + if(dabs(yvar(i)-fn9999).gt.tiny)then + k=k+1 + yvector(k)=yvar(i) + endif + endif + enddo + if(k.gt.2)then + call stdmean(k,yvector,ystd(j),ycyc(j)) + else + ycyc(j)=fn9999 + ystd(j)=fn9999 + endif + enddo + return + end +!#################################################################### diff --git a/dataassim/math/othersupmath/outlier.f b/dataassim/math/othersupmath/outlier.f new file mode 100644 index 0000000..5d7c28a --- /dev/null +++ b/dataassim/math/othersupmath/outlier.f @@ -0,0 +1,344 @@ + subroutine meancycleoutliers(nsamp,xvar,yvar,nminno0) + implicit none +!Detect outliers in yvar with the mean cycle approach. Replace the detected +!outliers with -9999. xvar must be repeated cycles + integer nsamp,nminno0 + double precision xvar(nsamp),yvar(nsamp) + integer i,j,k,m,n,noutliers,nk,nminno,ncyc + double precision yvector(nsamp),std_clean, + &fmean_clean(nsamp),fn9999,tiny,term + parameter(fn9999=-9999.0d0,tiny=1.0d-8) +! +!First remove the outliers for a given xvar value within a nminno window +5 noutliers=0 + do i=1,nsamp + nminno=nminno0 + if(dabs(yvar(i)-fn9999).gt.tiny)then +7 n=0 + k=i + nk=-1 +!The current value is the first value in yvector +10 if(nk.ge.nminno/2)goto 30 + if(dabs(xvar(k)-xvar(i)).gt.tiny)goto 20 + nk=nk+1 + if(dabs(yvar(k)-fn9999).lt.tiny)goto 20 + n=n+1 + yvector(n)=yvar(k) +20 k=k-1 + if(k.gt.0)goto 10 +30 nk=0 + m=i+1 +40 if(m.gt.nsamp)goto 60 + if(nk.ge.nminno/2)goto 60 + if(dabs(xvar(m)-xvar(i)).gt.tiny)goto 50 + nk=nk+1 + if(dabs(yvar(m)-fn9999).lt.tiny)goto 50 + n=n+1 + yvector(n)=yvar(m) +50 m=m+1 + goto 40 +60 if(n.lt.nminno0)then + nminno=nminno+1 + goto 7 + endif + call whoareoutliers(n,yvector,std_clean,fmean_clean(i)) + if(dabs(yvector(1)-fn9999).lt.tiny)then + noutliers=noutliers+1 + yvar(i)=fn9999 + else + fmean_clean(i)=yvar(i)-fmean_clean(i) + endif + endif + enddo + if(noutliers.gt.0)goto 5 + goto 190 +! +!Then remove the outliers from the mean cycle out of nminno cycles +105 noutliers=0 + do i=1,nsamp + nminno=nminno0 + if(dabs(yvar(i)-fn9999).gt.tiny)then +107 n=0 + nk=-1 + k=i +!The current value is the first value in yvector +110 if(dabs(xvar(k)-xvar(i)).lt.tiny)nk=nk+1 + if(nk.ge.nminno/2)goto 130 + if(dabs(yvar(k)-fn9999).lt.tiny)goto 120 + n=n+1 + yvector(n)=fmean_clean(k) +120 k=k-1 + if(k.gt.0)goto 110 +130 m=i+1 + ncyc=nk + nk=0 +140 if(m.gt.nsamp)goto 160 + if(dabs(xvar(m)-xvar(i)).lt.tiny)nk=nk+1 + if(nk.ge.nminno/2)goto 160 + if(dabs(yvar(m)-fn9999).lt.tiny)goto 150 + n=n+1 + yvector(n)=fmean_clean(m) +150 m=m+1 + goto 140 +160 if((nk+ncyc).lt.nminno)then + nminno=nminno+1 + goto 107 + endif + call whoareoutliers(n,yvector,std_clean,term) + if(dabs(yvector(1)-fn9999).lt.tiny)then + noutliers=noutliers+1 + yvar(i)=fn9999 + endif + endif + enddo +190 if(noutliers.gt.0)goto 5 + do i=2,nsamp-1 + if((yvar(i)-fn9999).gt.tiny)then + if((yvar(i-1)-fn9999).lt.tiny.and. + &(yvar(i+1)-fn9999).lt.tiny)yvar(i)=fn9999 + endif + enddo + return + end +!#################################################################### + subroutine whoareoutliers(nsamp0,xvar0,std_clean,fmean_clean) + implicit none +!Detect outliers. On exit, outliers are given as -9999 + integer nsamp,i,j,nsamp0,isoutlier_2sides,ivect(nsamp0) + double precision xvar(nsamp0),std_clean,fmean_clean, + & xvar0(nsamp0),gap + parameter(gap=-9999.0d0) + +10 nsamp=0 + do j=1,nsamp0 + if(dabs(xvar0(j)-gap).gt.1.0d-5)then + nsamp=nsamp+1 + xvar(nsamp)=xvar0(j) + ivect(nsamp)=j + endif + enddo + if(nsamp.lt.2)then + std_clean=gap + fmean_clean=gap + return + endif + i=isoutlier_2sides(nsamp,xvar) + if(i.lt.0)goto 100 + xvar0(ivect(i))=gap + goto 10 + +100 fmean_clean=0.0d0 + do j=1,nsamp + fmean_clean=fmean_clean+xvar(j) + enddo + fmean_clean=fmean_clean/dble(nsamp) + std_clean=0.0d0 + do j=1,nsamp + std_clean=std_clean+(xvar(j)-fmean_clean)*(xvar(j)-fmean_clean) + enddo + std_clean=dsqrt(std_clean/dble(nsamp-1)) + return + end + +!#################################################################### +! detecting outliers using Grubb's + integer function isoutlier_2sides(nsamp,yobs) + implicit none +! Detecting the outlier using the Grubb's test for two tails. If there is an outlier, +! isoutlier is the index number of the outlier in the sequence yobs. If there +! is no outlier, isoutlier is returned with -9999 + integer nsamp + double precision yobs(nsamp) + + integer i,imax + double precision zc,std,fmean,dev,devmax, + & alpha,grubbzc_2sides + parameter(alpha=0.05d0) + + isoutlier_2sides=-9999 + if(nsamp.le.2)then + return + endif + call stdmean(nsamp,yobs,std,fmean) + if(std.le.0.0d0)return + devmax=dabs(yobs(1)-fmean)/std + imax=1 + do i=2,nsamp + dev=dabs(yobs(i)-fmean)/std + if(dev.gt.devmax)then + imax=i + devmax=dev + endif + enddo + zc=grubbzc_2sides(nsamp,alpha) + if(devmax.ge.zc)then + isoutlier_2sides=imax + endif + return + end +!************************************************************* + integer function isoutlier_1side(nsamp,yobs,iwhichside) + implicit none +! Detecting the outlier using the Grubb's test for one tail. If there is an outlier, +! isoutlier is the index number of the outlier in the sequence yobs. If there +! is no outlier, isoutlier is returned with -9999 +! iwhichside < 0, detecting the outlier smaller than the mean +! iwhichside > 0, detecting the outlier greater than the mean + integer nsamp,iwhichside + double precision yobs(nsamp) + + integer i,imax + double precision zc,std,fmean,dev,devmax, + & alpha,grubbzc_1side + parameter(alpha=0.05d0) + + isoutlier_1side=-9999 + if(nsamp.le.2)then + return + endif + call stdmean(nsamp,yobs,std,fmean) + + devmax=-9999.0d0 + do i=1,nsamp + dev=(yobs(i)-fmean)/std + if(iwhichside.gt.0)then + if(dev.gt.0.0d0.and.dev.gt.devmax)then + imax=i + devmax=dev + endif + else + if(dev.lt.0.0d0.and.dabs(dev).gt.devmax)then + imax=i + devmax=dabs(dev) + endif + endif + enddo + zc=grubbzc_1side(nsamp,alpha) + if(devmax.ge.zc)then + isoutlier_1side=imax + endif + return + end + + double precision function grubbzc_2sides(nsamp,alpha) + implicit none + integer nsamp + double precision alpha + +! Compute the critical Grubb Z valu +! nsamp: the number of samples (not the degree of freedom) +! alpha: the significance level (the sum of probabilities of +! upper and lower tails) + + double precision Sign_Level,tc,student_t + integer Samples + + Sign_Level=1.0d0-2.0d0*alpha/dble(2*nsamp) + Samples=(nsamp-2) + Samples=Samples+1 + tc=student_t(Samples,Sign_Level) + + grubbzc_2sides=(dble(nsamp)-1.0d0)*tc/dsqrt(dble(nsamp)) + grubbzc_2sides=grubbzc_2sides/dsqrt(dble(nsamp-2)+tc*tc) + return + end + + double precision function grubbzc_1side(nsamp,alpha) + implicit none + integer nsamp + double precision alpha + +! Compute the critical Grubb Z valu +! nsamp: the number of samples (not the degree of freedom) +! alpha: the significance level (one tail probability) upper and lower tails) + + double precision Sign_Level,tc,student_t + integer Samples + + Sign_Level=1.0d0-2.0d0*alpha/dble(nsamp) + Samples=(nsamp-2) + Samples=Samples+1 + tc=student_t(Samples,Sign_Level) + + grubbzc_1side=(dble(nsamp)-1.0d0)*tc/dsqrt(dble(nsamp)) + grubbzc_1side=grubbzc_1side/dsqrt(dble(nsamp-2)+tc*tc) + return + end + + + double precision function grubbzc_0_01(nsamp) + implicit none + integer nsamp,nlow,nhigh + double precision zvalue(140), + & a,b,x0,y0 + + if(nsamp.gt.140)then + a=1903.0377d0 + b=-0.3756d0 + x0=1.0369d-7 + y0=-1898.8572d0 + grubbzc_0_01=y0+a/(1.0d0+(dble(nsamp)/x0)**b) + else + zvalue(3)=1.15d0 + zvalue(4)=1.48d0 + zvalue(5)=1.71d0 + zvalue(6)=1.89d0 + zvalue(7)=2.02d0 + zvalue(8)=2.13d0 + zvalue(9)=2.21d0 + zvalue(10)=2.29d0 + zvalue(11)=2.34d0 + zvalue(12)=2.41d0 + zvalue(13)=2.46d0 + zvalue(14)=2.51d0 + zvalue(15)=2.55d0 + zvalue(16)=2.59d0 + zvalue(17)=2.62d0 + zvalue(18)=2.65d0 + zvalue(19)=2.68d0 + zvalue(20)=2.71d0 + zvalue(21)=2.73d0 + zvalue(22)=2.76d0 + zvalue(23)=2.78d0 + zvalue(24)=2.8d0 + zvalue(25)=2.82d0 + zvalue(26)=2.84d0 + zvalue(27)=2.86d0 + zvalue(28)=2.88d0 + zvalue(29)=2.89d0 + zvalue(30)=2.91d0 + zvalue(31)=2.92d0 + zvalue(32)=2.94d0 + zvalue(33)=2.95d0 + zvalue(34)=2.97d0 + zvalue(35)=2.98d0 + zvalue(36)=2.99d0 + zvalue(37)=3.0d0 + zvalue(38)=3.01d0 + zvalue(39)=3.03d0 + zvalue(40)=3.04d0 + zvalue(50)=3.13d0 + zvalue(60)=3.2d0 + zvalue(70)=3.26d0 + zvalue(80)=3.31d0 + zvalue(90)=3.35d0 + zvalue(100)=3.38d0 + zvalue(110)=3.42d0 + zvalue(120)=3.44d0 + zvalue(130)=3.47d0 + zvalue(140)=3.49d0 + if(nsamp.le.40)then + grubbzc_0_01=zvalue(nsamp) + else + if(nsamp.eq.140)then + grubbzc_0_01=zvalue(140) + else + nlow=idint(dble(nsamp)/10.0d0)*10 + nhigh=10+idint(dble(nsamp)/10.0d0)*10 + grubbzc_0_01=zvalue(nlow)+(zvalue(nhigh)-zvalue(nlow))* + & dble(nsamp-nlow)/dble(nhigh-nlow) + endif + endif + endif + return + end diff --git a/dataassim/math/othersupmath/phenoindices.f b/dataassim/math/othersupmath/phenoindices.f new file mode 100644 index 0000000..90d20e4 --- /dev/null +++ b/dataassim/math/othersupmath/phenoindices.f @@ -0,0 +1,973 @@ +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine phenoindices(ivexcave,ndim,beta,phenofunc,step, + &nmaxextre,tstart,tend,nphenocycl,timemark,ishape,gpprefsp, + &gppreffl,gpprefspday,gpprefflday,spinitday,gppatspinitday,psdlin, + &gppatpsdlin,pddlin,gppatpddlin,fltermday,gppatfltermday,centerday, + &effgrowleng,assimpotindex,effmaxgpp,spmaxder,spmaxderday, + &spmaxdergpp,flmaxder,flmaxderday,flmaxdergpp,extremegpp, + &extremegppday,paramskewness,paramkurtosis,gppphase1,gppphase2, + &gppphase3,gppphase4,gppphase5,bellarea,gppmin,gppmax,timegppmin, + &timegppmax,nmingpp,nmaxgpp,offcenterday,offeffgrowleng, + &offassimpotindex,offeffmaxgpp,offparamskewness,offparamkurtosis, + &offgppphase1,offgppphase2,offgppphase3,offgppphase4,offgppphase5) + implicit none +!ivexcave =0, timemark provided for each pheno cycle, let the program determines the shape of each cycle +! =1, do convex indices, use minuma as timemark +! =2, do concave indices, use maxima as timemark + integer ivexcave,ndim,nmaxextre,nmingpp,nmaxgpp,i,nphenocycl, + &ishape(nmaxextre) + double precision beta(ndim),tstart,tend,step, + &timemark(nphenocycl+1),gpprefsp(nmaxextre),gppreffl(nmaxextre), + &gpprefspday(nmaxextre),gpprefflday(nmaxextre), + &spinitday(nmaxextre),gppatspinitday(nmaxextre),psdlin(nmaxextre), + &gppatpsdlin(nmaxextre),pddlin(nmaxextre),gppatpddlin(nmaxextre), + &fltermday(nmaxextre),gppatfltermday(nmaxextre), + ¢erday(nmaxextre),effgrowleng(nmaxextre), + &assimpotindex(nmaxextre),effmaxgpp(nmaxextre),spmaxder(nmaxextre), + &spmaxderday(nmaxextre),spmaxdergpp(nmaxextre),flmaxder(nmaxextre), + &flmaxderday(nmaxextre),flmaxdergpp(nmaxextre), + &extremegpp(nmaxextre),extremegppday(nmaxextre), + ¶mskewness(nmaxextre),paramkurtosis(nmaxextre), + &gppphase1(nmaxextre),gppphase2(nmaxextre),gppphase3(nmaxextre), + &gppphase4(nmaxextre),gppphase5(nmaxextre),bellarea(nmaxextre), + &gppmin(nmaxextre),gppmax(nmaxextre),timegppmin(nmaxextre), + &timegppmax(nmaxextre),offcenterday(nmaxextre), + &offeffgrowleng(nmaxextre),offassimpotindex(nmaxextre), + &offeffmaxgpp(nmaxextre),offparamskewness(nmaxextre), + &offparamkurtosis(nmaxextre),offgppphase1(nmaxextre), + &offgppphase2(nmaxextre),offgppphase3(nmaxextre), + &offgppphase4(nmaxextre),offgppphase5(nmaxextre) + external phenofunc + call extremaviader(ndim,beta,phenofunc,step,nmaxextre, + &tstart,tend,gppmin,gppmax,timegppmin,timegppmax,nmingpp, + &nmaxgpp) + if(ivexcave.eq.1.or.ivexcave.eq.2)then + if(ivexcave.eq.1)then + nphenocycl=nmingpp-1 + do i=1,nmingpp-1 + call bellindices(ndim,beta,phenofunc,timegppmin(i), + &timegppmin(i+1),step,ishape(i),gpprefsp(i),gppreffl(i), + &gpprefspday(i),gpprefflday(i),spinitday(i), + &gppatspinitday(i),psdlin(i),gppatpsdlin(i),pddlin(i), + &gppatpddlin(i),fltermday(i),gppatfltermday(i),centerday(i), + &effgrowleng(i),assimpotindex(i),effmaxgpp(i),spmaxder(i), + &spmaxderday(i),spmaxdergpp(i),flmaxder(i),flmaxderday(i), + &flmaxdergpp(i),extremegpp(i),extremegppday(i),paramskewness(i), + ¶mkurtosis(i),gppphase1(i),gppphase2(i),gppphase3(i), + &gppphase4(i),gppphase5(i),bellarea(i),offcenterday(i), + &offeffgrowleng(i),offassimpotindex(i),offeffmaxgpp(i), + &offparamskewness(i),offparamkurtosis(i),offgppphase1(i), + &offgppphase2(i),offgppphase3(i),offgppphase4(i),offgppphase5(i)) + enddo + endif + if(ivexcave.eq.2)then + nphenocycl=nmaxgpp-1 + do i=1,nmaxgpp-1 + call bellindices(ndim,beta,phenofunc,timegppmax(i), + &timegppmax(i+1),step,ishape(i),gpprefsp(i),gppreffl(i), + &gpprefspday(i),gpprefflday(i),spinitday(i), + &gppatspinitday(i),psdlin(i),gppatpsdlin(i),pddlin(i), + &gppatpddlin(i),fltermday(i),gppatfltermday(i),centerday(i), + &effgrowleng(i),assimpotindex(i),effmaxgpp(i),spmaxder(i), + &spmaxderday(i),spmaxdergpp(i),flmaxder(i),flmaxderday(i), + &flmaxdergpp(i),extremegpp(i),extremegppday(i),paramskewness(i), + ¶mkurtosis(i),gppphase1(i),gppphase2(i),gppphase3(i), + &gppphase4(i),gppphase5(i),bellarea(i),offcenterday(i), + &offeffgrowleng(i),offassimpotindex(i),offeffmaxgpp(i), + &offparamskewness(i),offparamkurtosis(i),offgppphase1(i), + &offgppphase2(i),offgppphase3(i),offgppphase4(i),offgppphase5(i)) + enddo + endif + else + do i=1,nphenocycl + call bellindices(ndim,beta,phenofunc,timemark(i), + &timemark(i+1),step,ishape(i),gpprefsp(i),gppreffl(i), + &gpprefspday(i),gpprefflday(i),spinitday(i), + &gppatspinitday(i),psdlin(i),gppatpsdlin(i),pddlin(i), + &gppatpddlin(i),fltermday(i),gppatfltermday(i),centerday(i), + &effgrowleng(i),assimpotindex(i),effmaxgpp(i),spmaxder(i), + &spmaxderday(i),spmaxdergpp(i),flmaxder(i),flmaxderday(i), + &flmaxdergpp(i),extremegpp(i),extremegppday(i),paramskewness(i), + ¶mkurtosis(i),gppphase1(i),gppphase2(i),gppphase3(i), + &gppphase4(i),gppphase5(i),bellarea(i),offcenterday(i), + &offeffgrowleng(i),offassimpotindex(i),offeffmaxgpp(i), + &offparamskewness(i),offparamkurtosis(i),offgppphase1(i), + &offgppphase2(i),offgppphase3(i),offgppphase4(i),offgppphase5(i)) + enddo + endif + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine bellindices(ndim,beta,phenofunc,firstday,lastday, + &step,ishape,gpprefsp,gppreffl,gpprefspday,gpprefflday, + &spinitday,gppatspinitday,psdlin,gppatpsdlin,pddlin,gppatpddlin, + &fltermday,gppatfltermday,centerday,effgrowleng,assimpotindex, + &effmaxgpp,spmaxder,spmaxderday,spmaxdergpp,flmaxder,flmaxderday, + &flmaxdergpp,extremegpp,extremegppday,paramskewness,paramkurtosis, + &gppphase1,gppphase2,gppphase3,gppphase4,gppphase5,bellarea, + &offcenterday,offeffgrowleng,offassimpotindex,offeffmaxgpp, + &offparamskewness,offparamkurtosis,offgppphase1,offgppphase2, + &offgppphase3,offgppphase4,offgppphase5) + implicit none + integer ishape,ndim,nmaxextre + parameter(nmaxextre=500) + double precision beta(ndim),step,firstday,lastday, + &gpprefsp,gppreffl,gpprefspday,gpprefflday, + &spinitday,gppatspinitday,psdlin,gppatpsdlin, + &pddlin,gppatpddlin,fltermday,gppatfltermday,centerday, + &effgrowleng,assimpotindex,effmaxgpp,spmaxder,spmaxderday, + &spmaxdergpp,flmaxder,flmaxderday,flmaxdergpp,extremegpp, + &extremegppday,paramskewness,paramkurtosis,gppphase1,gppphase2, + &gppphase3,gppphase4,gppphase5,bellarea,dydxp(ndim+1), + &offcenterday,offeffgrowleng,offassimpotindex,offeffmaxgpp, + &offparamskewness,offparamkurtosis,offgppphase1,offgppphase2, + &offgppphase3,offgppphase4,offgppphase5 + double precision p1int,p2int,p3int,day,term,funcint,tfuncint, + &sqtcentfunc,skewness,fkurtosis,fintercept,sigma,gppmin(nmaxextre), + &gppmax(nmaxextre),timegppmin(nmaxextre),timegppmax(nmaxextre), + &gppmin_der(nmaxextre),gppmax_der(nmaxextre),offset, + &timegppmin_der(nmaxextre),timegppmax_der(nmaxextre) + integer n,i,nmingpp,nmaxgpp,nmingpp_der,nmaxgpp_der + external phenofunc +! + call extremaviader(ndim,beta,phenofunc,step,nmaxextre, + &firstday,lastday,gppmin,gppmax,timegppmin,timegppmax,nmingpp, + &nmaxgpp) + call findextrema(1,ndim,beta,phenofunc,step,nmaxextre, + &firstday,lastday,gppmin_der,gppmax_der,timegppmin_der, + &timegppmax_der,nmingpp_der,nmaxgpp_der) +!determine whether it is a convex (bell) shape or a concave (reverse-bess) shape. +!A convex shape has the largest function value located between the sharpest ascend and the sharpest descend (ascend first). +!A concave shape has the smallest fuction value located between the sharpest descend and the sharpest ascend (descend first). +!largest function value + extremegpp=gppmax(1) + extremegppday=timegppmax(1) + do i=2,nmaxgpp + if(gppmax(i).gt.extremegpp)then + extremegpp=gppmax(i) + extremegppday=timegppmax(i) + endif + enddo +!most positive derivative + spmaxder=gppmax_der(1) + spmaxderday=timegppmax_der(1) + do i=2,nmaxgpp_der + if(gppmax_der(i).gt.spmaxder)then + spmaxder=gppmax_der(i) + spmaxderday=timegppmax_der(i) + endif + enddo + call phenofunc(1,spmaxdergpp,1,spmaxderday,ndim,beta,dydxp,0) +!most negative derivative + flmaxder=gppmin_der(1) + flmaxderday=timegppmin_der(1) + do i=2,nmingpp_der + if(gppmin_der(i).lt.flmaxder)then + flmaxder=gppmin_der(i) + flmaxderday=timegppmin_der(i) + endif + enddo + call phenofunc(1,flmaxdergpp,1,flmaxderday,ndim,beta,dydxp,0) + if(flmaxderday.ge.extremegppday.and. + &extremegppday.ge.spmaxderday)then +!it is a convex + ishape=1 + else +!try concave +!smallest function value + extremegpp=gppmin(1) + extremegppday=timegppmin(1) + do i=2,nmingpp + if(gppmin(i).lt.extremegpp)then + extremegpp=gppmin(i) + extremegppday=timegppmin(i) + endif + enddo + call fortranswap(1,spmaxder,flmaxder) + call fortranswap(1,spmaxderday,flmaxderday) + call fortranswap(1,spmaxdergpp,flmaxdergpp) +!now flmaxder is most positive and spmaxder is most negative + if(flmaxderday.ge.extremegppday.and. + &extremegppday.ge.spmaxderday)then +!it is a concave + ishape=2 + else +!the general shape is unrecognized. use the local shape + if(flmaxderday.lt.spmaxderday)then + call fortranswap(1,spmaxder,flmaxder) + call fortranswap(1,spmaxderday,flmaxderday) + call fortranswap(1,spmaxdergpp,flmaxdergpp) +!now spmaxder is most positive and flmaxder is most negative +!a small bell + ishape=-1 + else +!a small revese-bell + ishape=-2 + endif + call extremaviader(ndim,beta,phenofunc,step,nmaxextre, + &spmaxderday,flmaxderday,gppmin,gppmax,timegppmin,timegppmax, + &nmingpp,nmaxgpp) + if(ishape.eq.-1)then + extremegpp=gppmax(1) + extremegppday=timegppmax(1) + do i=2,nmaxgpp + if(gppmax(i).gt.extremegpp)then + extremegpp=gppmax(i) + extremegppday=timegppmax(i) + endif + enddo + else + extremegpp=gppmin(1) + extremegppday=timegppmin(1) + do i=2,nmingpp + if(gppmin(i).lt.extremegpp)then + extremegpp=gppmin(i) + extremegppday=timegppmin(i) + endif + enddo + endif + endif + endif +!find reference gpp + call extremaviader(ndim,beta,phenofunc,step,nmaxextre,firstday, + &spmaxderday,gppmin,gppmax,timegppmin,timegppmax,nmingpp,nmaxgpp) + if(ishape.eq.1.or.ishape.eq.-1)then + gpprefsp=gppmin(1) + gpprefspday=timegppmin(1) + do i=2,nmingpp + if(gppmin(i).lt.gpprefsp)then + gpprefsp=gppmin(i) + gpprefspday=timegppmin(i) + endif + enddo + else + gpprefsp=gppmax(1) + gpprefspday=timegppmax(1) + do i=2,nmaxgpp + if(gppmax(i).lt.gpprefsp)then + gpprefsp=gppmax(i) + gpprefspday=timegppmax(i) + endif + enddo + endif + call extremaviader(ndim,beta,phenofunc,step,nmaxextre,flmaxderday, + &lastday,gppmin,gppmax,timegppmin,timegppmax,nmingpp,nmaxgpp) + if(ishape.eq.1.or.ishape.eq.-1)then + gppreffl=gppmin(1) + gpprefflday=timegppmin(1) + do i=2,nmingpp + if(gppmin(i).lt.gppreffl)then + gppreffl=gppmin(i) + gpprefflday=timegppmin(i) + endif + enddo + else + gppreffl=gppmax(1) + gpprefflday=timegppmax(1) + do i=2,nmaxgpp + if(gppmax(i).lt.gppreffl)then + gppreffl=gppmax(i) + gpprefflday=timegppmax(i) + endif + enddo + endif +! spring +180 fintercept=spmaxdergpp-spmaxder*spmaxderday + spinitday=(gpprefsp-fintercept)/spmaxder + call phenofunc(1,gppatspinitday,1,spinitday,ndim,beta,dydxp,0) + psdlin=(extremegpp-fintercept)/spmaxder + call phenofunc(1,gppatpsdlin,1,psdlin,ndim,beta,dydxp,0) +! fall + fintercept=flmaxdergpp-flmaxder*flmaxderday + fltermday=(gppreffl-fintercept)/flmaxder + call phenofunc(1,gppatfltermday,1,fltermday,ndim,beta,dydxp,0) + pddlin=(extremegpp-fintercept)/flmaxder + call phenofunc(1,gppatpddlin,1,pddlin,ndim,beta,dydxp,0) +! +!first no offset + offset=0.0d0 + assimpotindex=funcint(ndim,beta,phenofunc,firstday,lastday,offset) + p2int=tfuncint(ndim,beta,phenofunc,firstday,lastday,offset) + centerday=p2int/assimpotindex + p3int=sqtcentfunc(ndim,beta,phenofunc,firstday,lastday,centerday, + &offset) + sigma=dsqrt(p3int/assimpotindex) + effgrowleng=2.0d0*dsqrt(3.0d0)*sigma + effmaxgpp=assimpotindex/effgrowleng + paramskewness= + &skewness(ndim,beta,phenofunc,firstday,lastday,centerday,offset) + paramskewness=paramskewness/ + & (assimpotindex*sigma*sigma*sigma) + paramkurtosis= + &fkurtosis(ndim,beta,phenofunc,firstday,lastday,centerday,offset) + paramkurtosis=paramkurtosis/ + & (assimpotindex*sigma*sigma*sigma*sigma) + paramkurtosis=paramkurtosis-3.0d0 + gppphase1=funcint(ndim,beta,phenofunc,firstday,spinitday,offset) + gppphase2=funcint(ndim,beta,phenofunc,spinitday,psdlin,offset) + gppphase3=funcint(ndim,beta,phenofunc,psdlin,pddlin,offset) + gppphase4=funcint(ndim,beta,phenofunc,pddlin,fltermday,offset) + gppphase5=funcint(ndim,beta,phenofunc,fltermday,lastday,offset) + bellarea=funcint(ndim,beta,phenofunc,gpprefspday,gpprefflday, + &offset) + bellarea=bellarea-0.5d0*(gpprefsp+gppreffl)* + &(gpprefflday-gpprefspday) +! +!with offset + offset=0.5d0*(gpprefsp+gppreffl) + offassimpotindex=funcint(ndim,beta,phenofunc,gpprefspday, + &gpprefflday,offset) + p2int=tfuncint(ndim,beta,phenofunc,gpprefspday,gpprefflday,offset) + offcenterday=p2int/offassimpotindex + p3int=sqtcentfunc(ndim,beta,phenofunc,gpprefspday,gpprefflday, + &offcenterday,offset) + sigma=dsqrt(p3int/offassimpotindex) + offeffgrowleng=2.0d0*dsqrt(3.0d0)*sigma + offeffmaxgpp=offassimpotindex/offeffgrowleng + offparamskewness= + &skewness(ndim,beta,phenofunc,gpprefspday,gpprefflday, + &offcenterday,offset) + offparamskewness=offparamskewness/ + &(offassimpotindex*sigma*sigma*sigma) + offparamkurtosis=fkurtosis(ndim,beta,phenofunc,gpprefspday, + &gpprefflday,offcenterday,offset)/ + &(offassimpotindex*sigma*sigma*sigma*sigma)-3.0d0 + offgppphase1= + &funcint(ndim,beta,phenofunc,gpprefspday,spinitday,offset) + offgppphase2= + &funcint(ndim,beta,phenofunc,spinitday,psdlin,offset) + offgppphase3=funcint(ndim,beta,phenofunc,psdlin,pddlin,offset) + offgppphase4=funcint(ndim,beta,phenofunc,pddlin,fltermday,offset) + offgppphase5=funcint(ndim,beta,phenofunc,fltermday, + &gpprefflday,offset) + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function sqfuncint(ndim,beta,phenofunc, + &day1st,dayend,offset) + implicit double precision(a-h,l,o-z) + dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1) + parameter(nside=10000) + external phenofunc +c + cell=(dayend-day1st)/dble(nside) + sum = 0.0d0 + do 30 m = 1, nside + day0 = day1st+dble(m-1)*cell + day1 = day1st+dble(m)*cell + call quadrat(day0, day1, dayquad, weit, fact1) + do 40 n = 1, 8 + call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0) + func=func-offset + sum = sum+func*func*weit(n)*fact1 +40 continue +30 continue + sqfuncint=sum + return + end +c + double precision function tsqfuncint(ndim,beta,phenofunc, + &day1st,dayend,offset) + implicit double precision(a-h,l,o-z) + dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1) + parameter(nside=10000) + external phenofunc +c + cell=(dayend-day1st)/dble(nside) + sum = 0.0d0 + do 30 m = 1, nside + day0 = day1st+dble(m-1)*cell + day1 = day1st+dble(m)*cell + call quadrat(day0, day1, dayquad, weit, fact1) + do 40 n = 1, 8 + call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0) + func=func-offset + sum = sum+dayquad(n)*func*func*weit(n)*fact1 +40 continue +30 continue + tsqfuncint=sum + return + end + + double precision function tfuncint(ndim,beta,phenofunc, + &day1st,dayend,offset) + implicit double precision(a-h,l,o-z) + dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1) + parameter(nside=10000) + external phenofunc +c + cell=(dayend-day1st)/dble(nside) + sum = 0.0d0 + do 30 m = 1, nside + day0 = day1st+dble(m-1)*cell + day1 = day1st+dble(m)*cell + call quadrat(day0, day1, dayquad, weit, fact1) + do 40 n = 1, 8 + call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0) + func=func-offset + sum = sum+dayquad(n)*func*weit(n)*fact1 +40 continue +30 continue + tfuncint=sum + return + end +c + double precision function sqtcentsqfunc(ndim,beta,phenofunc, + &day1st,dayend,daymid,offset) + implicit double precision(a-h,l,o-z) + dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1) + parameter(nside=10000) + external phenofunc +c + cell=(dayend-day1st)/dble(nside) + sum = 0.0d0 + do 30 m = 1, nside + day0 = day1st+dble(m-1)*cell + day1 = day1st+dble(m)*cell + call quadrat(day0, day1, dayquad, weit, fact1) + do 40 n = 1, 8 + call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0) + func=func-offset + sum = sum+(dayquad(n)-daymid)*(dayquad(n)-daymid)* + &func*func*weit(n)*fact1 +40 continue +30 continue + sqtcentsqfunc=sum + return + end + + double precision function sqtcentfunc(ndim,beta,phenofunc, + &day1st,dayend,daymid,offset) + implicit double precision(a-h,l,o-z) + dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1) + parameter(nside=10000) + external phenofunc +c + cell=(dayend-day1st)/dble(nside) + sum = 0.0d0 + do 30 m = 1, nside + day0 = day1st+dble(m-1)*cell + day1 = day1st+dble(m)*cell + call quadrat(day0, day1, dayquad, weit, fact1) + do 40 n = 1, 8 + call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0) + func=func-offset + sum = sum+(dayquad(n)-daymid)*(dayquad(n)-daymid)* + &func*weit(n)*fact1 +40 continue +30 continue + sqtcentfunc=sum + return + end + + double precision function skewness(ndim,beta,phenofunc, + &day1st,dayend,daymid,offset) + implicit double precision(a-h,l,o-z) + dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1) + parameter(nside=10000) + external phenofunc +c + cell=(dayend-day1st)/dble(nside) + sum = 0.0d0 + do 30 m = 1, nside + day0 = day1st+dble(m-1)*cell + day1 = day1st+dble(m)*cell + call quadrat(day0, day1, dayquad, weit, fact1) + do 40 n = 1, 8 + call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0) + func=func-offset + sum = sum+(dayquad(n)-daymid)*(dayquad(n)-daymid)* + & (dayquad(n)-daymid)*func*weit(n)*fact1 +40 continue +30 continue + skewness=sum + return + end +c + double precision function fkurtosis(ndim,beta,phenofunc, + &day1st,dayend,daymid,offset) + implicit double precision(a-h,l,o-z) + dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1) + parameter(nside=10000) + external phenofunc +c + cell=(dayend-day1st)/dble(nside) + sum = 0.0d0 + do 30 m = 1, nside + day0 = day1st+dble(m-1)*cell + day1 = day1st+dble(m)*cell + call quadrat(day0, day1, dayquad, weit, fact1) + do 40 n = 1, 8 + call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0) + func=func-offset + sum = sum+(dayquad(n)-daymid)*(dayquad(n)-daymid)* + & (dayquad(n)-daymid)*(dayquad(n)-daymid)* + & func*weit(n)*fact1 +40 continue +30 continue + fkurtosis=sum + return + end + + double precision function funcint(ndim,beta,phenofunc, + &day1st,dayend,offset) + implicit double precision(a-h,l,o-z) + dimension dayquad(8),weit(8),beta(ndim),dydxp(ndim+1) + parameter(nside=10000) + external phenofunc +c + cell=(dayend-day1st)/dble(nside) + sum = 0.0d0 + do 30 m = 1, nside + day0 = day1st+dble(m-1)*cell + day1 = day1st+dble(m)*cell + call quadrat(day0, day1, dayquad, weit, fact1) + do 40 n = 1, 8 + call phenofunc(1,func,1,dayquad(n),ndim,beta,dydxp,0) + func=func-offset + sum = sum+func*weit(n)*fact1 +40 continue +30 continue + funcint=sum + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine findextrema(idowhat,ndim,beta,phenofunc,step, + &nmaxextre,tstart,tend,gppmin,gppmax,timegppmin,timegppmax, + &nmingpp,nmaxgpp) + implicit none +!idowhat=0, function value extremes +!idowhat=1, function devatives extrems + integer idowhat,ndim,nmaxextre,nmingpp,nmaxgpp + double precision beta(ndim),tstart,tend,step,gppmin(nmaxextre), + &gppmax(nmaxextre),timegppmin(nmaxextre),timegppmax(nmaxextre), + &gpp0,time,gpp1,t0,dydxp(ndim+1) + integer istatus,iup,idn,iuptoflat,idntoflat + parameter(iup=1,idn=2,iuptoflat=4,idntoflat=5) + external phenofunc +!------------------------------------------------------------------ +! find maxima and minima in gpp + t0=tstart + nmaxgpp=0 + nmingpp=0 + call phenofunc(1,gpp0,1,t0,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gpp0=dydxp(1) + time=t0+step + call phenofunc(1,gpp1,1,time,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gpp1=dydxp(1) + if(gpp1.gt.gpp0)then +! gpp increases so gpp0 must be a minimum + nmingpp=1 + gppmin(1)=gpp0 + timegppmin(1)=t0 + istatus=iup + else + if(gpp1.lt.gpp0)then +! gpp decreases so gpp0 must be a maximum + nmaxgpp=1 + gppmax(1)=gpp0 + timegppmax(1)=t0 + istatus=idn + else +! gpp flat + istatus=-9999 + endif + endif +50 gpp0=gpp1 + time=time+step + call phenofunc(1,gpp1,1,time,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gpp1=dydxp(1) + if(gpp1.gt.gpp0)then +! increase + if(istatus.eq.iup)then +! still increase + if(time.ge.tend)then + nmaxgpp=nmaxgpp+1 + call + &phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1) + timegppmax(nmaxgpp)=tend + goto 1000 + else + goto 50 + endif + endif + if(istatus.eq.idn)then +! previous down but now up so a minimum is reached + nmingpp=nmingpp+1 + gppmin(nmingpp)=gpp0 + timegppmin(nmingpp)=time-step + if(time.ge.tend)then + timegppmin(nmingpp)=tend + call + &phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1) + goto 1000 + endif + istatus=iup + goto 50 + endif +!previous step flat + if(istatus.eq.iuptoflat)then +!going up to flat and then going up again. ignore this staircase. + istatus=iup + goto 50 + endif + if(istatus.eq.idntoflat)then +!going down to flat and then going up so the flat represents a minimum. set the time +!stamp at the center of the flat. t0 is when the flat starts + nmingpp=nmingpp+1 + timegppmin(nmingpp)=(t0+time-step)/2.0d0 + call phenofunc(1,gppmin(nmingpp),1,timegppmin(nmingpp), + &ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1) + if(time.ge.tend)then + timegppmin(nmingpp)=tend + call + &phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1) + goto 1000 + endif + istatus=iup + goto 50 + else +!flat begining of the curve and then going up so the begining is a minimum + nmingpp=nmingpp+1 + timegppmin(nmingpp)=t0 + call phenofunc(1,gppmin(nmingpp),1,t0,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1) + istatus=iup + goto 50 + endif + else + if(gpp1.lt.gpp0)then +! decrease + if(istatus.eq.idn)then +! still decrease + if(time.ge.tend)then + nmingpp=nmingpp+1 + call + &phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1) + timegppmin(nmingpp)=tend + goto 1000 + else + goto 50 + endif + endif + if(istatus.eq.iup)then +! previous up but now down so a maximum is reached + nmaxgpp=nmaxgpp+1 + gppmax(nmaxgpp)=gpp0 + timegppmax(nmaxgpp)=time-step + if(time.ge.tend)then + timegppmax(nmaxgpp)=tend + call + &phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1) + goto 1000 + endif + istatus=idn + goto 50 + endif +! previous flat + if(istatus.eq.idntoflat)then +!going down to flat and then going down again. ignore this staircase + istatus=idn + goto 50 + endif + if(istatus.eq.iuptoflat)then +!going up to flat and then going down so the flat represents a maximum + nmaxgpp=nmaxgpp+1 + timegppmax(nmaxgpp)=(t0+time-step)/2.0d0 + call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp), + &ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1) + if(time.ge.tend)then + timegppmax(nmaxgpp)=tend + call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp), + &ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1) + goto 1000 + endif + istatus=idn + goto 50 + else +!flat begining of the curve and then going down so the begining is a maximum + nmaxgpp=nmaxgpp+1 + timegppmax(nmaxgpp)=t0 + call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp), + &ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1) + istatus=idn + goto 50 + endif + else +! a flat place + if(istatus.eq.iup)then +! up to flat + if(time.ge.tend)then + nmaxgpp=nmaxgpp+1 + timegppmax(nmaxgpp)=tend + call + &phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1) + goto 1000 + endif + istatus=iuptoflat + t0=time-step + goto 50 + endif + if(istatus.eq.idn)then +! down to flat + if(time.ge.tend)then + nmingpp=nmingpp+1 + timegppmin(nmingpp)=tend + call + &phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1) + goto 1000 + endif + istatus=idntoflat + t0=time-step + goto 50 + endif +! remain on a flat. no information is recorded unless at the end. + if(time.ge.tend)then + if(istatus.eq.iuptoflat)then + nmaxgpp=nmaxgpp+1 + timegppmax(nmaxgpp)=tend + call + &phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmax(nmaxgpp)=dydxp(1) + else + if(istatus.eq.idntoflat)then + nmingpp=nmingpp+1 + timegppmin(nmingpp)=tend + call + &phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,idowhat) + if(idowhat.eq.1)gppmin(nmingpp)=dydxp(1) + else +!a horizontal line + return + endif + endif + goto 1000 + endif + goto 50 + endif + endif +1000 return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine extremaviader(ndim,beta,phenofunc,step,nmaxextre, + &tstart,tend,gppmin,gppmax,timegppmin,timegppmax,nmingpp,nmaxgpp) + implicit none +!find function value extremes only via changes in derivatives. +!Do not use this subroutine to find extremes of derivatives. use findextrema instead + integer ndim,nmaxextre,nmingpp,nmaxgpp + double precision beta(ndim),tstart,tend,step,gppmin(nmaxextre), + &gppmax(nmaxextre),timegppmin(nmaxextre),timegppmax(nmaxextre), + &gpp0,time,t0,dydxp(ndim+1) + integer istatus,iup,idn,iuptoflat,idntoflat + parameter(iup=1,idn=2,iuptoflat=4,idntoflat=5) + external phenofunc +!------------------------------------------------------------------ +! find maxima and minima in gpp + time=tstart + nmaxgpp=0 + nmingpp=0 + call phenofunc(1,gpp0,1,time,ndim,beta,dydxp,1) + if(dydxp(1).gt.0.0d0)then +! gpp increases so gpp0 must be a minimum + nmingpp=1 + gppmin(1)=gpp0 + timegppmin(1)=time + istatus=iup + else + if(dydxp(1).lt.0.0d0)then +! gpp decreases so gpp0 must be a maximum + nmaxgpp=1 + gppmax(1)=gpp0 + timegppmax(1)=time + istatus=idn + else +! gpp flat in the begining + istatus=-9999 + endif + endif +50 time=time+step + call phenofunc(1,gpp0,1,time,ndim,beta,dydxp,1) + if(dydxp(1).gt.0.0d0)then +! increase + if(istatus.eq.iup)then +! still increase + if(time.ge.tend)then + nmaxgpp=nmaxgpp+1 + call + &phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,0) + timegppmax(nmaxgpp)=tend + goto 1000 + else + goto 50 + endif + endif + if(istatus.eq.idn)then +! previous down but now up so a minimum is reached + nmingpp=nmingpp+1 + if(time.ge.tend)then + timegppmin(nmingpp)=tend + call + &phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,0) + goto 1000 + endif + time=time-step/2.0d0 + timegppmin(nmingpp)=time + call + &phenofunc(1,gppmin(nmingpp),1,time,ndim,beta,dydxp,0) + istatus=iup + goto 50 + endif +!previous step flat + if(istatus.eq.iuptoflat)then +!going up to flat and then going up again. ignore this staircase. + istatus=iup + goto 50 + endif + if(istatus.eq.idntoflat)then +!going down to flat and then going up so the flat represents a minimum. set the time +!stamp at the center of the flat. t0 is when the flat starts + nmingpp=nmingpp+1 + timegppmin(nmingpp)=(t0+time-step)/2.0d0 + call phenofunc(1,gppmin(nmingpp),1,timegppmin(nmingpp), + &ndim,beta,dydxp,0) + if(time.ge.tend)then + timegppmin(nmingpp)=tend + call + &phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,0) + goto 1000 + endif + istatus=iup + goto 50 + else +!flat begining of the curve and then going up so the begining is a minimum + nmingpp=nmingpp+1 + timegppmin(nmingpp)=tstart + call phenofunc(1,gppmin(nmingpp),1,tstart,ndim,beta,dydxp,0) + istatus=iup + goto 50 + endif + else + if(dydxp(1).lt.0.0d0)then +! decrease + if(istatus.eq.idn)then +! still decrease + if(time.ge.tend)then + nmingpp=nmingpp+1 + call + &phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,0) + timegppmin(nmingpp)=tend + goto 1000 + else + goto 50 + endif + endif + if(istatus.eq.iup)then +! previous up but now down so a maximum is reached + nmaxgpp=nmaxgpp+1 + if(time.ge.tend)then + timegppmax(nmaxgpp)=tend + call + &phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,0) + goto 1000 + endif + time=time-step/2.0d0 + timegppmax(nmaxgpp)=time + call + &phenofunc(1,gppmax(nmaxgpp),1,time,ndim,beta,dydxp,0) + istatus=idn + goto 50 + endif +! previous flat + if(istatus.eq.idntoflat)then +!going down to flat and then going down again. ignore this staircase + istatus=idn + goto 50 + endif + if(istatus.eq.iuptoflat)then +!going up to flat and then going down so the flat represents a maximum + nmaxgpp=nmaxgpp+1 + timegppmax(nmaxgpp)=(t0+time-step)/2.0d0 + call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp), + &ndim,beta,dydxp,0) + if(time.ge.tend)then + timegppmax(nmaxgpp)=tend + call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp), + &ndim,beta,dydxp,0) + goto 1000 + endif + istatus=idn + goto 50 + else +!flat begining of the curve and then going down so the begining is a maximum + nmaxgpp=nmaxgpp+1 + timegppmax(nmaxgpp)=tstart + call phenofunc(1,gppmax(nmaxgpp),1,timegppmax(nmaxgpp), + &ndim,beta,dydxp,0) + istatus=idn + goto 50 + endif + else +! a flat place + if(istatus.eq.iup)then +! up to flat + if(time.ge.tend)then + nmaxgpp=nmaxgpp+1 + timegppmax(nmaxgpp)=tend + call + &phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,0) + goto 1000 + endif + istatus=iuptoflat + t0=time-step + goto 50 + endif + if(istatus.eq.idn)then +! down to flat + if(time.ge.tend)then + nmingpp=nmingpp+1 + timegppmin(nmingpp)=tend + call + &phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,0) + goto 1000 + endif + istatus=idntoflat + t0=time-step + goto 50 + endif +! remain on a flat. no information is recorded unless at the end. + if(time.ge.tend)then + if(istatus.eq.iuptoflat)then + nmaxgpp=nmaxgpp+1 + timegppmax(nmaxgpp)=tend + call + &phenofunc(1,gppmax(nmaxgpp),1,tend,ndim,beta,dydxp,0) + else + if(istatus.eq.idntoflat)then + nmingpp=nmingpp+1 + timegppmin(nmingpp)=tend + call + &phenofunc(1,gppmin(nmingpp),1,tend,ndim,beta,dydxp,0) + else +!a horizontal line + return + endif + endif + goto 1000 + endif + goto 50 + endif + endif +1000 return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/othersupmath/removerepeat.f b/dataassim/math/othersupmath/removerepeat.f new file mode 100644 index 0000000..22fb8fd --- /dev/null +++ b/dataassim/math/othersupmath/removerepeat.f @@ -0,0 +1,52 @@ + subroutine removerepeat(nin,stringin,nout,stringout,ncounter) + implicit none + integer nin,nout,ncounter(nin,nin+1) + character*100 stringin(nin),stringout(nin),term, + &chari,charj + character a*1 + integer i,j,k,n + do i=1,nin + do j=1,nin+1 + ncounter(i,j)=0 + enddo + stringin(i)=trim(stringin(i)) + enddo + nout=0 + do i=1,nin + term=trim(stringin(i)) + n=len(term) + chari='' + do k=1,n + a=term(k:k) + if((ichar(a).ge.65.and.ichar(a).le.90).or. + &(ichar(a).ge.97.and.ichar(a).le.122))then + if(ichar(a).ge.97)a=char(ichar(a)-32) + chari=trim(chari)//a + endif + enddo + do j=1,nout + term=trim(stringout(j)) + n=len(term) + charj='' + do k=1,n + a=term(k:k) + if((ichar(a).ge.65.and.ichar(a).le.90).or. + &(ichar(a).ge.97.and.ichar(a).le.122))then + if(ichar(a).ge.97)a=char(ichar(a)-32) + charj=trim(charj)//a + endif + enddo + if(trim(chari).eq.trim(charj))then + ncounter(j,1)=ncounter(j,1)+1 + ncounter(j,i+1)=1 + goto 10 + endif + enddo + nout=nout+1 + stringout(nout)=trim(stringin(i)) + ncounter(nout,1)=ncounter(nout,1)+1 + ncounter(nout,i+1)=1 +10 continue + enddo + return + end diff --git a/dataassim/math/othersupmath/rootploy.f b/dataassim/math/othersupmath/rootploy.f new file mode 100644 index 0000000..10b0a92 --- /dev/null +++ b/dataassim/math/othersupmath/rootploy.f @@ -0,0 +1,744 @@ + program main + implicit none + integer degree,i + logical fail + double precision op(4),zeror(4),zeroi(4) + + op(1)=3.0d0 + op(2)=6.0d0 + op(3)=-123.0d0 + op(4)=-126.0d0 + op(5)=1080.0d0 + degree=4 + + call RPOLY(op,degree,zeror,zeroi,fail) + write(*,*)degree,fail + do i=1,4 + write(*,*)zeror(i),zeroi(i) + enddo + end + + SUBROUTINE RPOLY(OP, DEGREE, ZEROR, ZEROI, RPO 10 + * FAIL) +C FINDS THE ZEROS OF A REAL POLYNOMIAL +C OP - DOUBLE PRECISION VECTOR OF COEFFICIENTS IN +C ORDER OF DECREASING POWERS. +C DEGREE - INTEGER DEGREE OF POLYNOMIAL. +C ZEROR, ZEROI - OUTPUT DOUBLE PRECISION VECTORS OF +C REAL AND IMAGINARY PARTS OF THE +C ZEROS. +C FAIL - OUTPUT LOGICAL PARAMETER, TRUE ONLY IF +C LEADING COEFFICIENT IS ZERO OR IF RPOLY +C HAS FOUND FEWER THAN DEGREE ZEROS. +C IN THE LATTER CASE DEGREE IS RESET TO +C THE NUMBER OF ZEROS FOUND. +C TO CHANGE THE SIZE OF POLYNOMIALS WHICH CAN BE +C SOLVED, RESET THE DIMENSIONS OF THE ARRAYS IN THE +C COMMON AREA AND IN THE FOLLOWING DECLARATIONS. +C THE SUBROUTINE USES SINGLE PRECISION CALCULATIONS +C FOR SCALING, BOUNDS AND ERROR CALCULATIONS. ALL +C CALCULATIONS FOR THE ITERATIONS ARE DONE IN DOUBLE +C PRECISION. + COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U, + * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G, + * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN + DOUBLE PRECISION P(101), QP(101), K(101), + * QK(101), SVK(101), SR, SI, U, V, A, B, C, D, + * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI, + * LZR, LZI + REAL ETA, ARE, MRE + INTEGER N, NN + DOUBLE PRECISION OP(101), TEMP(101), + * ZEROR(100), ZEROI(100), T, AA, BB, CC, DABS, + * FACTOR + REAL PT(101), LO, MAX, MIN, XX, YY, COSR, + * SINR, XXX, X, SC, BND, XM, FF, DF, DX, INFIN, + * SMALNO, BASE + INTEGER DEGREE, CNT, NZ, I, J, JJ, NM1 + LOGICAL FAIL, ZEROK +C THE FOLLOWING STATEMENTS SET MACHINE CONSTANTS USED +C IN VARIOUS PARTS OF THE PROGRAM. THE MEANING OF THE +C FOUR CONSTANTS ARE... +C ETA THE MAXIMUM RELATIVE REPRESENTATION ERROR +C WHICH CAN BE DESCRIBED AS THE SMALLEST +C POSITIVE FLOATING POINT NUMBER SUCH THAT +C 1.D0+ETA IS GREATER THAN 1. +C INFINY THE LARGEST FLOATING-POINT NUMBER. +C SMALNO THE SMALLEST POSITIVE FLOATING-POINT NUMBER +C IF THE EXPONENT RANGE DIFFERS IN SINGLE AND +C DOUBLE PRECISION THEN SMALNO AND INFIN +C SHOULD INDICATE THE SMALLER RANGE. +C BASE THE BASE OF THE FLOATING-POINT NUMBER +C SYSTEM USED. +C THE VALUES BELOW CORRESPOND TO THE BURROUGHS B6700 + BASE = 8. + ETA = .5*BASE**(1-26) + INFIN = 4.3E68 + SMALNO = 1.0E-45 +C ARE AND MRE REFER TO THE UNIT ERROR IN + AND * +C RESPECTIVELY. THEY ARE ASSUMED TO BE THE SAME AS +C ETA. + ARE = ETA + MRE = ETA + LO = SMALNO/ETA +C INITIALIZATION OF CONSTANTS FOR SHIFT ROTATION + XX = .70710678 + YY = -XX + COSR = -.069756474 + SINR = .99756405 + FAIL = .FALSE. + N = DEGREE + NN = N + 1 +C ALGORITHM FAILS IF THE LEADING COEFFICIENT IS ZERO. + IF (OP(1).NE.0.D0) GO TO 10 + FAIL = .TRUE. + DEGREE = 0 + RETURN +C REMOVE THE ZEROS AT THE ORIGIN IF ANY + 10 IF (OP(NN).NE.0.0D0) GO TO 20 + J = DEGREE - N + 1 + ZEROR(J) = 0.D0 + ZEROI(J) = 0.D0 + NN = NN - 1 + N = N - 1 + GO TO 10 +C MAKE A COPY OF THE COEFFICIENTS + 20 DO 30 I=1,NN + P(I) = OP(I) + 30 CONTINUE +C START THE ALGORITHM FOR ONE ZERO + 40 IF (N.GT.2) GO TO 60 + IF (N.LT.1) then + RETURN + endif + +C CALCULATE THE FINAL ZERO OR PAIR OF ZEROS + IF (N.EQ.2) GO TO 50 + ZEROR(DEGREE) = -P(2)/P(1) + ZEROI(DEGREE) = 0.0D0 + RETURN + 50 CALL QUAD(P(1), P(2), P(3), ZEROR(DEGREE-1), + * ZEROI(DEGREE-1), ZEROR(DEGREE), ZEROI(DEGREE)) + RETURN +C FIND LARGEST AND SMALLEST MODULI OF COEFFICIENTS. + 60 MAX = 0. + MIN = INFIN + DO 70 I=1,NN + X = ABS(SNGL(P(I))) + IF (X.GT.MAX) MAX = X + IF (X.NE.0. .AND. X.LT.MIN) MIN = X + 70 CONTINUE +C SCALE IF THERE ARE LARGE OR VERY SMALL COEFFICIENTS +C COMPUTES A SCALE FACTOR TO MULTIPLY THE +C COEFFICIENTS OF THE POLYNOMIAL. THE SCALING IS DONE +C TO AVOID OVERFLOW AND TO AVOID UNDETECTED UNDERFLOW +C INTERFERING WITH THE CONVERGENCE CRITERION. +C THE FACTOR IS A POWER OF THE BASE + SC = LO/MIN + IF (SC.GT.1.0) GO TO 80 + IF (MAX.LT.10.) GO TO 110 + IF (SC.EQ.0.) SC = SMALNO + GO TO 90 + 80 IF (INFIN/SC.LT.MAX) GO TO 110 + 90 L = ALOG(SC)/ALOG(BASE) + .5 + FACTOR = (BASE*1.0D0)**L + IF (FACTOR.EQ.1.D0) GO TO 110 + DO 100 I=1,NN + P(I) = FACTOR*P(I) + 100 CONTINUE +C COMPUTE LOWER BOUND ON MODULI OF ZEROS. + 110 DO 120 I=1,NN + PT(I) = ABS(SNGL(P(I))) + 120 CONTINUE + PT(NN) = -PT(NN) +C COMPUTE UPPER ESTIMATE OF BOUND + X = EXP((ALOG(-PT(NN))-ALOG(PT(1)))/FLOAT(N)) + IF (PT(N).EQ.0.) GO TO 130 +C IF NEWTON STEP AT THE ORIGIN IS BETTER, USE IT. + XM = -PT(NN)/PT(N) + IF (XM.LT.X) X = XM +C CHOP THE INTERVAL (0,X) UNTIL FF .LE. 0 + 130 XM = X*.1 + FF = PT(1) + DO 140 I=2,NN + FF = FF*XM + PT(I) + 140 CONTINUE + IF (FF.LE.0.) GO TO 150 + X = XM + GO TO 130 + 150 DX = X +C DO NEWTON ITERATION UNTIL X CONVERGES TO TWO +C DECIMAL PLACES + 160 IF (ABS(DX/X).LE..005) GO TO 180 + FF = PT(1) + DF = FF + DO 170 I=2,N + FF = FF*X + PT(I) + DF = DF*X + FF + 170 CONTINUE + FF = FF*X + PT(NN) + DX = FF/DF + X = X - DX + GO TO 160 + 180 BND = X +C COMPUTE THE DERIVATIVE AS THE INTIAL K POLYNOMIAL +C AND DO 5 STEPS WITH NO SHIFT + NM1 = N - 1 + DO 190 I=2,N + K(I) = FLOAT(NN-I)*P(I)/FLOAT(N) + 190 CONTINUE + K(1) = P(1) + AA = P(NN) + BB = P(N) + ZEROK = K(N).EQ.0.D0 + DO 230 JJ=1,5 + CC = K(N) + IF (ZEROK) GO TO 210 +C USE SCALED FORM OF RECURRENCE IF VALUE OF K AT 0 IS +C NONZERO + T = -AA/CC + DO 200 I=1,NM1 + J = NN - I + K(J) = T*K(J-1) + P(J) + 200 CONTINUE + K(1) = P(1) + ZEROK = DABS(K(N)).LE.DABS(BB)*ETA*10. + GO TO 230 +C USE UNSCALED FORM OF RECURRENCE + 210 DO 220 I=1,NM1 + J = NN - I + K(J) = K(J-1) + 220 CONTINUE + K(1) = 0.D0 + ZEROK = K(N).EQ.0.D0 + 230 CONTINUE +C SAVE K FOR RESTARTS WITH NEW SHIFTS + DO 240 I=1,N + TEMP(I) = K(I) + 240 CONTINUE +C LOOP TO SELECT THE QUADRATIC CORRESPONDING TO EACH +C NEW SHIFT + DO 280 CNT=1,20 +C QUADRATIC CORRESPONDS TO A DOUBLE SHIFT TO A +C NON-REAL POINT AND ITS COMPLEX CONJUGATE. THE POINT +C HAS MODULUS BND AND AMPLITUDE ROTATED BY 94 DEGREES +C FROM THE PREVIOUS SHIFT + XXX = COSR*XX - SINR*YY + YY = SINR*XX + COSR*YY + XX = XXX + SR = BND*XX + SI = BND*YY + U = -2.0D0*SR + V = BND +C SECOND STAGE CALCULATION, FIXED QUADRATIC + CALL FXSHFR(20*CNT, NZ) + IF (NZ.EQ.0) GO TO 260 +C THE SECOND STAGE JUMPS DIRECTLY TO ONE OF THE THIRD +C STAGE ITERATIONS AND RETURNS HERE IF SUCCESSFUL. +C DEFLATE THE POLYNOMIAL, STORE THE ZERO OR ZEROS AND +C RETURN TO THE MAIN ALGORITHM. + J = DEGREE - N + 1 + ZEROR(J) = SZR + ZEROI(J) = SZI + NN = NN - NZ + N = NN - 1 + DO 250 I=1,NN + P(I) = QP(I) + 250 CONTINUE + IF (NZ.EQ.1) GO TO 40 + ZEROR(J+1) = LZR + ZEROI(J+1) = LZI + GO TO 40 +C IF THE ITERATION IS UNSUCCESSFUL ANOTHER QUADRATIC +C IS CHOSEN AFTER RESTORING K + 260 DO 270 I=1,N + K(I) = TEMP(I) + 270 CONTINUE + 280 CONTINUE +C RETURN WITH FAILURE IF NO CONVERGENCE WITH 20 +C SHIFTS + FAIL = .TRUE. + DEGREE = DEGREE - N + RETURN + END + SUBROUTINE FXSHFR(L2, NZ) FXS 10 +C COMPUTES UP TO L2 FIXED SHIFT K-POLYNOMIALS, +C TESTING FOR CONVERGENCE IN THE LINEAR OR QUADRATIC +C CASE. INITIATES ONE OF THE VARIABLE SHIFT +C ITERATIONS AND RETURNS WITH THE NUMBER OF ZEROS +C FOUND. +C L2 - LIMIT OF FIXED SHIFT STEPS +C NZ - NUMBER OF ZEROS FOUND + COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U, + * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G, + * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN + DOUBLE PRECISION P(101), QP(101), K(101), + * QK(101), SVK(101), SR, SI, U, V, A, B, C, D, + * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI, + * LZR, LZI + REAL ETA, ARE, MRE + INTEGER N, NN + DOUBLE PRECISION SVU, SVV, UI, VI, S + REAL BETAS, BETAV, OSS, OVV, SS, VV, TS, TV, + * OTS, OTV, TVV, TSS + INTEGER L2, NZ, TYPE, I, J, IFLAG + LOGICAL VPASS, SPASS, VTRY, STRY + NZ = 0 + BETAV = .25 + BETAS = .25 + OSS = SR + OVV = V +C EVALUATE POLYNOMIAL BY SYNTHETIC DIVISION + CALL QUADSD(NN, U, V, P, QP, A, B) + CALL CALCSC(TYPE) + DO 80 J=1,L2 +C CALCULATE NEXT K POLYNOMIAL AND ESTIMATE V + CALL NEXTK(TYPE) + CALL CALCSC(TYPE) + CALL NEWEST(TYPE, UI, VI) + VV = VI +C ESTIMATE S + SS = 0. + IF (K(N).NE.0.D0) SS = -P(NN)/K(N) + TV = 1. + TS = 1. + IF (J.EQ.1 .OR. TYPE.EQ.3) GO TO 70 +C COMPUTE RELATIVE MEASURES OF CONVERGENCE OF S AND V +C SEQUENCES + IF (VV.NE.0.) TV = ABS((VV-OVV)/VV) + IF (SS.NE.0.) TS = ABS((SS-OSS)/SS) +C IF DECREASING, MULTIPLY TWO MOST RECENT +C CONVERGENCE MEASURES + TVV = 1. + IF (TV.LT.OTV) TVV = TV*OTV + TSS = 1. + IF (TS.LT.OTS) TSS = TS*OTS +C COMPARE WITH CONVERGENCE CRITERIA + VPASS = TVV.LT.BETAV + SPASS = TSS.LT.BETAS + IF (.NOT.(SPASS .OR. VPASS)) GO TO 70 +C AT LEAST ONE SEQUENCE HAS PASSED THE CONVERGENCE +C TEST. STORE VARIABLES BEFORE ITERATING + SVU = U + SVV = V + DO 10 I=1,N + SVK(I) = K(I) + 10 CONTINUE + S = SS +C CHOOSE ITERATION ACCORDING TO THE FASTEST +C CONVERGING SEQUENCE + VTRY = .FALSE. + STRY = .FALSE. + IF (SPASS .AND. ((.NOT.VPASS) .OR. + * TSS.LT.TVV)) GO TO 40 + 20 CALL QUADIT(UI, VI, NZ) + IF (NZ.GT.0) RETURN +C QUADRATIC ITERATION HAS FAILED. FLAG THAT IT HAS +C BEEN TRIED AND DECREASE THE CONVERGENCE CRITERION. + VTRY = .TRUE. + BETAV = BETAV*.25 +C TRY LINEAR ITERATION IF IT HAS NOT BEEN TRIED AND +C THE S SEQUENCE IS CONVERGING + IF (STRY .OR. (.NOT.SPASS)) GO TO 50 + DO 30 I=1,N + K(I) = SVK(I) + 30 CONTINUE + 40 CALL REALIT(S, NZ, IFLAG) + IF (NZ.GT.0) RETURN +C LINEAR ITERATION HAS FAILED. FLAG THAT IT HAS BEEN +C TRIED AND DECREASE THE CONVERGENCE CRITERION + STRY = .TRUE. + BETAS = BETAS*.25 + IF (IFLAG.EQ.0) GO TO 50 +C IF LINEAR ITERATION SIGNALS AN ALMOST DOUBLE REAL +C ZERO ATTEMPT QUADRATIC INTERATION + UI = -(S+S) + VI = S*S + GO TO 20 +C RESTORE VARIABLES + 50 U = SVU + V = SVV + DO 60 I=1,N + K(I) = SVK(I) + 60 CONTINUE +C TRY QUADRATIC ITERATION IF IT HAS NOT BEEN TRIED +C AND THE V SEQUENCE IS CONVERGING + IF (VPASS .AND. (.NOT.VTRY)) GO TO 20 +C RECOMPUTE QP AND SCALAR VALUES TO CONTINUE THE +C SECOND STAGE + CALL QUADSD(NN, U, V, P, QP, A, B) + CALL CALCSC(TYPE) + 70 OVV = VV + OSS = SS + OTV = TV + OTS = TS + 80 CONTINUE + RETURN + END + SUBROUTINE QUADIT(UU, VV, NZ) QUA 10 +C VARIABLE-SHIFT K-POLYNOMIAL ITERATION FOR A +C QUADRATIC FACTOR CONVERGES ONLY IF THE ZEROS ARE +C EQUIMODULAR OR NEARLY SO. +C UU,VV - COEFFICIENTS OF STARTING QUADRATIC +C NZ - NUMBER OF ZERO FOUND + COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U, + * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G, + * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN + DOUBLE PRECISION P(101), QP(101), K(101), + * QK(101), SVK(101), SR, SI, U, V, A, B, C, D, + * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI, + * LZR, LZI + REAL ETA, ARE, MRE + INTEGER N, NN + DOUBLE PRECISION UI, VI, UU, VV, DABS + REAL MS, MP, OMP, EE, RELSTP, T, ZM + INTEGER NZ, TYPE, I, J + LOGICAL TRIED + NZ = 0 + TRIED = .FALSE. + U = UU + V = VV + J = 0 +C MAIN LOOP + 10 CALL QUAD(1.D0, U, V, SZR, SZI, LZR, LZI) +C RETURN IF ROOTS OF THE QUADRATIC ARE REAL AND NOT +C CLOSE TO MULTIPLE OR NEARLY EQUAL AND OF OPPOSITE +C SIGN + IF (DABS(DABS(SZR)-DABS(LZR)).GT..01D0* + * DABS(LZR)) RETURN +C EVALUATE POLYNOMIAL BY QUADRATIC SYNTHETIC DIVISION + CALL QUADSD(NN, U, V, P, QP, A, B) + MP = DABS(A-SZR*B) + DABS(SZI*B) +C COMPUTE A RIGOROUS BOUND ON THE ROUNDING ERROR IN +C EVALUTING P + ZM = SQRT(ABS(SNGL(V))) + EE = 2.*ABS(SNGL(QP(1))) + T = -SZR*B + DO 20 I=2,N + EE = EE*ZM + ABS(SNGL(QP(I))) + 20 CONTINUE + EE = EE*ZM + ABS(SNGL(A)+T) + EE = (5.*MRE+4.*ARE)*EE - (5.*MRE+2.*ARE)* + * (ABS(SNGL(A)+T)+ABS(SNGL(B))*ZM) + + * 2.*ARE*ABS(T) +C ITERATION HAS CONVERGED SUFFICIENTLY IF THE +C POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND + IF (MP.GT.20.*EE) GO TO 30 + NZ = 2 + RETURN + 30 J = J + 1 +C STOP ITERATION AFTER 20 STEPS + IF (J.GT.20) RETURN + IF (J.LT.2) GO TO 50 + IF (RELSTP.GT..01 .OR. MP.LT.OMP .OR. TRIED) + * GO TO 50 +C A CLUSTER APPEARS TO BE STALLING THE CONVERGENCE. +C FIVE FIXED SHIFT STEPS ARE TAKEN WITH A U,V CLOSE +C TO THE CLUSTER + IF (RELSTP.LT.ETA) RELSTP = ETA + RELSTP = SQRT(RELSTP) + U = U - U*RELSTP + V = V + V*RELSTP + CALL QUADSD(NN, U, V, P, QP, A, B) + DO 40 I=1,5 + CALL CALCSC(TYPE) + CALL NEXTK(TYPE) + 40 CONTINUE + TRIED = .TRUE. + J = 0 + 50 OMP = MP +C CALCULATE NEXT K POLYNOMIAL AND NEW U AND V + CALL CALCSC(TYPE) + CALL NEXTK(TYPE) + CALL CALCSC(TYPE) + CALL NEWEST(TYPE, UI, VI) +C IF VI IS ZERO THE ITERATION IS NOT CONVERGING + IF (VI.EQ.0.D0) RETURN + RELSTP = DABS((VI-V)/VI) + U = UI + V = VI + GO TO 10 + END + SUBROUTINE REALIT(SSS, NZ, IFLAG) REA 10 +C VARIABLE-SHIFT H POLYNOMIAL ITERATION FOR A REAL +C ZERO. +C SSS - STARTING ITERATE +C NZ - NUMBER OF ZERO FOUND +C IFLAG - FLAG TO INDICATE A PAIR OF ZEROS NEAR REAL +C AXIS. + COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U, + * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G, + * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN + DOUBLE PRECISION P(101), QP(101), K(101), + * QK(101), SVK(101), SR, SI, U, V, A, B, C, D, + * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI, + * LZR, LZI + REAL ETA, ARE, MRE + INTEGER N, NN + DOUBLE PRECISION PV, KV, T, S, SSS, DABS + REAL MS, MP, OMP, EE + INTEGER NZ, IFLAG, I, J, NM1 + NM1 = N - 1 + NZ = 0 + S = SSS + IFLAG = 0 + J = 0 +C MAIN LOOP + 10 PV = P(1) +C EVALUATE P AT S + QP(1) = PV + DO 20 I=2,NN + PV = PV*S + P(I) + QP(I) = PV + 20 CONTINUE + MP = DABS(PV) +C COMPUTE A RIGOROUS BOUND ON THE ERROR IN EVALUATING +C P + MS = DABS(S) + EE = (MRE/(ARE+MRE))*ABS(SNGL(QP(1))) + DO 30 I=2,NN + EE = EE*MS + ABS(SNGL(QP(I))) + 30 CONTINUE +C ITERATION HAS CONVERGED SUFFICIENTLY IF THE +C POLYNOMIAL VALUE IS LESS THAN 20 TIMES THIS BOUND + IF (MP.GT.20.*((ARE+MRE)*EE-MRE*MP)) GO TO 40 + NZ = 1 + SZR = S + SZI = 0.D0 + RETURN + 40 J = J + 1 +C STOP ITERATION AFTER 10 STEPS + IF (J.GT.10) RETURN + IF (J.LT.2) GO TO 50 + IF (DABS(T).GT..001*DABS(S-T) .OR. MP.LE.OMP) + * GO TO 50 +C A CLUSTER OF ZEROS NEAR THE REAL AXIS HAS BEEN +C ENCOUNTERED RETURN WITH IFLAG SET TO INITIATE A +C QUADRATIC ITERATION + IFLAG = 1 + SSS = S + RETURN +C RETURN IF THE POLYNOMIAL VALUE HAS INCREASED +C SIGNIFICANTLY + 50 OMP = MP +C COMPUTE T, THE NEXT POLYNOMIAL, AND THE NEW ITERATE + KV = K(1) + QK(1) = KV + DO 60 I=2,N + KV = KV*S + K(I) + QK(I) = KV + 60 CONTINUE + IF (DABS(KV).LE.DABS(K(N))*10.*ETA) GO TO 80 +C USE THE SCALED FORM OF THE RECURRENCE IF THE VALUE +C OF K AT S IS NONZERO + T = -PV/KV + K(1) = QP(1) + DO 70 I=2,N + K(I) = T*QK(I-1) + QP(I) + 70 CONTINUE + GO TO 100 +C USE UNSCALED FORM + 80 K(1) = 0.0D0 + DO 90 I=2,N + K(I) = QK(I-1) + 90 CONTINUE + 100 KV = K(1) + DO 110 I=2,N + KV = KV*S + K(I) + 110 CONTINUE + T = 0.D0 + IF (DABS(KV).GT.DABS(K(N))*10.*ETA) T = -PV/KV + S = S + T + GO TO 10 + END + SUBROUTINE CALCSC(TYPE) CAL 10 +C THIS ROUTINE CALCULATES SCALAR QUANTITIES USED TO +C COMPUTE THE NEXT K POLYNOMIAL AND NEW ESTIMATES OF +C THE QUADRATIC COEFFICIENTS. +C TYPE - INTEGER VARIABLE SET HERE INDICATING HOW THE +C CALCULATIONS ARE NORMALIZED TO AVOID OVERFLOW + COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U, + * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G, + * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN + DOUBLE PRECISION P(101), QP(101), K(101), + * QK(101), SVK(101), SR, SI, U, V, A, B, C, D, + * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI, + * LZR, LZI + REAL ETA, ARE, MRE + INTEGER N, NN + DOUBLE PRECISION DABS + INTEGER TYPE +C SYNTHETIC DIVISION OF K BY THE QUADRATIC 1,U,V + CALL QUADSD(N, U, V, K, QK, C, D) + IF (DABS(C).GT.DABS(K(N))*100.*ETA) GO TO 10 + IF (DABS(D).GT.DABS(K(N-1))*100.*ETA) GO TO 10 + TYPE = 3 +C TYPE=3 INDICATES THE QUADRATIC IS ALMOST A FACTOR +C OF K + RETURN + 10 IF (DABS(D).LT.DABS(C)) GO TO 20 + TYPE = 2 +C TYPE=2 INDICATES THAT ALL FORMULAS ARE DIVIDED BY D + E = A/D + F = C/D + G = U*B + H = V*B + A3 = (A+G)*E + H*(B/D) + A1 = B*F - A + A7 = (F+U)*A + H + RETURN + 20 TYPE = 1 +C TYPE=1 INDICATES THAT ALL FORMULAS ARE DIVIDED BY C + E = A/C + F = D/C + G = U*E + H = V*B + A3 = A*E + (H/C+G)*B + A1 = B - A*(D/C) + A7 = A + G*D + H*F + RETURN + END + SUBROUTINE NEXTK(TYPE) NEX 10 +C COMPUTES THE NEXT K POLYNOMIALS USING SCALARS +C COMPUTED IN CALCSC + COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U, + * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G, + * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN + DOUBLE PRECISION P(101), QP(101), K(101), + * QK(101), SVK(101), SR, SI, U, V, A, B, C, D, + * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI, + * LZR, LZI + REAL ETA, ARE, MRE + INTEGER N, NN + DOUBLE PRECISION TEMP, DABS + INTEGER TYPE + IF (TYPE.EQ.3) GO TO 40 + TEMP = A + IF (TYPE.EQ.1) TEMP = B + IF (DABS(A1).GT.DABS(TEMP)*ETA*10.) GO TO 20 +C IF A1 IS NEARLY ZERO THEN USE A SPECIAL FORM OF THE +C RECURRENCE + K(1) = 0.D0 + K(2) = -A7*QP(1) + DO 10 I=3,N + K(I) = A3*QK(I-2) - A7*QP(I-1) + 10 CONTINUE + RETURN +C USE SCALED FORM OF THE RECURRENCE + 20 A7 = A7/A1 + A3 = A3/A1 + K(1) = QP(1) + K(2) = QP(2) - A7*QP(1) + DO 30 I=3,N + K(I) = A3*QK(I-2) - A7*QP(I-1) + QP(I) + 30 CONTINUE + RETURN +C USE UNSCALED FORM OF THE RECURRENCE IF TYPE IS 3 + 40 K(1) = 0.D0 + K(2) = 0.D0 + DO 50 I=3,N + K(I) = QK(I-2) + 50 CONTINUE + RETURN + END + SUBROUTINE NEWEST(TYPE, UU, VV) NEW 10 +C COMPUTE NEW ESTIMATES OF THE QUADRATIC COEFFICIENTS +C USING THE SCALARS COMPUTED IN CALCSC. + COMMON /GLOBAL/ P, QP, K, QK, SVK, SR, SI, U, + * V, A, B, C, D, A1, A2, A3, A6, A7, E, F, G, + * H, SZR, SZI, LZR, LZI, ETA, ARE, MRE, N, NN + DOUBLE PRECISION P(101), QP(101), K(101), + * QK(101), SVK(101), SR, SI, U, V, A, B, C, D, + * A1, A2, A3, A6, A7, E, F, G, H, SZR, SZI, + * LZR, LZI + REAL ETA, ARE, MRE + INTEGER N, NN + DOUBLE PRECISION A4, A5, B1, B2, C1, C2, C3, + * C4, TEMP, UU, VV + INTEGER TYPE +C USE FORMULAS APPROPRIATE TO SETTING OF TYPE. + IF (TYPE.EQ.3) GO TO 30 + IF (TYPE.EQ.2) GO TO 10 + A4 = A + U*B + H*F + A5 = C + (U+V*F)*D + GO TO 20 + 10 A4 = (A+G)*F + H + A5 = (F+U)*C + V*D +C EVALUATE NEW QUADRATIC COEFFICIENTS. + 20 B1 = -K(N)/P(NN) + B2 = -(K(N-1)+B1*P(N))/P(NN) + C1 = V*B2*A1 + C2 = B1*A7 + C3 = B1*B1*A3 + C4 = C1 - C2 - C3 + TEMP = A5 + B1*A4 - C4 + IF (TEMP.EQ.0.D0) GO TO 30 + UU = U - (U*(C3+C2)+V*(B1*A1+B2*A7))/TEMP + VV = V*(1.+C4/TEMP) + RETURN +C IF TYPE=3 THE QUADRATIC IS ZEROED + 30 UU = 0.D0 + VV = 0.D0 + RETURN + END + SUBROUTINE QUADSD(NN, U, V, P, Q, A, B) QUA 10 +C DIVIDES P BY THE QUADRATIC 1,U,V PLACING THE +C QUOTIENT IN Q AND THE REMAINDER IN A,B + DOUBLE PRECISION P(NN), Q(NN), U, V, A, B, C + INTEGER I + B = P(1) + Q(1) = B + A = P(2) - U*B + Q(2) = A + DO 10 I=3,NN + C = P(I) - U*A - V*B + Q(I) = C + B = A + A = C + 10 CONTINUE + RETURN + END + SUBROUTINE QUAD(A, B1, C, SR, SI, LR, LI) QUA 10 +C CALCULATE THE ZEROS OF THE QUADRATIC A*Z**2+B1*Z+C. +C THE QUADRATIC FORMULA, MODIFIED TO AVOID +C OVERFLOW, IS USED TO FIND THE LARGER ZERO IF THE +C ZEROS ARE REAL AND BOTH ZEROS ARE COMPLEX. +C THE SMALLER REAL ZERO IS FOUND DIRECTLY FROM THE +C PRODUCT OF THE ZEROS C/A. + DOUBLE PRECISION A, B1, C, SR, SI, LR, LI, B, + * D, E, DABS, DSQRT + IF (A.NE.0.D0) GO TO 20 + SR = 0.D0 + IF (B1.NE.0.D0) SR = -C/B1 + LR = 0.D0 + 10 SI = 0.D0 + LI = 0.D0 + RETURN + 20 IF (C.NE.0.D0) GO TO 30 + SR = 0.D0 + LR = -B1/A + GO TO 10 +C COMPUTE DISCRIMINANT AVOIDING OVERFLOW + 30 B = B1/2.D0 + IF (DABS(B).LT.DABS(C)) GO TO 40 + E = 1.D0 - (A/B)*(C/B) + D = DSQRT(DABS(E))*DABS(B) + GO TO 50 + 40 E = A + IF (C.LT.0.D0) E = -A + E = B*(B/DABS(C)) - E + D = DSQRT(DABS(E))*DSQRT(DABS(C)) + 50 IF (E.LT.0.D0) GO TO 60 +C REAL ZEROS + IF (B.GE.0.D0) D = -D + LR = (-B+D)/A + SR = 0.D0 + IF (LR.NE.0.D0) SR = (C/LR)/A + GO TO 10 +C COMPLEX CONJUGATE ZEROS + 60 SR = -B/A + LR = SR + SI = DABS(D/A) + LI = -SI + RETURN + END diff --git a/dataassim/math/othersupmath/sigmoid.f b/dataassim/math/othersupmath/sigmoid.f new file mode 100644 index 0000000..673abe0 --- /dev/null +++ b/dataassim/math/othersupmath/sigmoid.f @@ -0,0 +1,158 @@ + double precision function sigmoidfunc(y0,a,b,c,x0,x) + implicit none + double precision y0,a,b,c,x0,x,term,crit + parameter(crit=300.0d0) + if((-(x-x0)/b).lt.crit)then + term=dexp(-(x-x0)/b) + sigmoidfunc=y0+a*(1.0d0/(1.0d0+term))**c + else + term=dexp((x-x0)/b) + sigmoidfunc=y0+a*(term/(1.0d0+term))**c + endif + return + end +!------------------------------------------------------------------- + subroutine gradsigmoidfunc(y0,a,b,c,x0,x,grad) + implicit none + double precision y0,a,b,c,x0,x,grad(6),term,crit + parameter(crit=300.0d0) +! a<->grad(1) +! b<->grad(2) +! c<->grad(3) +! x0<->grad(4) +! y0<->grad(5) +! x<->grad(6) + grad(5)=1.0d0 + if((-(x-x0)/b).lt.crit)then + term=dexp(-(x-x0)/b) + grad(1)=(1.0d0/(1.0d0+term))**c + grad(6)=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c) + grad(4)=-(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c) + grad(2)=-(a*c*term*(x-x0)/(b*b))* + & (1.0d0/(1.0d0+term))**(1.0d0+c) + grad(3)=-(a*dlog(1.0d0+term))*(1.0d0/(1.0d0+term))**c + else + term=(x-x0)/b + grad(1)=(dexp(term)/(1.0d0+dexp(term)))**c + grad(6)=(a*c/b)*(dexp(term*c/(c+1.0d0))/ + & (1.0d0+dexp(term)))**(c+1.0d0) + grad(4)=-(a*c/b)*(dexp(term*c/(c+1))/ + & (1.0d0+dexp(term)))**(c+1.0d0) + grad(2)=-(a*c*(x-x0)/(b*b))* + & (dexp(term*c/(c+1.0d0))/(1.0d0+dexp(term)))**(1.0d0+c) + grad(3)=-a*(dlog(1.0d0+dexp(term))-term)* + & (dexp(term)/(1.0d0+dexp(term)))**c + endif + return + end +!-------------------------------------------------------------------- + double precision function twoexpfunc(y0,a1,b1,c1,x01, + &a2,b2,c2,x02,x) + implicit none + double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,sigmoidfunc + twoexpfunc=y0+sigmoidfunc(0.0d0,a1,b1,c1,x01,x)- + &sigmoidfunc(0.0d0,a2,b2,c2,x02,x) + return + end +!--------------------------------------------------------------------- + subroutine gradtwoexp(y0,a1,b1,c1,x01,a2,b2,c2,x02,x,grad) + implicit none + double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,grad(10),grad6(6) + integer i +! a1<->grad(1) +! b1<->grad(2) +! c1<->grad(3) +! x01<->grad(4) +! y0<->grad(5) +! x<->grad(6) +! a2<->grad(7) +! b2<->grad(8) +! c2<->grad(9) +! x02<->grad(10) + call gradsigmoidfunc(y0,a1,b1,c1,x01,x,grad6) + do i=1,6 + grad(i)=grad6(i) + enddo + call gradsigmoidfunc(0.0,a2,b2,c2,x02,x,grad6) + grad(6)=grad(6)-grad6(6) + do i=1,4 + grad(6+i)=-grad6(i) + enddo + return + end +!------------------------------------------------------------------------------ + subroutine proxyinflpoints(b1,c1,x01,b2,c2,x02,xinfl1,xinfl2) +! the approximate inflection points. The exact analytical solution +! is difficult to find + implicit none + double precision b1,c1,x01,b2,c2,x02,xinfl1,xinfl2 + xinfl1=x01+b1*dlog(c1) + xinfl2=x02+b2*dlog(c2) + end +!------------------------------------------------------------------------------ + double precision function sigmoidcurvat(y0,a,b,c,x0,x) + implicit none + double precision y0,a,b,c,x0,x,term,yp,ypp,crit + parameter(crit=300.0d0) + if((-(x-x0)/b).lt.crit)then + term=dexp(-(x-x0)/b) + yp=(a*c*term/b)*(1.0d0/(1.0d0+term))**(c+1.0d0) + ypp=(a*c/(b*b))*term*(c*term-1.0d0)* + & (1.0d0/(1.0d0+term))**(c+2) + else + term=(x-x0)/b + yp=(a*c/b)*(dexp(term*c/(c+1))/ + & (1.0d0+dexp(term)))**(c+1.0d0) + ypp=(a*c/(b*b))*(c-dexp(term))*(dexp(term*c/(c+2))/ + & (1.0d0+dexp(term)))**(c+2) + endif + sigmoidcurvat=dabs(ypp/((1.0d0+yp*yp)**1.5d0)) + return + end +!------------------------------------------------------------------------------ + double precision function twoexpcurvat(y0,a1,b1,c1,x01, + &a2,b2,c2,x02,x) + implicit none + double precision y0,a1,b1,c1,x01,a2,b2,c2,x02,x,a,b,c,x0, + &term,yp,ypp,crit + parameter(crit=300.0d0) + +! first part + a=a1 + b=b1 + c=c1 + x0=x01 + if((-(x-x0)/b).lt.crit)then + term=dexp(-(x-x0)/b) + yp=(a*c*term/b)*(1.0d0/(1.0d0+term))**(c+1.0d0) + ypp=(a*c/(b*b))*term*(c*term-1.0d0)* + & (1.0d0/(1.0d0+term))**(c+2) + else + term=(x-x0)/b + yp=(a*c/b)*(dexp(term*c/(c+1))/ + & (1.0d0+dexp(term)))**(c+1.0d0) + ypp=(a*c/(b*b))*(c-dexp(term))*(dexp(term*c/(c+2))/ + & (1.0d0+dexp(term)))**(c+2) + endif + +! second part + a=a2 + b=b2 + c=c2 + x0=x02 + if((-(x-x0)/b).lt.crit)then + term=dexp(-(x-x0)/b) + yp=yp-(a*c*term/b)*(1.0d0/(1.0d0+term))**(c+1.0d0) + ypp=ypp-(a*c/(b*b))*term*(c*term-1.0d0)* + & (1.0d0/(1.0d0+term))**(c+2) + else + term=(x-x0)/b + yp=yp-(a*c/b)*(dexp(term*c/(c+1))/ + & (1.0d0+dexp(term)))**(c+1.0d0) + ypp=ypp-(a*c/(b*b))*(c-dexp(term))*(dexp(term*c/(c+2))/ + & (1.0d0+dexp(term)))**(c+2) + endif + twoexpcurvat=dabs(ypp/((1.0d0+yp*yp)**1.5d0)) + return + end +!----------------------------------------------------------------------- diff --git a/dataassim/math/othersupmath/stdmaxmeanmin.f b/dataassim/math/othersupmath/stdmaxmeanmin.f new file mode 100644 index 0000000..2fdddf5 --- /dev/null +++ b/dataassim/math/othersupmath/stdmaxmeanmin.f @@ -0,0 +1,41 @@ +!#################################################################### + subroutine stdmaxmeanmin(nsamp0,xvar0,std,fmean,xmin,xmax) + implicit none + integer nsamp,j,nsamp0 + double precision xvar(nsamp0),std,fmean,xmin,xmax, + & xvar0(nsamp0),gap + parameter(gap=-9999.0d0) + + nsamp=0 + do j=1,nsamp0 + if(dabs(xvar0(j)-gap).gt.1.0d-5)then + nsamp=nsamp+1 + xvar(nsamp)=xvar0(j) + endif + enddo + if(nsamp.lt.1)then + std=gap + fmean=gap + xmin=gap + xmax=gap + return + endif + fmean=0.0d0 + xmin=xvar(1) + xmax=xvar(1) + do j=1,nsamp + fmean=fmean+xvar(j) + if(xvar(j).gt.xmax)then + xmax=xvar(j) + endif + if(xvar(j).lt.xmin)then + xmin=xvar(j) + endif + enddo + fmean=fmean/dble(nsamp) + std=0.0d0 + do j=1,nsamp + std=std+(xvar(j)-fmean)*(xvar(j)-fmean) + enddo + if(nsamp.gt.1)std=dsqrt(std/dble(nsamp-1)) + end diff --git a/dataassim/math/othersupmath/stemaxmeanmin.f b/dataassim/math/othersupmath/stemaxmeanmin.f new file mode 100644 index 0000000..dac3556 --- /dev/null +++ b/dataassim/math/othersupmath/stemaxmeanmin.f @@ -0,0 +1,42 @@ +!#################################################################### + + subroutine stemaxmeanmin(nsamp0,xvar0,ste,fmean,xmin,xmax) + implicit none + integer nsamp,j,nsamp0 + double precision xvar(nsamp0),ste,fmean,xmin,xmax, + & xvar0(nsamp0),gap + parameter(gap=-9999.0d0) + + nsamp=0 + do j=1,nsamp0 + if(dabs(xvar0(j)-gap).gt.1.0d-5)then + nsamp=nsamp+1 + xvar(nsamp)=xvar0(j) + endif + enddo + if(nsamp.lt.1)then + ste=gap + fmean=gap + xmin=gap + xmax=gap + return + endif + fmean=0.0d0 + xmin=xvar(1) + xmax=xvar(1) + do j=1,nsamp + fmean=fmean+xvar(j) + if(xvar(j).gt.xmax)then + xmax=xvar(j) + endif + if(xvar(j).lt.xmin)then + xmin=xvar(j) + endif + enddo + fmean=fmean/dble(nsamp) + ste=0.0d0 + do j=1,nsamp + ste=ste+(xvar(j)-fmean)*(xvar(j)-fmean) + enddo + if(nsamp.gt.1)ste=dsqrt(ste/dble((nsamp-1)*nsamp)) + end diff --git a/dataassim/math/othersupmath/student_t_dist.f b/dataassim/math/othersupmath/student_t_dist.f new file mode 100644 index 0000000..d439651 --- /dev/null +++ b/dataassim/math/othersupmath/student_t_dist.f @@ -0,0 +1,212 @@ + double precision function student_t(ndegfree,Sign_Level) +! +! the integration from -student_t to student_t =Sign_Level +! +! The student-t is calculated for a given degree of freedom +! and at a certain significance level. +! The following relation holds: +! Sign_Level = 1 - IncompleteBetaFunction( x, a, b ) +! x = Df / ( Df + student_t^2 ) +! a = Df / 2 +! b = 0.50 +! We need to solve the above equation for x (or student_t). +! Routines from Numerical Recipes are used for that. + + implicit none +! Input variables. + integer ndegfree +! Degree of freedom + double precision Sign_Level +! Significance level + +! Functions and parameters. + double precision zbrent,tobesolved + double precision x1,x2,b,eps + parameter(x1=0.0d0,x2=1.0d0,b=0.50d0,eps=1.0d-7) + +! Various parameters: x1, x2 bracket the root, given with +! accuracy eps. + +! Local + double precision Df,a +! Degrees of freedom +! a = 0.50 * Df + + external zbrent,tobesolved + + Df = dble(ndegfree) + a = 0.50d0 * Df + student_t=zbrent(tobesolved,a,b,Sign_Level,x1,x2,eps) + student_t = dsqrt( Df/student_t - Df) + end function student_t + + double precision function tobesolved( a, b, c, x ) + implicit none + double precision a, b, c, x +! a, b, c: parameters to the function +! x: variable + double precision betai + external betai +! Incomplete beta function. + tobesolved = betai(a,b,x) - 1.0d0 + c + end function tobesolved + +! The rest of this file comes from Numerical Recipes. +! Function zbrent has been modified slightly +! (variables aaa, bbb, ccc have been intoduced). + +! Brent's method for solving the equation +! func(a,b,c,x)=0 for x, where a,b,c parameters. +! Root is bracketed by x1 and x2. +! Root is returned to varable zbrent with +! accuracy tol. + + double precision function zbrent(func,aaa,bbb,ccc,x1,x2,tol) + implicit none + integer ITMAX,iter + double precision tol,x1,x2,func,EPS, + & a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm, + & aaa,bbb,ccc + parameter(ITMAX=5000) + parameter(EPS=3.0d-8) + external func + + a=x1 + b=x2 + + fa=func(aaa,bbb,ccc,a) + fb=func(aaa,bbb,ccc,b) + if((fa.gt.0.0d0.and.fb.gt.0.0d0).or. + & (fa.lt.0.0d0.and.fb.lt.0.0d0))then + write(*,*) 'root must be bracketed for zbrent' + endif + c=b + fc=fb + do 11 iter=1,ITMAX + if((fb.gt.0.0d0.and.fc.gt.0.0d0).or. + & (fb.lt.0.0d0.and.fc.lt.0.0d0))then + c=a + fc=fa + d=b-a + e=d + endif + if(dabs(fc).lt.dabs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + endif + tol1=2.0d0*EPS*dabs(b)+0.5d0*tol + xm=0.5d0*(c-b) + if(dabs(xm).le.tol1.or.fb.eq.0.0d0)then + zbrent=b + return + endif + if(dabs(e).ge.tol1.and.dabs(fa).gt.dabs(fb))then + s=fb/fa + if(a.eq.c) then + p=2.0d0*xm*s + q=1.0d0-s + else + q=fa/fc + r=fb/fc + p=s*(2.0d0*xm*q*(q-r)-(b-a)*(r-1.0d0)) + q=(q-1.0d0)*(r-1.0d0)*(s-1.0d0) + endif + if(p.gt.0.0d0)q=-q + p=dabs(p) + if(2.0d0*p.lt.dmin1(3.0d0*xm*q-dabs(tol1*q),dabs(e*q)))then + e=d + d=p/q + else + d=xm + e=d + endif + else + d=xm + e=d + endif + a=b + fa=fb + if(dabs(d).gt.tol1)then + b=b+d + else + b=b+dsign(tol1,xm) + endif + fb=func(aaa,bbb,ccc,b) +11 continue + write(*,*) 'zbrent exceeding maximum iterations' + zbrent=b + return + end function zbrent + +! Incomplete beta function. + double precision function betai(a,b,x) + double precision a,b,x +!U USES betacf,gammln + double precision bt + double precision betacf,gammln + external betacf,gammln + + if(x.lt.0.0d0.or.x.gt.1.0d0)then + write(*,*) 'bad argument x in betai' + endif + if(x.eq.0.0d0.or.x.eq.1.0d0)then + bt=0.0d0 + else + bt=dexp(gammln(a+b)-gammln(a)-gammln(b)+ + & a*dlog(x)+b*dlog(1.0d0-x)) + endif + if(x.lt.(a+1.0d0)/(a+b+2.0d0))then + betai=bt*betacf(a,b,x)/a + return + else + betai=1.0d0-bt*betacf(b,a,1.0d0-x)/b + return + endif + end function betai + + ! Continued fraction evaluation. +! Used by routine betai. + ! Numerical Recipes, chapter 6.4. + double precision function betacf(a,b,x) + implicit none + integer MAXIT,m,m2 + double precision a,b,x,EPS,FPMIN + double precision aa,c,d,del,h,qab,qam,qap + parameter(MAXIT = 100) + parameter(EPS=3.0d-7,FPMIN=1.0d-30) + + qab=a+b + qap=a+1.0d0 + qam=a-1.0d0 + c=1.0d0 + d=1.0d0-qab*x/qap + if(dabs(d).lt.FPMIN)d=FPMIN + d=1.0d0/d + h=d + do 11 m=1,MAXIT + m2=2*m + aa=dble(m)*(b-dble(m))*x/((qam+dble(m2))*(a+dble(m2))) + d=1.0d0+aa*d + if(dabs(d).lt.FPMIN)d=FPMIN + c=1.0d0+aa/c + if(dabs(c).lt.FPMIN)c=FPMIN + d=1.0d0/d + h=h*d*c + aa=-(a+dble(m))*(qab+dble(m))*x/((a+dble(m2))*(qap+dble(m2))) + d=1.0d0+aa*d + if(dabs(d).lt.FPMIN)d=FPMIN + c=1.0d0+aa/c + if(dabs(c).lt.FPMIN)c=FPMIN + d=1.0d0/d + del=d*c + h=h*del + if(dabs(del-1.0d0).lt.EPS)goto 1 +11 continue + write(*,*) 'a or b too big, or MAXIT too small in betacf' +1 betacf=h + return + end function betacf diff --git a/dataassim/math/othersupmath/sumstatsoutliers.f b/dataassim/math/othersupmath/sumstatsoutliers.f new file mode 100644 index 0000000..e2960ff --- /dev/null +++ b/dataassim/math/othersupmath/sumstatsoutliers.f @@ -0,0 +1,61 @@ +!#################################################################### + + subroutine sumstatsoutliers(nsamp0,xvar0,std,fmean,xmin,xmax) + implicit none + integer nsamp,i,j,nsamp0,isoutlier_2sides + double precision xvar(nsamp0),std,fmean,xmin,xmax, + & xvar0(nsamp0),gap + parameter(gap=-9999.0d0) + + nsamp=0 + do j=1,nsamp0 + if(dabs(xvar0(j)-gap).gt.1.0d-5)then + nsamp=nsamp+1 + xvar(nsamp)=xvar0(j) + endif + enddo + std=gap + fmean=gap + xmin=gap + xmax=gap + if(nsamp.eq.0)return + if(nsamp.eq.1)then + fmean=xvar(1) + return + endif + +10 i=isoutlier_2sides(nsamp,xvar) + if(i.lt.0)goto 100 + do j=i,nsamp-1 + xvar(j)=xvar(j+1) + enddo + nsamp=nsamp-1 + goto 10 + +100 if(nsamp.lt.1)then + std=gap + fmean=gap + xmin=gap + xmax=gap + return + endif + + fmean=0.0d0 + xmin=xvar(1) + xmax=xvar(1) + do j=1,nsamp + fmean=fmean+xvar(j) + if(xvar(j).gt.xmax)then + xmax=xvar(j) + endif + if(xvar(j).lt.xmin)then + xmin=xvar(j) + endif + enddo + fmean=fmean/dble(nsamp) + std=0.0d0 + do j=1,nsamp + std=std+(xvar(j)-fmean)*(xvar(j)-fmean) + enddo + std=dsqrt(std/dble(nsamp-1)) + end diff --git a/dataassim/math/othersupmath/sumthemup.f b/dataassim/math/othersupmath/sumthemup.f new file mode 100644 index 0000000..b540d96 --- /dev/null +++ b/dataassim/math/othersupmath/sumthemup.f @@ -0,0 +1,33 @@ + double precision function + &sumthemup(n,time,starttime,endtime,xtosum) + implicit none + integer n,i,j + double precision time(n),starttime,endtime,xtosum(n),agap, + &fmean + agap=-9999.0d0 + sumthemup=agap + fmean=0.0d0 + j=0 + do i=1,n + if(time(i).ge.starttime.and.time(i).lt.endtime)then + if(dabs(xtosum(i)-agap).gt.1.0d-5)then + j=j+1 + fmean=fmean+xtosum(i) + endif + endif + enddo + if(j.eq.0)return + fmean=fmean/dble(j) + sumthemup=0.0d0 + do i=1,n + if(time(i).ge.starttime.and.time(i).lt.endtime)then + if(dabs(xtosum(i)-agap).gt.1.0d-5)then + sumthemup=sumthemup+xtosum(i) + else + sumthemup=sumthemup+fmean + endif + endif + enddo + return + end + diff --git a/dataassim/math/othersupmath/supmath.f b/dataassim/math/othersupmath/supmath.f new file mode 100644 index 0000000..b8efa12 --- /dev/null +++ b/dataassim/math/othersupmath/supmath.f @@ -0,0 +1,798 @@ + subroutine sort_shell(n,a,iorder) +!sort array a with the Shell method (from smallest to largest). +!iorder records the original position of each member. + implicit none + integer n,iorder(n) + double precision a(n) + integer i,j,inc,k + double precision v + + do i=1,n + iorder(i)=i + enddo + inc=1 +1 inc=3*inc+1 + if(inc.le.n)goto 1 +2 continue + inc=inc/3 + do i=inc+1,n + v=a(i) + k=iorder(i) + j=i +3 if(a(j-inc).gt.v)then + a(j)=a(j-inc) + iorder(j)=iorder(j-inc) + j=j-inc + if(j.le.inc)goto 4 + goto 3 + endif +4 a(j)=v + iorder(j)=k + enddo + if(inc.gt.1)goto 2 + return + end +c +c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +c This subroutine solves the real root of a cubic equation. Solutions +c are found from p184-185 W. Press et al 1992 Numerical Recipes in C +c + double precision function cubicroot(p,q,r) +c + implicit double precision(a-h,l,o-z) + +c: x^3+p*x^2+q*x+r=0 + + capq=(p*p-3.0d0*q)/9.0d0 + capr=(2.0d0*p*p*p-9.0d0*p*q+27.0d0*r)/54.0d0 + if (capr*capr .lt. capq*capq*capq) then + rtta=dacos(capr/(dsqrt(capq*capq*capq))) + root1=-2.0d0*dsqrt(capq)*dcos(rtta/3.0d0)-p/3.0d0 + + root2=dsqrt(capq)*(dcos(rtta/3.0d0)+dsin(rtta/3.0d0)* + & dsqrt(3.0d0))-p/3.0d0 + root3=-dsqrt(capq)*(-dcos(rtta/3.0d0)+dsin(rtta/3.0d0)* + & dsqrt(3.0d0))-p/3.0d0 + else + capa=-dsign(1.0d0, capr)*(dabs(capr)+dsqrt(capr*capr- + & capq*capq*capq))**(1.0d0/3.0d0) + if (dabs(capa) .lt. 1.0d-6) then + capb=0.0 + else + capb=capq/capa + end if + root2 =(capa+capb)-p/3.0d0 + end if + cubicroot=root2 + return + end +c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine quadraticroots(a,b,c,root1,root2) + implicit none + double precision a,b,c,root1,root2,b24ac,q + + if(dabs(a).lt.1.0d-8)then + if(dabs(b).lt.1.0d-8)then + root1=-9999.0d0 + root2=-9999.0d0 + return + endif + root1=-c/b + root2=-9999.0d0 + return + endif + b24ac=b*b-4.0d0*a*c + if(b24ac.lt.0.0d0)then + root1=-9999.0d0 + root2=-9999.0d0 + return + endif +! q=-0.5d0*(b+dsign(1.0d0,b)*dsqrt(b24ac)) +! root1=q/a +! root2=c/q + root1=(-b-dsqrt(b24ac))/(2.0d0*a) + root2=(-b+dsqrt(b24ac))/(2.0d0*a) + return + end + + subroutine quadraticrootsbound(a,b,c, + & lower,upper,root,otherroot,iwrong) + implicit none + double precision a,b,c,lower,upper,root, + & otherroot + + integer iwrong +!iwrong=0, root is within (lower,upper) and otherroot is not +!iwrong=1, both root and otherroot are within (lower,upper) +!iwrong=2, both root and otherroot are real but outside of (lower, upper) +!iwrong=3, the equation bx+c=0 type, one root only +!iwrong=4, no real roots +!iwrong=5, invalid equation + + double precision b24ac,q + + if(a.eq.0.0d0)then + if(b.eq.0.0d0)then + root=-9999.0d0 + otherroot=-9999.0d0 + iwrong=5 + return + endif + root=-c/b + otherroot=-9999.0d0 + iwrong=3 + return + endif + + b24ac=b*b-4.0d0*a*c + if(b24ac.lt.0.0d0)then + root=-9999.0d0 + otherroot=-9999.0d0 + iwrong=4 + return + endif + q=-0.5d0*(b+dsign(1.0d0,b)*dsqrt(b24ac)) + root=c/q + otherroot=q/a + + if(root.ge.lower.and.root.le.upper)then + if(otherroot.ge.lower.and.otherroot.le.upper)then + iwrong=1 + else + iwrong=0 + endif + else + if(otherroot.ge.lower.and.otherroot.le.upper)then + b24ac=root + root=otherroot + otherroot=b24ac + iwrong=0 + else + iwrong=2 + endif + endif + return + end +c +c#################################################################### +c random number generator +c + double precision function ran2() + implicit none + integer im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv + double precision am,eps,rnmx +! parameter(im1=2147483563,im2=2147483399,am=1.0d0/dble(im1), +! &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1= +! &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2d-7, +! &rnmx=1.0d0-eps) + + parameter(im1=2147483563,im2=2147483399, + &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1= + &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab) + parameter(am=1.0d0/dble(im1),eps=1.2d-7, + &rnmx=1.0d0-eps) + + integer idum2,j,k,iv(ntab),iy,idum + save iv,iy,idum2,idum + data idum2/123456789/,iv/ntab*0/,iy/0/,idum/-1/ + + if(idum.le.0) then + idum=max0(-idum,1) + idum2=idum + do 11 j=ntab+8,1,-1 + k=idum/iq1 + idum=ia1*(idum-k*iq1)-k*ir1 + if(idum.lt.0)idum=idum+im1 + if(j.le.ntab)iv(j)=idum +11 continue + iy=iv(1) + end if + k=idum/iq1 + idum=ia1*(idum-k*iq1)-k*ir1 + if(idum.lt.0)idum=idum+im1 + k=idum2/iq2 + idum2=ia2*(idum2-k*iq2)-k*ir2 + if(idum2.lt.0) idum2=idum2+im2 + j=1+iy/ndiv + iy=iv(j)-idum2 + iv(j)=idum + if(iy.lt.1)iy=iy+imm1 + ran2=dmin1(am*dble(iy),rnmx) + return + end +c +c#################################################################### + double precision function beta(beta1,beta2) +c Returns the value of the Beta function B(u,v) +c + implicit double precision(a-h,l,o-z) + beta=dexp(gammln(beta1)+gammln(beta2)-gammln(beta1+beta2)) + return + end +c +! Logarithm of gamma function. +! Used by routine betai. +! Numerical Recipes, chapter 6.1. + double precision function gammln(xx) + implicit none + double precision xx + integer j + double precision cof(6) + double precision ser,stp,tmp,x,y + save cof,stp + data cof,stp/76.18009172947146d0,-86.50532032941677d0, + &24.01409824083091d0,-1.231739572450155d0,0.1208650973866179d-2, + &-0.5395239384953d-5,2.5066282746310005d0/ + + x=xx + y=x + tmp=x+5.5d0 + tmp=(x+0.5d0)*dlog(tmp)-tmp + ser=1.000000000190015d0 + do 11 j=1,6 + y=y+1.0d0 + ser=ser+cof(j)/y +11 continue + gammln=tmp+dlog(stp*ser/x) + return + end +c################################################################## +c +c This subroutine quadrat performs the transformation of 8 point +c Gaussian Quadrature in the interval (-1, 1) to any interval (x0, +c x1). +c + subroutine quadrat(x0, x1, abscis, weight, timeby) + implicit double precision(a-h,l,o-z) + dimension abscis(8), root(8), weight(8), weit(8) + +c + save root,weit + data(root(i),i=1,4)/0.18343464d0,0.52553241d0,0.79666648d0, + & 0.96028986d0/ + data(root(i),i=5,8)/-0.18343464d0,-0.52553241d0,-0.79666648d0, + & -0.96028986d0/ + data(weit(i),i=1,4)/0.36268378d0,0.31370665d0,0.22238103d0, + & 0.10122854d0/ + data(weit(i),i=5,8)/0.36268378d0,0.31370665d0,0.22238103d0, + & 0.10122854d0/ + + do 10 i = 1, 8 + abscis(i) = ((x1-x0)*root(i)+x1+x0)/2.0d0 + weight(i) = weit(i) +10 continue + timeby = (x1-x0)/2.0d0 + return + end +c#################################################################### +c random number generator +c + double precision function ran2_reset() + implicit none + integer im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv + double precision am,eps,rnmx +! parameter(im1=2147483563,im2=2147483399,am=1.0d0/dble(im1), +! &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1= +! &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2d-7, +! &rnmx=1.0d0-eps) + + parameter(im1=2147483563,im2=2147483399, + &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1= + &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab) + + parameter(am=1.0d0/dble(im1),eps=1.2d-7, + &rnmx=1.0d0-eps) + + + logical resetran2 + common /ran2reset/resetran2 + save /ran2reset/ + + integer idum2,j,k,iv(ntab),iy,idum + save iv,iy,idum2,idum + data idum2/123456789/,iv/ntab*0/,iy/0/,idum/-1/ + + if(resetran2.eqv..true..or.resetran2.eqv..TRUE.)then + idum2=123456789 + do j=1,ntab + iv(j)=0 + enddo + iy=0 + idum=-1 + endif + resetran2=.false. + + if(idum.le.0) then + idum=max0(-idum,1) + idum2=idum + do 11 j=ntab+8,1,-1 + k=idum/iq1 + idum=ia1*(idum-k*iq1)-k*ir1 + if(idum.lt.0) idum=idum+im1 + if(j.le.ntab) iv(j)=idum +11 continue + iy=iv(1) + end if + k=idum/iq1 + idum=ia1*(idum-k*iq1)-k*ir1 + if(idum.lt.0)idum=idum+im1 + k=idum2/iq2 + idum2=ia2*(idum2-k*iq2)-k*ir2 + if(idum2.lt.0) idum2=idum2+im2 + j=1+iy/ndiv + iy=iv(j)-idum2 + iv(j)=idum + if(iy.lt.1)iy=iy+imm1 + ran2_reset=dmin1(am*dble(iy),rnmx) + return + end +c +c#################################################################### +c random number generator +c + double precision function cpran2_reset() + implicit none + integer im1,im2,imm1,ia1,ia2,iq1,iq2,ir1,ir2,ntab,ndiv + double precision am,eps,rnmx +! parameter(im1=2147483563,im2=2147483399,am=1.0d0/dble(im1), +! &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1= +! &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab,eps=1.2d-7, +! &rnmx=1.0d0-eps) + + parameter(im1=2147483563,im2=2147483399, + &imm1=im1-1,ia1=40014,ia2=40692,iq1=53668,iq2=52774,ir1= + &12211,ir2=3791,ntab=32,ndiv=1+imm1/ntab) + + parameter(am=1.0d0/dble(im1),eps=1.2d-7, + &rnmx=1.0d0-eps) + + logical resetran2 + common /cpran2reset/resetran2 + save /cpran2reset/ + + integer idum2,j,k,iv(ntab),iy,idum + save iv,iy,idum2,idum + data idum2/123456789/,iv/ntab*0/,iy/0/,idum/-1/ + + if(resetran2.eqv..true..or.resetran2.eqv..TRUE.)then + idum2=123456789 + do j=1,ntab + iv(j)=0 + enddo + iy=0 + idum=-1 + endif + resetran2=.false. + + if(idum.le.0) then + idum=max0(-idum,1) + idum2=idum + do 11 j=ntab+8,1,-1 + k=idum/iq1 + idum=ia1*(idum-k*iq1)-k*ir1 + if(idum.lt.0) idum=idum+im1 + if(j.le.ntab) iv(j)=idum +11 continue + iy=iv(1) + end if + k=idum/iq1 + idum=ia1*(idum-k*iq1)-k*ir1 + if(idum.lt.0)idum=idum+im1 + k=idum2/iq2 + idum2=ia2*(idum2-k*iq2)-k*ir2 + if(idum2.lt.0) idum2=idum2+im2 + j=1+iy/ndiv + iy=iv(j)-idum2 + iv(j)=idum + if(iy.lt.1)iy=iy+imm1 + cpran2_reset=dmin1(am*dble(iy),rnmx) + return + end +c#################################################################### +c This subroutine calculates R2 and root mean square error and index of +cagreement + subroutine rsq_rms(y10,y20,n0,rsq,rms,agrind) + implicit double precision (a-h,l,o-z) + dimension y10(n0),y20(n0),y1(n0),y2(n0) + fn9999=-9999.0d0 + tiny=1.0d-7 + n=0 + do i=1,n0 + if(dabs(y10(i)-fn9999).gt.tiny.and. + &dabs(y20(i)-fn9999).gt.tiny)then + n=n+1 + y1(n)=y10(i) + y2(n)=y20(i) + endif + enddo + sum=0.0d0 + do 10 i=1,n + sum=sum+(y1(i)-y2(i))*(y1(i)-y2(i)) +10 continue + rms=dsqrt(sum/dble(n)) + ymean1=0.0d0 + ymean2=0.0d0 + do 20 i=1,n + ymean1=ymean1+y1(i) + ymean2=ymean2+y2(i) +20 continue + ymean1=ymean1/dble(n) + ymean2=ymean2/dble(n) + sum1=0.0d0 + sum2=0.0d0 + sum3=0.0d0 + sum4=0.0d0 + sum5=0.0d0 + do 30 i=1,n + sum1=(y1(i)-ymean1)*(y2(i)-ymean2)+sum1 + sum2=(y1(i)-ymean1)*(y1(i)-ymean1)+sum2 + sum3=(y2(i)-ymean2)*(y2(i)-ymean2)+sum3 + sum4=(y1(i)-y2(i))*(y1(i)-y2(i))+sum4 + sum5=(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))* + &(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))+sum5 +30 continue + if((sum2*sum3).eq.0.0d0)then + rsq=-9999.0d0 + else + rsq=sum1/dsqrt(sum2*sum3) + rsq=rsq*rsq + endif + if(sum5.eq.0.0d0)then + agrind=-9999.0d0 + else + agrind=1.0d0-sum4/sum5 + endif + return + end +c#################################################################### + subroutine extrsq_rms(y10,y20,n0,nparams,rsq,rms,agrind, + &rmse_norm,rmse_perc,aic,aicc) + implicit double precision (a-h,l,o-z) + dimension y10(n0),y20(n0),y1(n0),y2(n0) + fn9999=-9999.0d0 + tiny=1.0d-7 + n=0 + do i=1,n0 + if(dabs(y10(i)-fn9999).gt.tiny.and. + &dabs(y20(i)-fn9999).gt.tiny)then + n=n+1 + y1(n)=y10(i) + y2(n)=y20(i) + endif + enddo + ymin=y1(1) + ymax=y1(1) + do i=2,n + if(y1(i).lt.ymin)ymin=y1(i) + if(y1(i).gt.ymax)ymax=y1(i) + enddo + sum=0.0d0 + rmse_perc=0.0d0 + do 10 i=1,n + sum=sum+(y1(i)-y2(i))*(y1(i)-y2(i)) + rmse_perc=rmse_perc+(y1(i)-y2(i))*(y1(i)-y2(i))/(y2(i)*y2(i)) +10 continue + rms=dsqrt(sum/dble(n)) + if(nparams.gt.0)then + aic=dble(n)*dlog(rms*rms)+2.0d0*dble(nparams) + aicc=aic+2.0d0*dble(nparams*(nparams+1))/dble(n-nparams-1) + else + aic=-9999.0d0 + aicc=-9999.0d0 + endif + rmse_norm=rms/(ymax-ymin) + rmse_perc=100.0d0*dsqrt(rmse_perc/dble(n)) + ymean1=0.0d0 + ymean2=0.0d0 + do 20 i=1,n + ymean1=ymean1+y1(i) + ymean2=ymean2+y2(i) +20 continue + ymean1=ymean1/dble(n) + ymean2=ymean2/dble(n) + sum1=0.0d0 + sum2=0.0d0 + sum3=0.0d0 + sum4=0.0d0 + sum5=0.0d0 + do 30 i=1,n + sum1=(y1(i)-ymean1)*(y2(i)-ymean2)+sum1 + sum2=(y1(i)-ymean1)*(y1(i)-ymean1)+sum2 + sum3=(y2(i)-ymean2)*(y2(i)-ymean2)+sum3 + sum4=(y1(i)-y2(i))*(y1(i)-y2(i))+sum4 + sum5=(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))* + &(dabs(y2(i)-ymean1)+dabs(y1(i)-ymean1))+sum5 +30 continue + if((sum2*sum3).eq.0.0d0)then + rsq=-9999.0d0 + else + rsq=sum1/dsqrt(sum2*sum3) + rsq=rsq*rsq + endif + if(sum5.eq.0.0d0)then + agrind=-9999.0d0 + else + agrind=1.0d0-sum4/sum5 + endif + return + end +!#################################################################### + subroutine stdmean(nsamp,xvar,std,fmean) + implicit none + integer nsamp,j + double precision xvar(nsamp),std,fmean + fmean=0.0d0 + do j=1,nsamp + fmean=fmean+xvar(j) + enddo + fmean=fmean/dble(nsamp) + std=0.0d0 + do j=1,nsamp + std=std+(xvar(j)-fmean)*(xvar(j)-fmean) + enddo + std=dsqrt(std/dble(nsamp-1)) + end +c####################################################################### + subroutine reinitialization(x0min,x0likely, + & x0max,x0new,minterval) + implicit none + double precision x0min,x0likely,x0max,x0new,zrand, + & delta1,delta2,ran2_reset + integer minterval,iwhichone + save + intrinsic dble,dabs + if(x0likely.le.x0min.or.x0likely.ge.x0max)then + x0new=(x0min+x0max)/2.0d0+ + & (x0max-x0min)*(ran2_reset()-0.5d0) + else + delta1=(x0likely-x0min)/dble(minterval) + delta2=(x0max-x0likely)/dble(minterval) + zrand=ran2_reset() + iwhichone=idint(dble(2*minterval)*zrand)+1 + if(iwhichone.gt.(2*minterval))iwhichone=minterval+1 + zrand=ran2_reset() + if(iwhichone.le.minterval)then + x0new=x0likely-(x0likely-x0min + & -delta1*dble(iwhichone-1))*zrand + else + x0new=x0likely+ + & zrand*delta2*dble(iwhichone-minterval) + endif + endif + return + end +c####################################################################### + + double precision function whatismedian(n,x) + implicit none + integer n,i,j + double precision x(n),copyx(n),term + + do i=1,n + copyx(i)=x(i) + enddo + do i=1,n + do j=i+1,n + if(copyx(j).lt.copyx(i))then + term=copyx(i) + copyx(i)=copyx(j) + copyx(j)=term + endif + enddo + enddo + if(mod(n,2).eq.0)then + whatismedian=(copyx(n/2)+copyx(n/2+1))/2.0d0 + else + whatismedian=copyx((n-1)/2+1) + endif + return + end +!------------------------------------------------ + subroutine y_aPLUSbxrsq(npoints,x,y,a,b,rsq) + implicit none +!fit for y=a+bx + integer npoints + double precision x(npoints),y(npoints),a,b,rsq,rms,agrind + integer i + double precision fn9999,tiny,ycal(npoints) + parameter(fn9999=-9999.0d0,tiny=1.0d-7) + + call y_aPLUSbx(npoints,x,y,a,b) + do i=1,npoints + ycal(i)=fn9999 + if(dabs(x(i)-fn9999).gt.tiny)ycal(i)=a+b*x(i) + enddo + call rsq_rms(y,ycal,npoints,rsq,rms,agrind) + return + end +!------------------------------------------------ + subroutine y_aPLUSbx(npoints0,x0,y0,a,b) + implicit none +!fit for y=a+bx + integer npoints0 + double precision x0(npoints0),y0(npoints0),a,b + integer i,npoints + double precision xmean,ymean,lxx,lyy,lxy,fn9999,tiny, + &x(npoints0),y(npoints0) + parameter(fn9999=-9999.0d0,tiny=1.0d-7) + + npoints=0 + do i=1,npoints0 + if(dabs(x0(i)-fn9999).gt.tiny.and. + &dabs(y0(i)-fn9999).gt.tiny)then + npoints=npoints+1 + x(npoints)=x0(i) + y(npoints)=y0(i) + endif + enddo + xmean=0.0d0 + ymean=0.0d0 + do i=1,npoints + xmean=xmean+x(i) + ymean=ymean+y(i) + enddo + xmean=xmean/dble(npoints) + ymean=ymean/dble(npoints) + lxx=0.0d0 + lyy=0.0d0 + lxy=0.0d0 + do i=1,npoints + lxx=lxx+(x(i)-xmean)**2 + lyy=lyy+(y(i)-ymean)**2 + lxy=lxy+(x(i)-xmean)*(y(i)-ymean) + enddo + if(lxx.ne.0.0d0)then + b=lxy/lxx + a=ymean-b*xmean + else + b=-9999.0d0 + a=-9999.0d0 + endif + return + end +!---------------------------------------------- + subroutine y_bx(npoints0,x0,y0,b) + implicit none +!fit for y=bx + integer npoints0 + double precision x0(npoints0),y0(npoints0),b + integer i,npoints + double precision lxx,lxy,fn9999,tiny, + &x(npoints0),y(npoints0) + parameter(fn9999=-9999.0d0,tiny=1.0d-7) + + npoints=0 + do i=1,npoints0 + if(dabs(x0(i)-fn9999).gt.tiny.and. + &dabs(y0(i)-fn9999).gt.tiny)then + npoints=npoints+1 + x(npoints)=x0(i) + y(npoints)=y0(i) + endif + enddo + lxx=0.0d0 + lxy=0.0d0 + do i=1,npoints + lxx=lxx+x(i)*x(i) + lxy=lxy+x(i)*y(i) + enddo + b=lxy/lxx + return + end +!====================================================== + subroutine linearsys_dim2(a,b,c,d,e,f,x,y) + implicit none +!solve for x and y in +! ax+by=c +! dx+ey=f +!avoiding overflow + double precision a,b,c,d,e,f,x,y + if(dabs(a).gt.dabs(b).and.dabs(a).gt.dabs(d) + & .and.dabs(a).gt.dabs(e))then + y=(f-c*d/a)/(e-b*d/a) + x=c/a-b*y/a + else + if(dabs(b).gt.dabs(a).and.dabs(b).gt.dabs(d) + & .and.dabs(b).gt.dabs(e))then + x=(f-c*e/b)/(d-a*e/b) + y=c/b-a*x/b + else + if(dabs(d).gt.dabs(a).and.dabs(d).gt.dabs(b) + & .and.dabs(d).gt.dabs(e))then + y=(c-a*f/d)/(b-a*e/d) + x=f/d-e*y/d + else + x=(c-b*f/e)/(a-b*d/e) + y=f/e-d*x/e + endif + endif + endif + return + end +!=========================================================== + double precision function crosscorrel(nsamp,var1,var2, + & istart,iend,ndelay) + implicit none + integer nsamp,istart,iend,ndelay,i,j + double precision var1(1:nsamp),var2(istart:iend),var1mean, + & var2mean,sxy,sxx,syy + var1mean=0.0d0 + var2mean=0.0d0 + j=0 + do i=1,nsamp + if((i-ndelay).ge.istart.and.(i-ndelay).le.iend)then + j=j+1 + var1mean=var1mean+var1(i) + var2mean=var2mean+var2(i-ndelay) + endif + enddo + var1mean=var1mean/dble(j) + var2mean=var2mean/dble(j) + sxy=0.0d0 + sxx=0.0d0 + syy=0.0d0 + do i=1,nsamp + if((i-ndelay).ge.istart.and.(i-ndelay).le.iend)then + sxy=sxy+(var1(i)-var1mean)*(var2(i-ndelay)-var2mean) + sxx=sxx+(var1(i)-var1mean)*(var1(i)-var1mean) + syy=syy+(var2(i-ndelay)-var2mean)*(var2(i-ndelay)-var2mean) + endif + enddo + crosscorrel=sxy/dsqrt(sxx*syy) + return + end +!=========================================================== + double precision function cumutailsum(n,time,starttime,endtime, + &xtosum,threshold,iaboveorbelow) + implicit none + integer n,i,j,iaboveorbelow,iabove,ibelow + double precision time(n),starttime,endtime,xtosum(n),agap, + &threshold(n) + parameter(iabove=1,ibelow=-1) + agap=-9999.0d0 + cumutailsum=0.0d0 + do i=1,n + if(time(i).ge.starttime.and.time(i).lt.endtime)then + if(dabs(xtosum(i)-agap).gt.1.0d-5)then + if(iaboveorbelow.eq.iabove)then + if(xtosum(i).ge.threshold(i)) + &cumutailsum=cumutailsum+xtosum(i) + endif + if(iaboveorbelow.eq.ibelow)then + if(xtosum(i).le.threshold(i)) + &cumutailsum=cumutailsum+xtosum(i) + endif + endif + endif + enddo + return + end +!---------------------------------------------------------------- + double precision function ran1(idum) + INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV + double precision AM,EPS,RNMX + PARAMETER (IA=16807,IM=2147483647,AM=1.d0/dble(IM), + &IQ=127773,IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-7, + &RNMX=1.0d0-EPS) + INTEGER j,k,iv(NTAB),iy + SAVE iv,iy + DATA iv /NTAB*0/, iy /0/ + if (idum.le.0.or.iy.eq.0) then + idum=max(-idum,1) + do 11 j=NTAB+8,1,-1 + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + if (j.le.NTAB) iv(j)=idum +11 continue + iy=iv(1) + endif + k=idum/IQ + idum=IA*(idum-k*IQ)-IR*k + if (idum.lt.0) idum=idum+IM + j=1+iy/NDIV + iy=iv(j) + iv(j)=idum + ran1=dmin1(AM*dble(iy),RNMX) + return + END diff --git a/dataassim/math/othersupmath/targetgridsampling.f b/dataassim/math/othersupmath/targetgridsampling.f new file mode 100644 index 0000000..312c335 --- /dev/null +++ b/dataassim/math/othersupmath/targetgridsampling.f @@ -0,0 +1,71 @@ + subroutine targetgridsampling(sampfunc,nparams0, + & msect0,bestguess,yatguess,bmax0,bmin0,iflag) + implicit none +! +!iflag(i)=0, fix bestguess(i) at the input value +!iflag(i)=1, bestguess(i) is not provided an input value. use grid search + integer nparams0,msect0,iflag(nparams0) + double precision bestguess(nparams0), + & bmax0(nparams0),bmin0(nparams0), + & params(nparams0,msect0+1),yatguess, + & beta(nparams0),fatbeta,bmax(nparams0),bmin(nparams0) + integer i,j,k,n,msect,m,nparams,itag(nparams0) + double precision tiny,x1,delta,eps + parameter(eps=1.0d-8) + external sampfunc +! + nparams=0 + do i=1,nparams0 + if(iflag(i).eq.1)then + nparams=nparams+1 + bmax(nparams)=bmax0(i) + bmin(nparams)=bmin0(i) + itag(nparams)=i + endif + enddo + msect=msect0 + do i=1,nparams + tiny=(bmax(i)-bmin(i))*eps + x1=(bmax(i)-bmin(i)-2.0d0*tiny)/dble(msect) + params(i,1)=bmin(i)+tiny + do j=2,msect+1 + params(i,j)=params(i,j-1)+x1 + params(i,j)=dmax1(params(i,j),bmin(i)) + params(i,j)=dmin1(params(i,j),bmax(i)) + enddo + enddo + msect=msect+1 + yatguess=1.0d+100 + do i=1,msect**nparams + do j=1,nparams +!the size of the larger repeated unit is msect**(nparams-j+1) + k=i/(msect**(nparams-j+1)) + n=mod(i,(msect**(nparams-j+1))) + if(n.eq.0)k=k-1 +!k is the number of repeated units before i (not include the unit i is in) + k=i-k*(msect**(nparams-j+1)) +!now k is the position in the larger repeated unit +!the size of the smaller repeated unit is (msect**(nparams-j+1))/msect + m=(msect**(nparams-j+1))/msect + n=k/m + if(mod(k,m).ne.0)n=n+1 + beta(j)=params(j,n) + enddo + do j=nparams,1,-1 + beta(itag(j))=beta(j) + enddo + do j=1,nparams0 + if(iflag(j).eq.0)then + beta(j)=bestguess(j) + endif + enddo + call sampfunc(nparams0,beta,fatbeta) + if(fatbeta.lt.yatguess)then + yatguess=fatbeta + do j=1,nparams0 + bestguess(j)=beta(j) + enddo + endif + enddo + return + end diff --git a/dataassim/math/othersupmath/test_t.f b/dataassim/math/othersupmath/test_t.f new file mode 100644 index 0000000..680e4cb --- /dev/null +++ b/dataassim/math/othersupmath/test_t.f @@ -0,0 +1,248 @@ + subroutine test_t(nsamp1,samp1,nsamp2,samp2,alpha, + &ntail,fmean1,std1,fmean2,std2,isitdifferent) + implicit none +!----------------Inputs-------------------------- +!nsamp: the number of samples +!samp: the sample values +!alpha: the significance level to consider (e.g. 0.05. 0.01) +!ntail: ntail = 1, one tail (one mean is significantly larger (smaller) than the other mean +! ntail = 2, two tails (the two means are significantly different from each other) +!----------------Outputs--------------------------- +!fmean and std: sample means and standard deviations +!isitdifferent=0, not different +! =1, different + integer nsamp1,nsamp2,ntail,isitdifferent,ndegfree + double precision samp1(nsamp1),samp2(nsamp2),alpha, + &fmean1,std1,fmean2,std2,Sign_Level,student_t,t,t0,s0 + + call stdmean(nsamp1,samp1,std1,fmean1) + call stdmean(nsamp2,samp2,std2,fmean2) + ndegfree=nsamp1+nsamp2-2 + s0=dble((nsamp1-1))*std1*std1+ + &dble((nsamp2-1))*std2*std2 + s0=dsqrt(s0/dble(ndegfree)) + t=(fmean1-fmean2)/ + &(s0*dsqrt(1.0d0/dble(nsamp1)+1.0d0/dble(nsamp2))) + if(ntail.eq.1)then + Sign_Level=1.0d0-alpha*2.0d0 + else + Sign_Level=1.0d0-alpha/2.0d0 + endif + t0=student_t(ndegfree,Sign_Level) + isitdifferent=0 + if(dabs(t).gt.t0)isitdifferent=1 + return + end +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + double precision function student_t(ndegfree,Sign_Level) +! +! the integration from -student_t to student_t =Sign_Level +! +! The student-t is calculated for a given degree of freedom +! and at a certain significance level. +! The following relation holds: +! Sign_Level = 1 - IncompleteBetaFunction( x, a, b ) +! x = Df / ( Df + student_t^2 ) +! a = Df / 2 +! b = 0.50 +! We need to solve the above equation for x (or student_t). +! Routines from Numerical Recipes are used for that. + + implicit none +! Input variables. + integer ndegfree +! Degree of freedom + double precision Sign_Level +! Significance level + +! Functions and parameters. + double precision zbrent,tobesolved + double precision x1,x2,b,eps + parameter(x1=0.0d0,x2=1.0d0,b=0.50d0,eps=1.0d-7) + +! Various parameters: x1, x2 bracket the root, given with +! accuracy eps. + +! Local + double precision Df,a +! Degrees of freedom +! a = 0.50 * Df + + external zbrent,tobesolved + + Df = dble(ndegfree) + a = 0.50d0 * Df + student_t=zbrent(tobesolved,a,b,Sign_Level,x1,x2,eps) + student_t = dsqrt( Df/student_t - Df) + end function student_t + + double precision function tobesolved( a, b, c, x ) + implicit none + double precision a, b, c, x +! a, b, c: parameters to the function +! x: variable + double precision betai + external betai +! Incomplete beta function. + tobesolved = betai(a,b,x) - 1.0d0 + c + end function tobesolved + +! The rest of this file comes from Numerical Recipes. +! Function zbrent has been modified slightly +! (variables aaa, bbb, ccc have been intoduced). + +! Brent's method for solving the equation +! func(a,b,c,x)=0 for x, where a,b,c parameters. +! Root is bracketed by x1 and x2. +! Root is returned to varable zbrent with +! accuracy tol. + + double precision function zbrent(func,aaa,bbb,ccc,x1,x2,tol) + implicit none + integer ITMAX,iter + double precision tol,x1,x2,func,EPS, + & a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm, + & aaa,bbb,ccc + parameter(ITMAX=5000) + parameter(EPS=3.0d-8) + external func + + a=x1 + b=x2 + + fa=func(aaa,bbb,ccc,a) + fb=func(aaa,bbb,ccc,b) + if((fa.gt.0.0d0.and.fb.gt.0.0d0).or. + & (fa.lt.0.0d0.and.fb.lt.0.0d0))then + write(*,*) 'root must be bracketed for zbrent' + endif + c=b + fc=fb + do 11 iter=1,ITMAX + if((fb.gt.0.0d0.and.fc.gt.0.0d0).or. + & (fb.lt.0.0d0.and.fc.lt.0.0d0))then + c=a + fc=fa + d=b-a + e=d + endif + if(dabs(fc).lt.dabs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + endif + tol1=2.0d0*EPS*dabs(b)+0.5d0*tol + xm=0.5d0*(c-b) + if(dabs(xm).le.tol1.or.fb.eq.0.0d0)then + zbrent=b + return + endif + if(dabs(e).ge.tol1.and.dabs(fa).gt.dabs(fb))then + s=fb/fa + if(a.eq.c) then + p=2.0d0*xm*s + q=1.0d0-s + else + q=fa/fc + r=fb/fc + p=s*(2.0d0*xm*q*(q-r)-(b-a)*(r-1.0d0)) + q=(q-1.0d0)*(r-1.0d0)*(s-1.0d0) + endif + if(p.gt.0.0d0)q=-q + p=dabs(p) + if(2.0d0*p.lt.dmin1(3.0d0*xm*q-dabs(tol1*q),dabs(e*q)))then + e=d + d=p/q + else + d=xm + e=d + endif + else + d=xm + e=d + endif + a=b + fa=fb + if(dabs(d).gt.tol1)then + b=b+d + else + b=b+dsign(tol1,xm) + endif + fb=func(aaa,bbb,ccc,b) +11 continue + write(*,*) 'zbrent exceeding maximum iterations' + zbrent=b + return + end function zbrent + +! Incomplete beta function. + double precision function betai(a,b,x) + double precision a,b,x +!U USES betacf,gammln + double precision bt + double precision betacf,gammln + external betacf,gammln + + if(x.lt.0.0d0.or.x.gt.1.0d0)then + write(*,*) 'bad argument x in betai' + endif + if(x.eq.0.0d0.or.x.eq.1.0d0)then + bt=0.0d0 + else + bt=dexp(gammln(a+b)-gammln(a)-gammln(b)+ + & a*dlog(x)+b*dlog(1.0d0-x)) + endif + if(x.lt.(a+1.0d0)/(a+b+2.0d0))then + betai=bt*betacf(a,b,x)/a + return + else + betai=1.0d0-bt*betacf(b,a,1.0d0-x)/b + return + endif + end function betai + + ! Continued fraction evaluation. +! Used by routine betai. + ! Numerical Recipes, chapter 6.4. + double precision function betacf(a,b,x) + implicit none + integer MAXIT,m,m2 + double precision a,b,x,EPS,FPMIN + double precision aa,c,d,del,h,qab,qam,qap + parameter(MAXIT = 100) + parameter(EPS=3.0d-7,FPMIN=1.0d-30) + + qab=a+b + qap=a+1.0d0 + qam=a-1.0d0 + c=1.0d0 + d=1.0d0-qab*x/qap + if(dabs(d).lt.FPMIN)d=FPMIN + d=1.0d0/d + h=d + do 11 m=1,MAXIT + m2=2*m + aa=dble(m)*(b-dble(m))*x/((qam+dble(m2))*(a+dble(m2))) + d=1.0d0+aa*d + if(dabs(d).lt.FPMIN)d=FPMIN + c=1.0d0+aa/c + if(dabs(c).lt.FPMIN)c=FPMIN + d=1.0d0/d + h=h*d*c + aa=-(a+dble(m))*(qab+dble(m))*x/((a+dble(m2))*(qap+dble(m2))) + d=1.0d0+aa*d + if(dabs(d).lt.FPMIN)d=FPMIN + c=1.0d0+aa/c + if(dabs(c).lt.FPMIN)c=FPMIN + d=1.0d0/d + del=d*c + h=h*del + if(dabs(del-1.0d0).lt.EPS)goto 1 +11 continue + write(*,*) 'a or b too big, or MAXIT too small in betacf' +1 betacf=h + return + end function betacf diff --git a/dataassim/math/othersupmath/uniformgridsampling.f b/dataassim/math/othersupmath/uniformgridsampling.f new file mode 100644 index 0000000..8157e11 --- /dev/null +++ b/dataassim/math/othersupmath/uniformgridsampling.f @@ -0,0 +1,52 @@ + subroutine uniformgridsampling(sampfunc,nparams, + & msect0,bestguess,yatguess,bmax,bmin) + implicit none +! + integer nparams,msect0,ihowsamp + double precision bestguess(nparams),guessconfid0, + & bmax(nparams),bmin(nparams),params(nparams,msect0+1), + & guessconfid,yatguess,beta(nparams),fatbeta + integer i,nright,nleft,j,k,n,msect,m + double precision tiny,x1,delta,eps + parameter(eps=1.0d-9) + external sampfunc +! + msect=msect0 + do i=1,nparams + tiny=(bmax(i)-bmin(i))*eps + x1=(bmax(i)-bmin(i)-2.0d0*tiny)/dble(msect) + params(i,1)=bmin(i)+tiny + do j=2,msect+1 + params(i,j)=params(i,j-1)+x1 + params(i,j)=dmax1(params(i,j),bmin(i)) + params(i,j)=dmin1(params(i,j),bmax(i)) + enddo + enddo + msect=msect+1 + yatguess=1.0d+100 + do i=1,msect**nparams + do j=1,nparams +!the size of the larger repeated unit is msect**(nparams-j+1) + k=i/(msect**(nparams-j+1)) + n=mod(i,(msect**(nparams-j+1))) + if(n.eq.0)k=k-1 +!k is the number of repeated units before i (not include the unit i is in) + k=i-k*(msect**(nparams-j+1)) +!now k is the position in the larger repeated unit +!the size of the smaller repeated unit is (msect**(nparams-j+1))/msect + m=(msect**(nparams-j+1))/msect + n=k/m + if(mod(k,m).ne.0)n=n+1 + beta(j)=params(j,n) + enddo + call sampfunc(nparams,beta,fatbeta) + if(fatbeta.lt.yatguess)then + yatguess=fatbeta + do j=1,nparams + bestguess(j)=beta(j) + enddo + endif + enddo +1 format(1x,i5,4f15.8) + return + end diff --git a/dataassim/math/othersupmath/univparser.f b/dataassim/math/othersupmath/univparser.f new file mode 100644 index 0000000..d1ba308 --- /dev/null +++ b/dataassim/math/othersupmath/univparser.f @@ -0,0 +1,34 @@ + subroutine univparser(longchar,nmax,vars,n) +!convert a line of characters that consists of an array of real numbers into a +!vector of real numbers + implicit none + integer nmax,n + double precision vars(nmax+100) + character longchar*(*),astring*50,c*1 + integer i,pos1,pos2,ispartnum,leng,numchar,ierr +! + n=0 + leng=len(longchar) + i=0 +10 i=i+1 + if(i.gt.leng)return + c=longchar(i:i) + if(ispartnum(c).eq.0)goto 10 + pos1=i-1 +20 i=i+1 + c=longchar(i:i) + if(ispartnum(c).eq.1)then + if(i.lt.leng)goto 20 + i=i+1 + endif + numchar=i-1-(pos1+1)+1 + if(numchar.gt.0)then + n=n+1 + astring=longchar((pos1+1):(i-1)) + call extCharToFloatNum(numchar,astring,vars(n),ierr) + endif + if(i.ge.leng)return + pos1=i + goto 20 + return + end subroutine univparser diff --git a/dataassim/math/othersupmath/vectorrotation.f b/dataassim/math/othersupmath/vectorrotation.f new file mode 100644 index 0000000..3c715a9 --- /dev/null +++ b/dataassim/math/othersupmath/vectorrotation.f @@ -0,0 +1,15 @@ + subroutine vectorrotation(vectold,tranmatrix,vectnew) + implicit none +!transform the three components of a vector from an old coordinate +!system to an new coordinate system defined by the rotation matrix tranmatrix +!tranmatrix(i,j): ith row, jth column + double precision vectold(3),tranmatrix(3,3),vectnew(3) + integer i,j + do i=1,3 + vectnew(i)=0.0d0 + do j=1,3 + vectnew(i)=vectnew(i)+ + & tranmatrix(i,j)*vectold(j) + enddo + enddo + end subroutine vectorrotation diff --git a/dataassim/math/specialfuncs/odr_recthypb.f b/dataassim/math/specialfuncs/odr_recthypb.f new file mode 100644 index 0000000..e31093c --- /dev/null +++ b/dataassim/math/specialfuncs/odr_recthypb.f @@ -0,0 +1,274 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +! + subroutine odr_recthypb(npoints,nparams,yobs,xobs, + & a,b,c,d,root,der_root,fmax,rms,INFO) + implicit none +c +C ODRPACK ARGUMENT DEFINITIONS +C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE +C ==> N NUMBER OF OBSERVATIONS +C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C <==> BETA FUNCTION PARAMETERS +C ==> Y RESPONSE VARIABLE +C ==> LDY LEADING DIMENSION OF ARRAY Y +C ==> X EXPLANATORY VARIABLE +C ==> LDX LEADING DIMENSION OF ARRAY X +C ==> WE "EPSILON" WEIGHTS +C ==> LDWE LEADING DIMENSION OF ARRAY WE +C ==> LD2WE SECOND DIMENSION OF ARRAY WE +C ==> WD "DELTA" WEIGHTS +C ==> LDWD LEADING DIMENSION OF ARRAY WD +C ==> LD2WD SECOND DIMENSION OF ARRAY WD +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> JOB TASK TO BE PERFORMED +C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS +C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR +C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION +C ==> PARTOL PARAMETER CONVERGENCE CRITERION +C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS +C ==> IPRINT PRINT CONTROL +C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS +C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS +C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA +C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA +C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD +C ==> SCLB SCALE VALUES FOR PARAMETERS BETA +C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE +C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD +C <==> WORK DOUBLE PRECISION WORK VECTOR +C ==> LWORK DIMENSION OF VECTOR WORK +C <== IWORK INTEGER WORK VECTOR +C ==> LIWORK DIMENSION OF VECTOR IWORK +C <== INFO STOPPING CONDITION + +C PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER +C MAXN MAXIMUM NUMBER OF OBSERVATIONS +C MAXM MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C MAXNP MAXIMUM NUMBER OF FUNCTION PARAMETERS +C MAXNQ MAXIMUM NUMBER OF RESPONSES PER OBSERVATION + +C PARAMETER DECLARATIONS AND SPECIFICATIONS + INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ + PARAMETER (MAXM=25,MAXN=10000,MAXNP=30,MAXNQ=1, + + LDY=MAXN,LDX=MAXN, + + LDWE=1,LD2WE=1,LDWD=1,LD2WD=1, + + LDIFX=MAXN,LDSTPD=1,LDSCLD=1, + + LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + + + 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP + + + 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + + + 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ, + + LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM)) +C VARIABLE DECLARATIONS + INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N, + + NDIGIT,NP,NQ + INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK) + DOUBLE PRECISION PARTOL,SSTOL,TAUFAC + DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM), + + STPB(MAXNP),STPD(LDSTPD,MAXM), + + WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ), + + WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ) +c + integer npoints,i1,i2,i3,i4,i5,iwrong,nparams + double precision yobs(npoints),xobs(npoints), + & a,b,c,d,root,der_root,fmax,ypred(npoints),rms, + & rsq,agrind + + EXTERNAL FCN_rhb +c +C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS + WE(1,1,1) = -1.0D0 + WD(1,1,1) = -1.0D0 + IFIXB(1) = -1 +! IFIXX(1,1) = -1 +! JOB = 00023 + JOB=43 + NDIGIT = -1 + TAUFAC = -1.0D0 + SSTOL = -1.0D0 + PARTOL = -1.0D0 + MAXIT = -1 +! IPRINT = -1 + IPRINT=0 + LUNERR = -1 + LUNRPT = -1 + STPB(1) = -1.0D0 + STPD(1,1) = -1.0D0 + SCLB(1) = -1.0D0 + SCLD(1,1) = -1.0D0 + + MAXIT = 200000 +C SET UP ODRPACK REPORT FILES + LUNERR = 107 + LUNRPT = 108 +c + N=npoints + NP=nparams + M=1 + NQ=1 + BETA(1)=a + BETA(2)=b + BETA(3)=c + if(NP.eq.4)BETA(4)=d + + do I=1,N + X(I,1)=xobs(I) + Y(I,1)=yobs(I) + enddo + NQ=1 + +C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX + DO 10 I=1,N + DO 15 J=1, M + IFIXX(I,J) = 1 +15 CONTINUE +10 CONTINUE +60 CALL DODRC(FCN_rhb, + + N,M,NP,NQ, + + BETA, + + Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, + + SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, + + SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + i1=mod(INFO,10) + i2=(mod(INFO,100)-i1)/10 + i3=(mod(INFO,1000)-mod(INFO,100))/100 + i4=(mod(INFO,10000)-mod(INFO,1000))/1000 + i5=(INFO-mod(INFO,10000))/10000 + a=BETA(1) + b=BETA(2) + c=BETA(3) + if(NP.eq.4)then + d=BETA(4) + do I=1,N + call fnonrecthypb(a,b,c,d,xobs(I),ypred(I), + & iwrong) + if(iwrong.eq.1)then + INFO=6 + return + endif + enddo + call indices_fnonrecthypb(a,b,c,d,root, + & der_root,fmax,iwrong) + if(iwrong.eq.1)then + INFO=6 + return + endif + else + do I=1,N + call recthypb(a,b,c,xobs(I),ypred(I)) + enddo + call indices_frecthypb(a,b,c,root, + & der_root,fmax) + endif + call rsq_rms(yobs,ypred,N,rsq,rms,agrind) + return + END +c + SUBROUTINE FCN_rhb(N,M,NP,NQ, + + LDN,LDM,LDNP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,F,FJACB,FJACD, + + ISTOP) + implicit none +C SUBROUTINE ARGUMENTS +C ==> N NUMBER OF OBSERVATIONS +C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N +C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M +C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP +C ==> BETA CURRENT VALUES OF PARAMETERS +C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED +C <== F PREDICTED FUNCTION VALUES +C <== FJACB JACOBIAN WITH RESPECT TO BETA +C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA +C <== ISTOP STOPPING CONDITION, WHERE +C 0 MEANS CURRENT BETA AND X+DELTA WERE +C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY +C 1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES +C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE +C -1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD STOP + +C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE: + INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ + DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M) + INTEGER IFIXB(NP),IFIXX(LDIFX,M) +C OUTPUT ARGUMENTS: + DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) + double precision a,b,c,d,x,da,db,dc,dd,dx,yvalue + integer iwrong + +C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM +c +! + IF (MOD(IDEVAL,10).GE.1) THEN + DO 110 L = 1,NQ + DO 100 I = 1,N + a=BETA(1) + b=BETA(2) + c=BETA(3) + x=XPLUSD(I,1) + if(NP.eq.4)then + d=BETA(4) + call fnonrecthypb(a,b,c,d,x,yvalue,iwrong) + if(iwrong.eq.1)then + ISTOP=1 + return + endif + else + call recthypb(a,b,c,x,yvalue) + endif + F(I,L)=yvalue + 100 CONTINUE + 110 CONTINUE + END IF + +C COMPUTE DERIVATIVES WITH RESPECT TO BETA + IF (MOD(IDEVAL/10,10).GE.1) THEN + DO 210 L = 1,NQ + DO 200 I = 1,N + a=BETA(1) + b=BETA(2) + c=BETA(3) + x=XPLUSD(I,1) + if(NP.eq.4)then + d=BETA(4) + call der_fnonrecthypb(a,b,c,d,x,da,db, + & dc,dd,dx,iwrong) + if(iwrong.eq.1)then + ISTOP=1 + return + endif + FJACB(I,4,L)=dd + else + call der_recthypb(a,b,c,x,da,db,dc,dx) + endif + FJACB(I,1,L)=da + FJACB(I,2,L)=db + FJACB(I,3,L)=dc + 200 CONTINUE + 210 CONTINUE + END IF + RETURN + END +! +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/dataassim/math/specialfuncs/recthypb.f b/dataassim/math/specialfuncs/recthypb.f new file mode 100644 index 0000000..b264005 --- /dev/null +++ b/dataassim/math/specialfuncs/recthypb.f @@ -0,0 +1,124 @@ +!-----------4 parameters--------------------------------- +! Non-rectangular hyperbola function and derivatives +! y=a+b(x-sqrt(c+dx+x2)) or y=(ax+b-sqrt((ax+b)^2-4abcx))/2c-d +! + subroutine fnonrecthypb(a,b,c,d,x,y,iwrong) + implicit none + integer iwrong + double precision a,b,c,d,x,y,p + iwrong=0 + goto 10 +!---------------------------------------- +!a=alpha, b=Amax, c=theta, d=rd + p=(a*x+b)*(a*x+b)-4.0d0*a*b*c*x + if(p.lt.0.0d0)then + iwrong=1 + return + endif + y=(a*x+b-dsqrt(p))/(2.0d0*c)-d + return +!---------------------------------------- +10 p=c+d*x+x*x + if(p.lt.0.0d0)then + iwrong=1 + return + endif + y=a+b*(x-dsqrt(p)) + return + end + + subroutine indices_fnonrecthypb(a,b,c,d,root, + & der_root,fmax,iwrong) + implicit none + double precision a,b,c,d,root,der_root,fmax,p + integer iwrong + iwrong=0 + goto 10 +!--------------------------- + root=(c*d*d-b*d)/(a*d-a*b) + fmax=b + p=(a*root+b)*(a*root+b)-4.0d0*a*b*c*root + if(p.lt.0.0d0)then + iwrong=1 + return + endif + der_root=(a-a*(a*root+b-2.0d0*b*c)/dsqrt(p)) + & /(2.0d0*c) + return +!------------------------------ +10 root=(b*b*c-a*a)/(2.0d0*a*b-b*b*d) + fmax=a-0.5d0*b*d + p=root*root+d*root+c + if(p.lt.0.0d0)then + iwrong=1 + return + endif + der_root=b*(1.0d0-(2.0d0*root+d)/ + & (2.0d0*dsqrt(p))) + return + end + + subroutine der_fnonrecthypb(a,b,c,d,x,da,db,dc,dd,dx, + & iwrong) + implicit none + integer iwrong + double precision a,b,c,d,x,da,db,dc,dd,dx + double precision p + iwrong=0 + goto 10 +!----------------------------------------- + p=(a*x+b)*(a*x+b)-4.0d0*a*b*c*x + if(p.lt.0.0d0)then + iwrong=1 + return + endif + p=dsqrt(p) + da=(x-x*(a*x+b-2.0d0*b*c)/p)/(2.0d0*c) + db=(1.0d0-(a*x+b-2.0d0*a*c*x)/p)/(2.0d0*c) + dd=-1.0d0 + dc=a*b*x/(c*p)-(a*x+b-p)/(2.0d0*c*c) + dx=(a-a*(a*x+b-2.0d0*b*c)/p)/(2.0d0*c) + return +!------------------------------------------ +10 p=c+d*x+x*x + if(p.lt.0.0d0)then + iwrong=1 + return + endif + p=dsqrt(p) + da=1.0d0 + db=x-p + dc=-b/(2.0d0*p) + dd=dc*x + dx=b*(1.0d0-(d+2.0d0*x)/(2.0d0*p)) + return + end + +!-------3 parameters---------------------- + subroutine recthypb(a,b,c,x,y) + implicit none + double precision a,b,c,x,y + y=(a*x+b)/(x+c) + return + end + + subroutine indices_frecthypb(a,b,c,root, + & der_root,fmax) + implicit none + double precision a,b,c,root, + & der_root,fmax + root=-b/a + der_root=a*a/(a*c-b) + fmax=a + return + end + + subroutine der_recthypb(a,b,c,x,da,db,dc,dx) + implicit none + double precision a,b,c,x,da,db,dc,dx + da=x/(x+c) + db=1.0d0/(x+c) + dc=-(a*x+b)/((x+c)*(x+c)) + dx=a/(x+c)-(a*x+b)/((x+c)*(x+c)) + return + end diff --git a/leafres/testarea/ALightCombinatorial.f b/leafres/testarea/ALightCombinatorial.f new file mode 100644 index 0000000..77e30d8 --- /dev/null +++ b/leafres/testarea/ALightCombinatorial.f @@ -0,0 +1,318 @@ + subroutine ALightCombinatorial() + implicit none + include '../testarea/LeafGasHybridFit.h' + integer i,ilastrubp1,ilastrubis1,ilastrubp2,ilastrubis2, + &ilastrubp3,ilastrubis3,ilastrubp4,ilastrubis4, + &ilastrubp5,ilastrubis5,ilastrubp6,ilastrubis6, + &ilastrubp7,ilastrubis7,ilastrubp8,ilastrubis8, + &ilastrubp9,ilastrubis9,ilastrubp10,ilastrubis10, + &ilastrubp11,ilastrubis11,ilastrubp12,ilastrubis12, + &ilastrubp13,ilastrubis13,ilastrubp14,ilastrubis14, + &ilastrubp15,ilastrubis15,k1,k2,k3,k4,k5,k6,k7,k8,k9,k10, + &k11,k12,k13,k14,k15 +!common block variables: numALightcurves,nALightPoints(numALightcurves), +!ALightiphotolimit(nALightPoints,numALightcurves),ialightmin(numALightcurves), +!ialightmax(numALightcurves),ialightrubpmin(numALightcurves),ialightrubpmax(numALightcurves), +!ialightorder(numALightcurves) + + if(numALightcurves.eq.0)then +!no conventional A/Light curves. go to free-style measurements directly and then return + call FreeCombinatorial() + return + endif +!(before 17/09/2014 remarks.) Assume rubp, rubisco and tpu limitations in the order of (rubp, rubisco, tpu) +!but any limitation can be missing in any light response curves. The nALightPoints data in each light +!response curve must be ordered from low to high PAR. When ordered in such, the three limitation states +!should occur in the order of (rubp, rubisco, tpu) +! +!17/09/2014 Wenting found (RuBP, TPU, Rubisco) is more likely for A/Light curves if Ci decreases with +!increased light. Thus the following changes are made: +!we generally assume the points of an A/Light curve are lined up in a sequence of (RuBP, TPU and Rubisco), +!which is indicated by ialightorder=0. However, if Ci increases steadily from nstartalight to the end, we +!assume a sequence of (RuBP, Rubisco and TPU),which is indicated by ialightorder=2. + do ilastrubp1=ialightrubpmin(1),ialightrubpmax(1) + do i=1,ilastrubp1 + ALightiphotolimit(i,1)=2 + enddo + k1=max0(ilastrubp1,ialightmin(1)) + do 1 ilastrubis1=k1,ialightmax(1) + do i=ilastrubp1+1,ilastrubis1 + ALightiphotolimit(i,1)=3-ialightorder(1) + enddo + do i=ilastrubis1+1,nALightPoints(1) + ALightiphotolimit(i,1)=1+ialightorder(1) + enddo + if(numALightcurves.eq.1)then + call FreeCombinatorial() + goto 1 + endif + + do ilastrubp2=ialightrubpmin(2),ialightrubpmax(2) + do i=1,ilastrubp2 + ALightiphotolimit(i,2)=2 + enddo + k2=max0(ilastrubp2,ialightmin(2)) + do 2 ilastrubis2=k2,ialightmax(2) + do i=ilastrubp2+1,ilastrubis2 + ALightiphotolimit(i,2)=3-ialightorder(2) + enddo + do i=ilastrubis2+1,nALightPoints(2) + ALightiphotolimit(i,2)=1+ialightorder(2) + enddo + if(numALightcurves.eq.2)then + call FreeCombinatorial() + goto 2 + endif + + do ilastrubp3=ialightrubpmin(3),ialightrubpmax(3) + do i=1,ilastrubp3 + ALightiphotolimit(i,3)=2 + enddo + k3=max0(ilastrubp3,ialightmin(3)) + do 3 ilastrubis3=k3,ialightmax(3) + do i=ilastrubp3+1,ilastrubis3 + ALightiphotolimit(i,3)=3-ialightorder(3) + enddo + do i=ilastrubis3+1,nALightPoints(3) + ALightiphotolimit(i,3)=1+ialightorder(3) + enddo + if(numALightcurves.eq.3)then + call FreeCombinatorial() + goto 3 + endif + + do ilastrubp4=ialightrubpmin(4),ialightrubpmax(4) + do i=1,ilastrubp4 + ALightiphotolimit(i,4)=2 + enddo + k4=max0(ilastrubp4,ialightmin(4)) + do 4 ilastrubis4=k4,ialightmax(4) + do i=ilastrubp4+1,ilastrubis4 + ALightiphotolimit(i,4)=3-ialightorder(4) + enddo + do i=ilastrubis4+1,nALightPoints(4) + ALightiphotolimit(i,4)=1+ialightorder(4) + enddo + if(numALightcurves.eq.4)then + call FreeCombinatorial() + goto 4 + endif + + do ilastrubp5=ialightrubpmin(5),ialightrubpmax(5) + do i=1,ilastrubp5 + ALightiphotolimit(i,5)=2 + enddo + k5=max0(ilastrubp5,ialightmin(5)) + do 5 ilastrubis5=k5,ialightmax(5) + do i=ilastrubp5+1,ilastrubis5 + ALightiphotolimit(i,5)=3-ialightorder(5) + enddo + do i=ilastrubis5+1,nALightPoints(5) + ALightiphotolimit(i,5)=1+ialightorder(5) + enddo + if(numALightcurves.eq.5)then + call FreeCombinatorial() + goto 5 + endif + + do ilastrubp6=ialightrubpmin(6),ialightrubpmax(6) + do i=1,ilastrubp6 + ALightiphotolimit(i,6)=2 + enddo + k6=max0(ilastrubp6,ialightmin(6)) + do 6 ilastrubis6=k6,ialightmax(6) + do i=ilastrubp6+1,ilastrubis6 + ALightiphotolimit(i,6)=3-ialightorder(6) + enddo + do i=ilastrubis6+1,nALightPoints(6) + ALightiphotolimit(i,6)=1+ialightorder(6) + enddo + if(numALightcurves.eq.6)then + call FreeCombinatorial() + goto 6 + endif + + do ilastrubp7=ialightrubpmin(7),ialightrubpmax(7) + do i=1,ilastrubp7 + ALightiphotolimit(i,7)=2 + enddo + k7=max0(ilastrubp7,ialightmin(7)) + do 7 ilastrubis7=k7,ialightmax(7) + do i=ilastrubp7+1,ilastrubis7 + ALightiphotolimit(i,7)=3-ialightorder(7) + enddo + do i=ilastrubis7+1,nALightPoints(7) + ALightiphotolimit(i,7)=1+ialightorder(7) + enddo + if(numALightcurves.eq.7)then + call FreeCombinatorial() + goto 7 + endif + + do ilastrubp8=ialightrubpmin(8),ialightrubpmax(8) + do i=1,ilastrubp8 + ALightiphotolimit(i,8)=2 + enddo + k8=max0(ilastrubp8,ialightmin(8)) + do 8 ilastrubis8=k8,ialightmax(8) + do i=ilastrubp8+1,ilastrubis8 + ALightiphotolimit(i,8)=3-ialightorder(8) + enddo + do i=ilastrubis8+1,nALightPoints(8) + ALightiphotolimit(i,8)=1+ialightorder(8) + enddo + if(numALightcurves.eq.8)then + call FreeCombinatorial() + goto 8 + endif + + do ilastrubp9=ialightrubpmin(9),ialightrubpmax(9) + do i=1,ilastrubp9 + ALightiphotolimit(i,9)=2 + enddo + k9=max0(ilastrubp9,ialightmin(9)) + do 9 ilastrubis9=k9,ialightmax(9) + do i=ilastrubp9+1,ilastrubis9 + ALightiphotolimit(i,9)=3-ialightorder(9) + enddo + do i=ilastrubis9+1,nALightPoints(9) + ALightiphotolimit(i,9)=1+ialightorder(9) + enddo + if(numALightcurves.eq.9)then + call FreeCombinatorial() + goto 9 + endif + + do ilastrubp10=ialightrubpmin(10),ialightrubpmax(10) + do i=1,ilastrubp10 + ALightiphotolimit(i,10)=2 + enddo + k10=max0(ilastrubp10,ialightmin(10)) + do 10 ilastrubis10=k10,ialightmax(10) + do i=ilastrubp10+1,ilastrubis10 + ALightiphotolimit(i,10)=3-ialightorder(10) + enddo + do i=ilastrubis10+1,nALightPoints(10) + ALightiphotolimit(i,10)=1+ialightorder(10) + enddo + if(numALightcurves.eq.10)then + call FreeCombinatorial() + goto 10 + endif + + do ilastrubp11=ialightrubpmin(11),ialightrubpmax(11) + do i=1,ilastrubp11 + ALightiphotolimit(i,11)=2 + enddo + k11=max0(ilastrubp11,ialightmin(11)) + do 11 ilastrubis11=k11,ialightmax(11) + do i=ilastrubp11+1,ilastrubis11 + ALightiphotolimit(i,11)=3-ialightorder(11) + enddo + do i=ilastrubis11+1,nALightPoints(11) + ALightiphotolimit(i,11)=1+ialightorder(11) + enddo + if(numALightcurves.eq.11)then + call FreeCombinatorial() + goto 11 + endif + + do ilastrubp12=ialightrubpmin(12),ialightrubpmax(12) + do i=1,ilastrubp12 + ALightiphotolimit(i,12)=2 + enddo + k12=max0(ilastrubp12,ialightmin(12)) + do 12 ilastrubis12=k12,ialightmax(12) + do i=ilastrubp12+1,ilastrubis12 + ALightiphotolimit(i,12)=3-ialightorder(12) + enddo + do i=ilastrubis12+1,nALightPoints(12) + ALightiphotolimit(i,12)=1+ialightorder(12) + enddo + if(numALightcurves.eq.12)then + call FreeCombinatorial() + goto 12 + endif + + do ilastrubp13=ialightrubpmin(13),ialightrubpmax(13) + do i=1,ilastrubp13 + ALightiphotolimit(i,13)=2 + enddo + k13=max0(ilastrubp13,ialightmin(13)) + do 13 ilastrubis13=k13,ialightmax(13) + do i=ilastrubp13+1,ilastrubis13 + ALightiphotolimit(i,13)=3-ialightorder(13) + enddo + do i=ilastrubis13+1,nALightPoints(13) + ALightiphotolimit(i,13)=1+ialightorder(13) + enddo + if(numALightcurves.eq.13)then + call FreeCombinatorial() + goto 13 + endif + + do ilastrubp14=ialightrubpmin(14),ialightrubpmax(14) + do i=1,ilastrubp14 + ALightiphotolimit(i,14)=2 + enddo + k14=max0(ilastrubp14,ialightmin(14)) + do 14 ilastrubis14=k14,ialightmax(14) + do i=ilastrubp14+1,ilastrubis14 + ALightiphotolimit(i,14)=3-ialightorder(14) + enddo + do i=ilastrubis14+1,nALightPoints(14) + ALightiphotolimit(i,14)=1+ialightorder(14) + enddo + if(numALightcurves.eq.14)then + call FreeCombinatorial() + goto 14 + endif + + do ilastrubp15=ialightrubpmin(15),ialightrubpmax(15) + do i=1,ilastrubp15 + ALightiphotolimit(i,15)=2 + enddo + k15=max0(ilastrubp15,ialightmin(15)) + do 15 ilastrubis15=k15,ialightmax(15) + do i=ilastrubp15+1,ilastrubis15 + ALightiphotolimit(i,15)=3-ialightorder(15) + enddo + do i=ilastrubis15+1,nALightPoints(15) + ALightiphotolimit(i,15)=1+ialightorder(15) + enddo + if(numALightcurves.eq.15)then + call FreeCombinatorial() + goto 15 + endif +15 continue + enddo +14 continue + enddo +13 continue + enddo +12 continue + enddo +11 continue + enddo +10 continue + enddo +9 continue + enddo +8 continue + enddo +7 continue + enddo +6 continue + enddo +5 continue + enddo +4 continue + enddo +3 continue + enddo +2 continue + enddo +1 continue + enddo + return + end subroutine ALightCombinatorial diff --git a/leafres/testarea/Anet_Final.f b/leafres/testarea/Anet_Final.f new file mode 100644 index 0000000..47e8245 --- /dev/null +++ b/leafres/testarea/Anet_Final.f @@ -0,0 +1,1087 @@ +!This version of Anet_Final uses resistance instead of conductance. It considers the fact that +!CO2 from mitochodria (dark respiration and photorespiration) has different diffusion path ways than +!intercellular CO2 + subroutine Anet_Final(vcmax,jrubp,vtpu,resistwp,resistch, + &stargamma,kco,co2i,alpha,rd,ilimittype,iminimum,anet,co2c, + &realizedfjelect) + implicit none +! +!Calculates the net assimilation rate once all parameters are given at measurement conditions +!------------------ Inputs ----------------------------------- +!ilimittype: limitation types to evaluate +! 1 = Rubisco,RuBp and TPU limitations +! 2 = Rubisco and RuBp limitations only +! 3 = Rubisco and TPU limitations only +! 4 = RuBp and TPU limitations only +! 5 = Rubisco limitation only +! 6 = RuBp limitation only +! 7 = TPU limitation only +!vcmax (if ilimittype=1,2,3,5), maximum carboxylation rate limited by Rubisco (umol m-2 s-1) +!jrubp (if ilimittype=1,2,4,6), electron transport rate (umol m-2 s-1) +!vtpu (if ilimittype=1,3,4,7), triose phosphate export rate from chloroplast (umol m-2 s-1) +!resistwp: resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!stargamma, chloraplatic CO2 photocompensation point (Pa) +!kco,(if ilimittype=1,2,3,5), Kc(1+O/Ko), (Pa) +!co2i, intercellular CO2 partial pressure (Pa) +!alpha, (if ilimittype=1,3,4,7), fraction of glycolate carbon not returned to the chloroplast (0-1, dimensionless) +!rd, mitochondrial respiration in the light (umol m-2 s-1). +!------------------ Outputs ---------------------------------- +!anet: the net assimilation rate (umol m-2 s-1) +!iminimum, which limitation type is actually present Rubisco (1), RuBp(2), and TPU (3) +!realizedfjelect: the realized electron transport rate <= jrubp (=when RuBP regeneration limits photosynthesis). + integer ilimittype,iminimum,idorubisco,idorubp,idotpu + double precision vcmax,jrubp,vtpu,gmeso,stargamma,kco,co2i, + &alpha,rd,anet,wc,wj,wp,anetc,anetj,anettpu,term,term1,term2,co2c, + &co2c_wc,co2c_wj,co2c_wp,rwp,resistwp,rch,resistch,realizedfjelect +!---------------------------------rwp=dmax1(0.0d0,resistwp)--------------------------------- + anetc=1.0d+20 + anetj=1.0d+20 + anettpu=1.0d+20 + wc=1.0d+10 + wj=1.0d+15 + wp=1.0d+20 + realizedfjelect=-9999.0d0 + rwp=dmax1(0.0d0,resistwp) + rch=dmax1(0.0d0,resistch) +!This way of initialization is deliberate. If co2c <0, the priority of limitation +!state is Rubisco, RuBP regeneration, TPU + idorubisco=0 + idorubp=0 + idotpu=0 + iminimum=0 + if(ilimittype.le.3.or.ilimittype.eq.5)then + idorubisco=1 + endif + if(ilimittype.le.2.or.ilimittype.eq.4.or. + & ilimittype.eq.6)then + idorubp=1 + endif + if(ilimittype.eq.1.or.ilimittype.eq.3.or. + & ilimittype.eq.4.or.ilimittype.eq.7)then + idotpu=1 + endif + if(idorubisco.eq.1)then + call findco2c(vcmax,kco,co2i,rd,stargamma,rwp,rch,co2c_wc) + wc=co2c_wc*vcmax/(co2c_wc+kco) + anetc=(co2c_wc-stargamma)*vcmax/(co2c_wc+kco)-rd + endif + if(idorubp.eq.1)then + if(stargamma.eq.0.0d0)then + co2c_wj=co2i+rd*rwp-0.25d0*jrubp*(rwp+rch) + else + term1=0.25d0*jrubp + term2=2.0d0*stargamma + call findco2c(term1,term2,co2i,rd,stargamma,rwp,rch,co2c_wj) + endif + wj=co2c_wj*0.25d0*jrubp/(co2c_wj+2.0d0*stargamma) + anetj=(co2c_wj-stargamma)*0.25d0*jrubp/ + & (co2c_wj+2.0d0*stargamma)-rd + endif + if(idotpu.eq.1)then +!assumptions: +!Carboxylation rate cannot be negative. That means, if +!co2i is less than or equal to (1.0d0+3.0d0*alpha)*stargamma, then +!the TPU limitation state cannot occur. Under this situation, set wp to infinite + term1=3.0d0*vtpu + term2=-(1.0d0+3.0d0*alpha)*stargamma + call findco2c(term1,term2,co2i,rd,stargamma,rwp,rch,co2c_wp) + term=co2c_wp-(1.0d0+3.0d0*alpha)*stargamma + if(term.gt.1.0d-12)then + wp=co2c_wp*3.0d0*vtpu/term + anettpu=(co2c_wp-stargamma)*3.0d0*vtpu/term-rd + else + co2c_wp=-9999.0d0 + if(alpha.eq.0.0d0)anettpu=3.0d0*vtpu-rd + endif + endif + if(ilimittype.ge.5)then + if(ilimittype.eq.5)then + iminimum=1 + anet=anetc + co2c=co2c_wc + endif + if(ilimittype.eq.6)then + iminimum=2 + anet=anetj + co2c=co2c_wj + endif + if(ilimittype.eq.7)then + iminimum=3 + anet=anettpu + co2c=co2c_wp + endif + else + if(wc.lt.wj)then + if(wc.le.wp)then + anet=anetc + co2c=co2c_wc + iminimum=1 + else + anet=anettpu + co2c=co2c_wp + iminimum=3 + endif + else + if(wj.le.wp)then + anet=anetj + co2c=co2c_wj + iminimum=2 + else + anet=anettpu + co2c=co2c_wp + iminimum=3 + endif + endif + endif + if(iminimum.eq.2)then + realizedfjelect=jrubp + else + if(co2c.eq.stargamma)then + realizedfjelect=0.0d0 + else + realizedfjelect= + &(anet+rd)*(4.0d0*co2c+8.0d0*stargamma)/(co2c-stargamma) + endif + endif + return + end subroutine Anet_Final +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine findco2c(vcmax,kco,co2i,rd,stargamma,rwp,rch, + &co2c) +!kco and vcmax are generic and the formulation applies to rubp and tpu too + implicit none + double precision vcmax,kco,co2i,rd,stargamma,rwp,rch,co2c, + &b,c,b24ac,p,q,w + co2c=-9999.0d0 + b=kco-co2i-rd*rwp+vcmax*(rwp+rch) + c=-(co2i+rd*rwp)*kco-vcmax*rwp*stargamma + b24ac=b*b-4.0d0*c + if(b24ac.ge.0.0d0)then + co2c=(-b+dsqrt(b24ac))*0.5d0 +! write(*,*)(-b+dsqrt(b24ac))*0.5d0,(-b-dsqrt(b24ac))*0.5d0 +! p=-rd*rwp+vcmax*(rwp+rch) +! q=rd*rwp*kco+vcmax*rwp*stargamma +! w=4.0d0*(p*kco+q) +! if(w.le.0.0d0)then +! if((kco+co2i-p).le.(-dsqrt(-w)))co2c=(-b-dsqrt(b24ac))*0.5d0 +! endif +! if((kco+co2i-p).lt.0.0d0)co2c=(-b-dsqrt(b24ac))*0.5d0 + endif + return + end +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine der_findco2c(vcmax,kco,co2i,rd,stargamma,rwp, + &rch,co2c,der_vcmax,der_kco,der_co2i,der_rd,der_stargamma, + &der_rwp,der_rch) +!kco and vcmax are generic and the formulation applies to rubp and tpu too + implicit none + double precision vcmax,kco,co2i,rd,stargamma,rwp,rch,co2c, + &b,c,b24ac,p,q,w,fsign,der_vcmax,der_kco,der_co2i,der_rd, + &der_stargamma,der_rwp,der_rch,term,der_b,der_c + co2c=-9999.0d0 + der_vcmax=0.0d0 + der_kco=0.0d0 + der_co2i=0.0d0 + der_rd=0.0d0 + der_stargamma=0.0d0 + der_rwp=0.0d0 + der_rch=0.0d0 + b=kco-co2i-rd*rwp+vcmax*(rwp+rch) + c=-(co2i+rd*rwp)*kco-vcmax*rwp*stargamma + b24ac=b*b-4.0d0*c + if(b24ac.ge.0.0d0)then + fsign=1.0d0 +! p=-rd*rwp+vcmax*(rwp+rch) +! q=rd*rwp*kco+vcmax*rwp*stargamma +! w=4.0d0*(p*kco+q) +! if(w.le.0.0d0)then +! if((kco+co2i-p).le.(-dsqrt(-w)))fsign=-1.0d0 +! endif +! if((kco+co2i-p).lt.0.0d0)fsign=-1.0d0 + + term=dsqrt(b24ac) + co2c=(-b+fsign*term)*0.5d0 + der_b=(-1.0d0+fsign*b/term)*0.5d0 + der_c=-fsign/term + der_vcmax=der_b*(rwp+rch)-der_c*rwp*stargamma + der_kco=der_b-der_c*(co2i+rd*rwp) + der_co2i=-der_b-der_c*kco + der_rd=-der_b*rwp-der_c*rwp*kco + der_stargamma=-der_c*vcmax*rwp + der_rwp=der_b*(vcmax-rd)-der_c*(rd*kco+vcmax*stargamma) + der_rch=der_b*vcmax + endif + return + end +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine Anet_Final_der(vcmax,jrubp,vtpu,resistwp, + &resistch,stargamma,kco,co2i,alpha,rd,ilimittype,der_vcmax, + &der_jrubp,der_vtpu,der_rwp,der_rch,der_stargamma,der_kco, + &der_alpha,der_rd,der_co2i,anet,co2c,realizedfjelect) + implicit none +!Calculates the derivatives of parameters and the net assimilation rate +!once all parameters are given at measurement conditions. +!------------------ Inputs ----------------------------------- +!ilimittype: limitation types to evaluate +! 1 = Rubisco,RuBp and TPU limitations +! 2 = Rubisco and RuBp limitations only +! 3 = Rubisco and TPU limitations only +! 4 = RuBp and TPU limitations only +! 5 = Rubisco limitation only +! 6 = RuBp limitation only +! 7 = TPU limitation only +!vcmax (if ilimittype=1,2,3,5), maximum carboxylation rate limited by Rubisco (umol m-2 s-1) +!jrubp (if ilimittype=1,2,4,6), electron transport rate (umol m-2 s-1) +!vtpu (if ilimittype=1,3,4,7), triose phosphate export rate from chloroplast (umol m-2 s-1) +!resistwp: resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!stargamma, chloraplatic CO2 photocompensation point (Pa) +!kco,(if ilimittype=1,2,3,5), Kc(1+O/Ko), (Pa) +!co2i, intercellular CO2 partial pressure (Pa) +!starco2i,(if ilimittype=1,2,3,5), intercellular CO2 partial pressure at which Ac = 0. At this point, +! chloroplastic CO2 partial pressure equals the intercellular partial pressure (Pa). If less than +! zero, rd must be an input. +!alpha, (if ilimittype=1,3,4,7), fraction of glycolate carbon not returned to the chloroplast (0-1, dimensionless) +!rd, (if ilimittype=4,6,7),mitochondrial respiration in the light (umol m-2 s-1). if starco2i is less than +!zero, rd must be an input under all limitation types +! +!------------------ Outputs ---------------------------------- +!rd, (if ilimittype=1,2,3,5 when starco2i is greater than zero),mitochondrial respiration in the light (umol m-2 s-1) +!anet: the net assimilation rate (umol m-2 s-1) +!iminimum, which limitation type is actually present Rubisco (1), RuBp(2), and TPU (3) +!realizedfjelect: the realized electron transport rate <= jrubp (=when RuBP regeneration limits photosynthesis). + integer ilimittype,iminimum + double precision vcmax,jrubp,vtpu,gmeso,stargamma,kco,co2i, + &alpha,rd,anet,der_vcmax,der_jrubp,der_vtpu,der_rwp,der_rch, + &der_stargamma,der_kco,der_alpha,der_rd,t1,t2,co2c,rwp, + &rch,resistwp,resistch,dCc_t1,dCc_t2,dCc_co2i,dCc_rd, + &dCc_stargamma,der_co2i,der_Cc,der_t1,der_t2,dCc_rwp,dCc_rch, + &realizedfjelect + rwp=dmax1(0.0d0,resistwp) + rch=dmax1(0.0d0,resistch) + call Anet_Final(vcmax,jrubp,vtpu,rwp,rch,stargamma, + &kco,co2i,alpha,rd,ilimittype,iminimum,anet,co2c, + &realizedfjelect) +!We now know which limitation type is at work. Calculate the derivatives + der_vcmax=0.0d0 + der_jrubp=0.0d0 + der_vtpu=0.0d0 + der_rwp=0.0d0 + der_rch=0.0d0 + der_stargamma=0.0d0 + der_kco=0.0d0 + der_alpha=0.0d0 + der_co2i=0.0d0 + der_rd=-1.0d0 + if(iminimum.eq.1)then + t1=vcmax + t2=kco + endif + if(iminimum.eq.2)then + t1=0.25d0*jrubp + t2=2.0d0*stargamma + endif + if(iminimum.eq.3)then + t1=3.0d0*vtpu + t2=-(1.0d0+3.0d0*alpha)*stargamma + endif + der_t1=(co2c-stargamma)/(co2c+t2) + der_t2=-(co2c-stargamma)*t1/((co2c+t2)*(co2c+t2)) + der_stargamma=-t1/(co2c+t2) + der_Cc=t1/(co2c+t2)*(1.0d0-(co2c-stargamma)/(co2c+t2)) + der_co2i=der_Cc + call der_findco2c(t1,t2,co2i,rd,stargamma,rwp, + &rch,co2c,dCc_t1,dCc_t2,dCc_co2i,dCc_rd,dCc_stargamma, + &dCc_rwp,dCc_rch) + der_t1=der_t1+der_Cc*dCc_t1 + der_t2=der_t2+der_Cc*dCc_t2 + der_stargamma=der_stargamma+der_Cc*dCc_stargamma + der_rd=der_rd+der_Cc*dCc_rd + der_co2i=der_Cc*dCc_co2i + der_rwp=der_Cc*dCc_rwp + der_rch=der_Cc*dCc_rch +!now change back + if(iminimum.eq.1)then + der_vcmax=der_t1 + der_kco=der_t2 + endif + if(iminimum.eq.2)then + der_jrubp=der_t1*0.25d0 + der_stargamma=der_stargamma+der_t2*2.0d0 + endif + if(iminimum.eq.3)then + der_vtpu=der_t1*3.0d0 + der_stargamma=der_stargamma-der_t2*(1.0d0+3.0d0*alpha) + der_alpha=-der_t2*3.0d0*stargamma + endif + return + end subroutine Anet_Final_der +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine Anet_Final_der2(vcmax,jrubp,vtpu,resistwp, + &resistch,stargamma,kco,co2i,alpha,rd,ilimittype,der_vcmax, + &der_jrubp,der_vtpu,der_rwp,der_rch,der_stargamma,der_kco, + &der_alpha,der_rd,der_co2i,der2_vcmax,der2_jrubp,der2_vtpu, + &der2_rwp,der2_rch,der2_stargamma,der2_kco,der2_alpha, + &der2_rd,der2_co2i,anet,co2c,realizedfjelect) + implicit none +!Calculates the derivatives of parameters and the net assimilation rate +!once all parameters are given at measurement conditions. +!------------------ Inputs ----------------------------------- +!ilimittype: limitation types to evaluate +! 1 = Rubisco,RuBp and TPU limitations +! 2 = Rubisco and RuBp limitations only +! 3 = Rubisco and TPU limitations only +! 4 = RuBp and TPU limitations only +! 5 = Rubisco limitation only +! 6 = RuBp limitation only +! 7 = TPU limitation only +!vcmax (if ilimittype=1,2,3,5), maximum carboxylation rate limited by Rubisco (umol m-2 s-1) +!jrubp (if ilimittype=1,2,4,6), electron transport rate (umol m-2 s-1) +!vtpu (if ilimittype=1,3,4,7), triose phosphate export rate from chloroplast (umol m-2 s-1) +!resistwp: resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!stargamma, chloraplatic CO2 photocompensation point (Pa) +!kco,(if ilimittype=1,2,3,5), Kc(1+O/Ko), (Pa) +!co2i, intercellular CO2 partial pressure (Pa) +!starco2i,(if ilimittype=1,2,3,5), intercellular CO2 partial pressure at which Ac = 0. At this point, +! chloroplastic CO2 partial pressure equals the intercellular partial pressure (Pa). If less than +! zero, rd must be an input. +!alpha, (if ilimittype=1,3,4,7), fraction of glycolate carbon not returned to the chloroplast (0-1, dimensionless) +!rd, mitochondrial respiration in the light (umol m-2 s-1) +! +!------------------ Outputs ---------------------------------- +!anet: the net assimilation rate (umol m-2 s-1) +!iminimum, which limitation type is actually present Rubisco (1), RuBp(2), and TPU (3) +!realizedfjelect: the realized electron transport rate <= jrubp (=when RuBP regeneration limits photosynthesis). + integer ilimittype,iminimum + double precision vcmax,jrubp,vtpu,resistwp,resistch, + &stargamma,kco,co2i,alpha,rd,der_vcmax,der_jrubp,der_vtpu, + &der_rwp,der_rch,der_stargamma,der_kco,der_alpha,der_rd,der_co2i, + &der2_vcmax,der2_jrubp,der2_vtpu,der2_rwp,der2_rch,der2_stargamma, + &der2_kco,der2_alpha,der2_rd,der2_co2i,anet,co2c,rwp,rch,t1,t2,t3, + &der_t1,der_t2,der_Cc,der2_t1,der2_t2,der2_Cc,der2_Cct1,der2_Cct2, + &der2_Ccstargamma,der2_t2stargamma,der2_Ccrd,dCc_t1,dCc_t2,dCc_rd, + &dCc2_rd,dCc_stargamma,dCc_rwp,dCc2_rwp,dCc_rch,dCc2_rch,dCc_co2i, + &dCc2_t1,dCc2_t2,dCc2_co2i,dCc2_stargamma,dCc2_t2stargamma, + &der2_t2_0,realizedfjelect +!------------------------------------------------------------------ + rwp=dmax1(0.0d0,resistwp) + rch=dmax1(0.0d0,resistch) + call Anet_Final(vcmax,jrubp,vtpu,rwp,rch,stargamma, + &kco,co2i,alpha,rd,ilimittype,iminimum,anet,co2c, + &realizedfjelect) +!We now know which limitation type is at work. Calculate the derivatives +!first derivatives + der_vcmax=0.0d0 + der_jrubp=0.0d0 + der_vtpu=0.0d0 + der_rwp=0.0d0 + der_rch=0.0d0 + der_stargamma=0.0d0 + der_kco=0.0d0 + der_alpha=0.0d0 + der_rd=-1.0d0 +!second derivatives + der2_vcmax=0.0d0 + der2_jrubp=0.0d0 + der2_vtpu=0.0d0 + der2_rwp=0.0d0 + der2_rch=0.0d0 + der2_stargamma=0.0d0 + der2_kco=0.0d0 + der2_alpha=0.0d0 + der2_rd=0.0d0 + if(iminimum.eq.1)then + t1=vcmax + t2=kco + endif + if(iminimum.eq.2)then + t1=0.25d0*jrubp + t2=2.0d0*stargamma + endif + if(iminimum.eq.3)then + t1=3.0d0*vtpu + t2=-(1.0d0+3.0d0*alpha)*stargamma + endif + der_t1=(co2c-stargamma)/(co2c+t2) + der_t2=-(co2c-stargamma)*t1/((co2c+t2)*(co2c+t2)) + der_stargamma=-t1/(co2c+t2) + der_Cc=t1/(co2c+t2)*(1.0d0-(co2c-stargamma)/(co2c+t2)) + der_co2i=der_Cc + der2_Cc=(2.0d0*t1/((co2c+t2)**2))* + &((co2c-stargamma)/(co2c+t2)-1.0d0) + der2_t2=2.0d0*(co2c-stargamma)*t1/((co2c+t2)**3) + der2_t2_0=der2_t2 + der2_Cct1=(1.0d0-(co2c-stargamma)/(co2c+t2))/(co2c+t2) + der2_Cct2=(t1/((co2c+t2)**2))* + &(2.0d0*(co2c-stargamma)/(co2c+t2)-1.0d0) + der2_Ccstargamma=t1/((co2c+t2)**2) + der2_t2stargamma=t1/((co2c+t2)**2) + der2_co2i=der2_Cc + der2_rd=0.0d0 + der2_t1=0.0d0 + der2_stargamma=0.0d0 + der2_Ccrd=0.0d0 + call der2_findco2c(t1,t2,co2i,rd,stargamma,rwp,rch,co2c,dCc_t1, + &dCc_t2,dCc_co2i,dCc_rd,dCc_stargamma,dCc_rwp,dCc_rch,dCc2_t1, + &dCc2_t2,dCc2_co2i,dCc2_rd,dCc2_stargamma,dCc2_rwp,dCc2_rch, + &dCc2_t2stargamma) + der_t1=der_t1+der_Cc*dCc_t1 + der_t2=der_t2+der_Cc*dCc_t2 + der_stargamma=der_stargamma+der_Cc*dCc_stargamma + der_rd=der_rd+der_Cc*dCc_rd + der_co2i=der_Cc*dCc_co2i + der_rwp=der_Cc*dCc_rwp + der_rch=der_Cc*dCc_rch + der2_t1= + &2.0d0*der2_Cct1*dCc_t1+der2_Cc*(dCc_t1**2)+der_Cc*dCc2_t1 + der2_t2=der2_t2+ + &2.0d0*der2_Cct2*dCc_t2+der2_Cc*(dCc_t2**2)+der_Cc*dCc2_t2 + der2_rd=der2_Cc*(dCc_rd**2)+der_Cc*dCc2_rd + der2_rwp=der2_Cc*(dCc_rwp**2)+der_Cc*dCc2_rwp + der2_rch=der2_Cc*(dCc_rch**2)+der_Cc*dCc2_rch + der2_co2i=der2_Cc*(dCc_co2i**2)+der_Cc*dCc2_co2i + if(iminimum.eq.1)then + der2_stargamma= + &2.0d0*der2_Ccstargamma*dCc_stargamma+der2_Cc*(dCc_stargamma**2)+ + &der_Cc*dCc2_stargamma + der_vcmax=der_t1 + der_kco=der_t2 + der2_vcmax=der2_t1 + der2_kco=der2_t2 + endif + if(iminimum.eq.2)then + dCc_stargamma=dCc_stargamma+dCc_t2*2.0d0 + dCc2_stargamma=dCc2_stargamma+ + &2.0d0*dCc2_t2stargamma*2.0d0+dCc2_t2*4.0d0 + der_jrubp=der_t1*0.25d0 + der_stargamma=der_stargamma+der_t2*2.0d0 + der2_jrubp=der2_t1*0.25d0*0.25d0 + der2_stargamma=2.0d0*der2_Ccstargamma*dCc_stargamma+ + &der2_Cc*(dCc_stargamma**2)+der_Cc*dCc2_stargamma+ + &4.0d0*(der2_t2stargamma+der2_Cct2*dCc_stargamma)+der2_t2_0*4.0d0 + endif + if(iminimum.eq.3)then + t3=-(1.0d0+3.0d0*alpha) + dCc_stargamma=dCc_stargamma+dCc_t2*t3 + dCc2_stargamma=dCc2_stargamma+ + &2.0d0*dCc2_t2stargamma*t3+dCc2_t2*t3*t3 + der_vtpu=der_t1*3.0d0 + der_stargamma=der_stargamma+der_t2*t3 + der_alpha=-der_t2*3.0d0*stargamma + der2_vtpu=der2_t1*3.0d0*3.0d0 + der2_stargamma=2.0d0*der2_Ccstargamma*dCc_stargamma+ + &der2_Cc*(dCc_stargamma**2)+der_Cc*dCc2_stargamma+ + &2.0d0*(der2_t2stargamma+der2_Cct2*dCc_stargamma)*t3+ + &der2_t2_0*t3*t3 + der2_alpha=der2_t2*9.0d0*stargamma**2 + endif + return + end +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine der2_findco2c(vcmax,kco,co2i,rd,stargamma,rwp, + &rch,co2c,der_vcmax,der_kco,der_co2i,der_rd,der_stargamma, + &der_rwp,der_rch,der2_vcmax,der2_kco,der2_co2i,der2_rd, + &der2_stargamma,der2_rwp,der2_rch,der2_kcostargamma) +!kco and vcmax are generic and the formulation applies to rubp and tpu too +!after the transformation factors are applied + implicit none + integer iwhichroot + double precision vcmax,kco,co2i,rd,stargamma,rwp,rch,co2c, + &der_vcmax,der_kco,der_co2i,der_rd,der_stargamma,der_rwp, + &der_rch,der2_vcmax,der2_kco,der2_co2i,der2_rd,der2_stargamma, + &der2_rwp,der2_rch,der2_kcostargamma,derb_vcmax,derb_kco,derb_co2i, + &derb_rd,derb_stargamma,derb_rwp,derb_rch,derc_vcmax,derc_kco, + &derc_co2i,derc_rd,derc_stargamma,derc_rwp,derc_rch,b,c,b24ac, + &term,der_b,der_c,der2_b,der2_c,der2_bc,p,q,w,der2implicit + co2c=-9999.0d0 + der_vcmax=0.0d0 + der_kco=0.0d0 + der_co2i=0.0d0 + der_rd=0.0d0 + der_stargamma=0.0d0 + der_rwp=0.0d0 + der_rch=0.0d0 + der2_kco=0.0d0 + der2_co2i=0.0d0 + der2_rd=0.0d0 + der2_stargamma=0.0d0 + der2_rwp=0.0d0 + der2_rch=0.0d0 + der2_kcostargamma=0.0d0 + b=kco-co2i-rd*rwp+vcmax*(rwp+rch) + c=-(co2i+rd*rwp)*kco-vcmax*rwp*stargamma + derb_vcmax=rwp+rch + derb_kco=1.0d0 + derb_co2i=-1.0d0 + derb_rd=-rwp + derb_stargamma=0.0d0 + derb_rwp=vcmax-rd + derb_rch=vcmax + derc_vcmax=-rwp*stargamma + derc_kco=-(co2i+rd*rwp) + derc_co2i=-kco + derc_rd=-rwp*kco + derc_stargamma=-vcmax*rwp + derc_rwp=-rd*kco-vcmax*stargamma + derc_rch=0.0d0 + b24ac=b*b-4.0d0*c + if(b24ac.ge.0.0d0)then + iwhichroot=1 +! p=-rd*rwp+vcmax*(rwp+rch) +! q=rd*rwp*kco+vcmax*rwp*stargamma +! w=4.0d0*(p*kco+q) +! if(w.le.0.0d0)then +! if((kco+co2i-p).le.(-dsqrt(-w)))iwhichroot=-1 +! endif +! if((kco+co2i-p).lt.0.0d0)iwhichroot=-1 + + call der2_simpquadroot(iwhichroot,b,c,co2c,der_b,der_c,der2_b, + &der2_c,der2_bc) + der_vcmax=der_b*derb_vcmax+der_c*derc_vcmax + der_kco=der_b*derb_kco+der_c*derc_kco + der_co2i=der_b*derb_co2i+der_c*derc_co2i + der_rd=der_b*derb_rd+der_c*derc_rd + der_stargamma=der_b*derb_stargamma+der_c*derc_stargamma + der_rwp=der_b*derb_rwp+der_c*derc_rwp + der_rch=der_b*derb_rch+der_c*derc_rch + der2_vcmax=der2implicit(der2_b,der2_c,der2_bc, + &derb_vcmax,derc_vcmax) + der2_kco=der2implicit(der2_b,der2_c,der2_bc,derb_kco,derc_kco) + der2_co2i=der2implicit(der2_b,der2_c,der2_bc, + &derb_co2i,derc_co2i) + der2_rd=der2implicit(der2_b,der2_c,der2_bc,derb_rd,derc_rd) + der2_stargamma=der2implicit(der2_b,der2_c,der2_bc, + &derb_stargamma,derc_stargamma) + der2_rwp=der2implicit(der2_b,der2_c,der2_bc,derb_rwp,derc_rwp) + der2_rch=der2implicit(der2_b,der2_c,der2_bc,derb_rch,derc_rch) + der2_kcostargamma= + &der2_bc*derc_stargamma*derb_kco+der2_c*derc_stargamma*derc_kco + endif + return + end +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine der2_simpquadroot(iwhichroot,b,c,root, + & der_b,der_c,der2_b,der2_c,der2_bc) + implicit none + double precision b,c,root,der_b,der_c,b24c, + & der2_b,der2_c,der2_bc,term + integer iwhichroot +!root for x2+bx+c=0 + b24c=b*b-4.0d0*c + if(b24c.lt.0.0d0)then + root=-9999.0d0 + der_b=-9999.0d0 + der_c=-9999.0d0 + der2_b=-9999.0d0 + der2_c=-9999.0d0 + der2_bc=-9999.0d0 + else + term=1.0d0/((b*b-4.0d0*c)*dsqrt(b24c)) + if(iwhichroot.lt.0)then + root=0.5d0*(-b-dsqrt(b24c)) + der_b=0.5d0*(-1.0d0-b/dsqrt(b24c)) + der_c=1.0d0/dsqrt(b24c) + der2_b=2.0d0*c*term + der2_c=2.0d0*term + der2_bc=-b*term + else + root=0.5d0*(-b+dsqrt(b24c)) + der_b=0.5d0*(-1.0d0+b/dsqrt(b24c)) + der_c=-1.0d0/dsqrt(b24c) + der2_b=-2.0d0*c*term + der2_c=-2.0d0*term + der2_bc=b*term + endif + endif + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function der2implicit(der2_b,der2_c, + & der2_bc,derb_p,derc_p) + implicit none + double precision der2_b,der2_c, + & der2_bc,derb_p,derc_p + der2implicit=der2_b*derb_p*derb_p+ + & 2.0d0*der2_bc*derb_p*derc_p+der2_c*derc_p*derc_p + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine der_simpquadroot(iwhichroot,b,c,root, + & der_b,der_c) + implicit none + double precision b,c,root,der_b,der_c,b24c + integer iwhichroot +!x2+bx+c=0 + b24c=b*b-4.0d0*c + if(b24c.gt.0.0d0)then + if(iwhichroot.lt.0)then + root=0.5d0*(-b-dsqrt(b24c)) + der_b=0.5d0*(-1.0d0-b/dsqrt(b24c)) + der_c=1.0d0/dsqrt(b24c) + else + root=0.5d0*(-b+dsqrt(b24c)) + der_b=0.5d0*(-1.0d0+b/dsqrt(b24c)) + der_c=-1.0d0/dsqrt(b24c) + endif + else + if(b24c.lt.0.0d0)then + root=-9999.0d0 + der_b=-9999.0d0 + der_c=-9999.0d0 + else + root=-b + der_b=-1.0d0 + der_c=0.0d0 + endif + endif + return + end +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine EqualPoints(vcmax,jrubp,vtpu,resistwp, + &resistch,stargamma,kc,ko,oxypres,alpha,rd,ilimittype, + &co2iRubismax,co2iRuBpmax,anetRubismax,anetRuBpmax) + implicit none +!Calculates the CO2i points where limitations of Rubisco, RuBp and Tpu are equal. +!------------------ Inputs ----------------------------------- +!ilimittype: limitation types to evaluate +! 1 = Rubisco,RuBp and TPU limitations +! 2 = Rubisco and RuBp limitations only +! 3 = Rubisco and TPU limitations only +! 4 = RuBp and TPU limitations only +! 5 = Rubisco limitation only +! 6 = RuBp limitation only +! 7 = TPU limitation only +!vcmax (if ilimittype=1,2,3,5), maximum carboxylation rate limited by Rubisco (umol m-2 s-1) +!jrubp (if ilimittype=1,2,4,6), electron transport rate (umol m-2 s-1) +!vtpu (if ilimittype=1,3,4,7), triose phosphate export rate from chloroplast (umol m-2 s-1) +!resistwp: resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!stargamma, chloraplatic CO2 photocompensation point (Pa) +!kc: the Michaelis constant for CO2 [Pa] +!ko: the Michaelis constant for O2 [Pa] +!oxypres: Oxygen partial pressure (Pa) +!alpha, (if ilimittype=1,3,4,7), fraction of glycolate carbon not returned to the chloroplast (0-1, dimensionless) +!rd, mitochondrial respiration in the light (umol m-2 s-1). +!------------------ Outputs ---------------------------------- +!anetRubisRuBp,anetRuBpTpu,anetRubisTpu: the net assimilation rates at equal points (umol m-2 s-1) +!co2iRubisRuBp,co2iRuBpTpu,co2iRubisTpu: equal points + + integer ilimittype + double precision vcmax,jrubp,vtpu,resistwp,resistch, + &rwp,rch,stargamma,kc,ko,oxypres,kco,co2i,alpha,rd, + &co2iRubismax,co2iRuBpmax,anetRubismax,anetRuBpmax,term1 +!------------------------------------------------------------------ + rwp=dmax1(0.0d0,resistwp) + rch=dmax1(0.0d0,resistch) + anetRubismax=-9999.0d0 + anetRuBpmax=-9999.0d0 + co2iRubismax=-9999.0d0 + co2iRuBpmax=-9999.0d0 + kco=kc*(1.0d0+oxypres/ko) + term1=-(1.0d0+3.0d0*alpha)*stargamma + if(ilimittype.eq.1)then + co2iRubismax=(2.0d0*stargamma*vcmax- + & kco*0.25d0*jrubp)/(0.25d0*jrubp-vcmax) + anetRubismax=(co2iRubismax-stargamma)*vcmax/ + & (co2iRubismax+kco)-rd + co2iRuBpmax=(2.0d0*stargamma*3.0d0*vtpu- + & term1*0.25d0*jrubp)/(0.25d0*jrubp-3.0d0*vtpu) + anetRuBpmax=(co2iRuBpmax-stargamma)*0.25d0*jrubp/ + & (co2iRuBpmax+2.0d0*stargamma)-rd + endif + if(ilimittype.eq.2)then + co2iRubismax=(2.0d0*stargamma*vcmax- + & kco*0.25d0*jrubp)/(0.25d0*jrubp-vcmax) + anetRubismax=(co2iRubismax-stargamma)*vcmax/ + & (co2iRubismax+kco)-rd + endif + if(ilimittype.eq.3)then + co2iRubismax=(term1*vcmax- + & kco*3.0d0*vtpu)/(3.0d0*vtpu-vcmax) + anetRubismax=(co2iRubismax-stargamma)*vcmax/ + & (co2iRubismax+kco)-rd + endif + if(ilimittype.eq.4)then + co2iRuBpmax=(2.0d0*stargamma*3.0d0*vtpu- + & term1*0.25d0*jrubp)/(0.25d0*jrubp-3.0d0*vtpu) + anetRuBpmax=(co2iRuBpmax-stargamma)*0.25d0*jrubp/ + & (co2iRuBpmax+2.0d0*stargamma)-rd + endif + if(rwp.gt.0.0d0.or.rch.gt.0.0d0)then + if(ilimittype.eq.1.or.ilimittype.eq.2.or.ilimittype.eq.3) + &co2iRubismax=co2iRubismax+anetRubismax*rwp+rch* + &co2iRubismax*vcmax/(co2iRubismax+kco) + if(ilimittype.eq.1.or.ilimittype.eq.4)co2iRuBpmax= + &co2iRuBpmax+anetRuBpmax*rwp+rch*co2iRuBpmax*0.25d0*jrubp/ + &(co2iRuBpmax+2.0d0*stargamma) + endif + return + end subroutine EqualPoints +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine Params_Ci(vcmax,jrubp,vtpu,resistwp,resistch, + &stargamma,kco,alpha,rd,ilimittype,cic,anetcic,cij,anetcij) + implicit none +! +!Calculates vcmax and tpu when the CO2i thresholds are known. +!------------------ Inputs ----------------------------------- +!ilimittype: limitation types to evaluate +! 1 = Rubisco,RuBp and TPU limitations, +! 2 = Rubisco and RuBp limitations only +! 3 = Rubisco and TPU limitations only +! 4 = RuBp and TPU limitations only +! +!jrubp (except for ilimittype=3), electron transport rate (umol m-2 s-1) +!vtpu (when ilimittype=3 only), triose phosphate export rate from chloroplast (umol m-2 s-1) +!resistwp: resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!stargamma, chloraplatic CO2 photocompensation point (Pa) +!kco,(if ilimittype=1,2,3), Kc(1+O/Ko), (Pa) +!alpha, (if ilimittype=1,3,4), fraction of glycolate carbon not returned to the chloroplast (0-1, dimensionless) +!rd, mitochondrial respiration in the light (umol m-2 s-1). +!cic, CO2i at rubisco and rubp limited intersection (Pa) or at rubisco and tpu limited intersection +!cij, CO2i at rubp and tpu limited intersection (Pa) +!------------------ Outputs ---------------------------------- +!vcmax (when ilimittype=1,2,3 only), maximum carboxylation rate limited by Rubisco (umol m-2 s-1) +!vtpu (when ilimittype=1,4 only), triose phosphate export rate from chloroplast (umol m-2 s-1) +!anetcic: net assimilation rate at cic (umol m-2 s-1). +!anetcij: net assimilation rate at cij (umol m-2 s-1). + + integer ilimittype,idogi,i,j,k + double precision vcmax,jrubp,vtpu,resistwp,resistch,rwp,rch, + &stargamma,kco,co2i,alpha,rd,term1,cic,cij,anetcic,anetcij, + &co2cic,co2cij,realizedfjelect +!------------------------------------------------------------------ + rwp=dmax1(0.0d0,resistwp) + rch=dmax1(0.0d0,resistch) + term1=-(1.0d0+3.0d0*alpha)*stargamma + if(ilimittype.eq.1.or.ilimittype.eq.2)then + call Anet_Final(vcmax,jrubp,vtpu,rwp,rch,stargamma, + &kco,cic,alpha,rd,6,i,anetcic,co2cic,realizedfjelect) + endif + if(ilimittype.eq.1.or.ilimittype.eq.4)then + call Anet_Final(vcmax,jrubp,vtpu,rwp,rch,stargamma, + &kco,cij,alpha,rd,6,i,anetcij,co2cij,realizedfjelect) + endif + if(ilimittype.eq.3)then + call Anet_Final(vcmax,jrubp,vtpu,rwp,rch,stargamma, + &kco,cic,alpha,rd,7,i,anetcic,co2cic,realizedfjelect) + endif + if(ilimittype.eq.1.or.ilimittype.eq.2.or.ilimittype.eq.3) + &vcmax=(anetcic+rd)*(co2cic+kco)/(co2cic-stargamma) + if(ilimittype.eq.1.or.ilimittype.eq.4)then + if(alpha.gt.0.0d0)then + vtpu=(anetcij+rd)*(co2cij+term1)/(co2cij-stargamma) + vtpu=vtpu/3.0d0 + else + vtpu=(anetcij+rd)/3.0d0 + endif + endif + return + end subroutine Params_Ci +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine inverse_anet(vcmax,jrubp,vtpu,resistwp, + &resistch,stargamma,kco,alpha,rd,iminimum,co2i,anet) + implicit none +!Calculates vcmax, jrubp, or tpu when CO2i and other parameters are known. +!------------------ Inputs ----------------------------------- +!iminimum=1, rubisco limitation +! =2, rubp regeneration limitation +! =3, tpu limitation +!anet: net co2 assimilation rate (umolm-2s-1) +!resistwp: resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!stargamma, chloraplatic CO2 photocompensation point (Pa) +!kco (if iminimum=1), Kc(1+O/Ko), (Pa) +!alpha (if iminimum=3), fraction of glycolate carbon not returned to the chloroplast (0-1, dimensionless) +!rd, mitochondrial respiration in the light (umol m-2 s-1). +!------------------ Outputs ---------------------------------- +!vcmax (when iminimum=1 only), maximum carboxylation rate limited by Rubisco (umol m-2 s-1) +!jrubp (when iminimum=2 only), electron transport rate (umol m-2 s-1) +!vtpu (when iminimum=3 only), triose phosphate export rate from chloroplast (umol m-2 s-1) +! + integer iminimum + double precision vcmax,jrubp,vtpu,resistwp,resistch, + &stargamma,kco,co2i,alpha,rd,anet,term1,co2c +!------------------------------------------------------------------ + vcmax=-9999.0d0 + jrubp=-9999.0d0 + vtpu=-9999.0d0 + if(iminimum.eq.3.and.alpha.le.0.0d0)then + vtpu=(anet+rd)/3.0d0 + return + endif + call getco2c(resistwp,resistch,stargamma,rd,co2i,anet,co2c) + if(co2c.lt.0.0d0)return + if(iminimum.eq.1)vcmax=(anet+rd)*(co2c+kco)/(co2c-stargamma) + if(iminimum.eq.2)jrubp= + &4.0d0*(anet+rd)*(co2c+2.0d0*stargamma)/(co2c-stargamma) + if(iminimum.eq.3)then + term1=-(1.0d0+3.0d0*alpha)*stargamma + vtpu=((anet+rd)*(co2c+term1)/(co2c-stargamma))/3.0d0 + endif + return + end subroutine inverse_anet +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine getco2c(resistwp,resistch,stargamma,rd,co2i,anet, + &co2c) + implicit none +!Calculates CO2c +!------------------ Inputs ----------------------------------- +!resistwp: resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!stargamma, chloraplatic CO2 photocompensation point (Pa) +!rd, mitochondrial respiration in the light (umol m-2 s-1). +!anet: CO2 assimilation rate (umolm-2s-1) + double precision resistwp,rwp,resistch,rch,stargamma,co2i,rd,anet, + &co2c,b,c,b24ac,cy +!------------------------------------------------------------------ + rwp=dmax1(0.0d0,resistwp) + rch=dmax1(0.0d0,resistch) + cy=co2i-anet*rwp + if(rch.gt.0.0d0)then + b=(anet+rd)*rch-cy-stargamma + c=cy*stargamma + b24ac=b*b-4.0d0*c + if(b24ac.ge.0.0d0)then + if(anet.lt.-rd)then + co2c=(-b-dsqrt(b24ac))/2.0d0 + else + co2c=(-b+dsqrt(b24ac))/2.0d0 + endif + else + co2c=-9999.0d0 + endif + else + co2c=cy + endif + return + end subroutine getco2c +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine getresistmeso(resistwp,resistch,stargamma,rd,co2i,anet, + &co2c,resistmeso) + implicit none +!Calculates mesophyll resistance resistmeso (Pa s m2 umol-1) and chloroplastic CO2 co2c (Pa) +!------------------ Inputs ----------------------------------- +!resistwp: resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!stargamma, chloraplatic CO2 photocompensation point (Pa) +!rd, mitochondrial respiration in the light (umol m-2 s-1). +!anet: CO2 assimilation rate (umolm-2s-1) +!co2i: CO2 partial pressure at intercellular air space (Pa) + double precision resistwp,rwp,resistch,rch,stargamma,co2i,rd,anet, + &co2c,q,u,q24u,resistmeso +!------------------------------------------------------------------ + rwp=dmax1(0.0d0,resistwp) + rch=dmax1(0.0d0,resistch) + if(rch.gt.0.0d0)then + call getco2c(rwp,rch,stargamma,rd,co2i,anet,co2c) + resistmeso=(co2i-co2c)/anet +! +! q=-(anet+rd)*rch-co2i+stargamma-anet*rwp +! u=(anet+rd)*rch*co2i+(co2i-stargamma)*anet*rwp +! q24u=q*q-4.0d0*u +! if(q24u.ge.0.0d0)then +! resistmeso=(-q-dsqrt(q24u))/(2.0d0*anet) +! co2c=co2i-anet*resistmeso +! write(*,*)co2c,resistmeso +! resistmeso=(-q+dsqrt(q24u))/(2.0d0*anet) +! co2c=co2i-anet*resistmeso +! write(*,*)co2c,resistmeso +! else +! resistmeso=-9999.0d0 +! co2c=-9999.0d0 +! endif + else + resistmeso=rwp + co2c=co2i-anet*resistmeso + endif + return + end subroutine getresistmeso +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine co2recyclingratio(resistwp,resistch,resiststom, + &stargamma,rd,co2c,anet,recyclingrate) + implicit none +!resistwp: resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!resiststom: resistance to CO2 via stomata (Pa s m2 umol-1). If less than zero, set to zero. +!stargamma: chloraplatic CO2 photocompensation point (Pa) +!rd, mitochondrial respiration in the light (umol m-2 s-1). +!co2c: co2 partial pressure at chloroplast (Pa) +!anet, net assimilation rate (umol m-2 s-1). + double precision resistwp,resistch,resiststom,stargamma, + &rd,co2c,anet,recyclingrate,rwp,rch,rst,vc,rcarb + rwp=dmax1(0.0d0,resistwp) + rch=dmax1(0.0d0,resistch) + rst=dmax1(0.0d0,resiststom) + vc=(anet+rd)/(1.0d0-stargamma/co2c) + rcarb=co2c/vc + recyclingrate=(rwp+rst)/(rwp+rst+rch+rcarb) + return + end +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine CO2i_Final(vcmax,jrubp,vtpu,resistwp,resistch, + &stargamma,kco,co2i,alpha,rd,ilimittype,iminimum,anet,co2c, + &realizedfjelect,co2i_obs,co2c_wp,anet_wp) + implicit none +! +!Calculates the net assimilation rate once all parameters are given at measurement conditions +!------------------ Inputs ----------------------------------- +!ilimittype: limitation types to evaluate +! 1 = Rubisco,RuBp and TPU limitations +! 2 = Rubisco and RuBp limitations only +! 3 = Rubisco and TPU limitations only +! 4 = RuBp and TPU limitations only +! 5 = Rubisco limitation only +! 6 = RuBp limitation only +! 7 = TPU limitation only +!vcmax (if ilimittype=1,2,3,5), maximum carboxylation rate limited by Rubisco (umol m-2 s-1) +!jrubp (if ilimittype=1,2,4,6), electron transport rate (umol m-2 s-1) +!vtpu (if ilimittype=1,3,4,7), triose phosphate export rate from chloroplast (umol m-2 s-1) +!resistwp: resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!stargamma, chloraplatic CO2 photocompensation point (Pa) +!kco,(if ilimittype=1,2,3,5), Kc(1+O/Ko), (Pa) +!co2i, intercellular CO2 partial pressure (Pa) +!alpha, (if ilimittype=1,3,4,7), fraction of glycolate carbon not returned to the chloroplast (0-1, dimensionless) +!rd, mitochondrial respiration in the light (umol m-2 s-1). +!------------------ Outputs ---------------------------------- +!anet: the net assimilation rate (umol m-2 s-1) +!iminimum, which limitation type is actually present Rubisco (1), RuBp(2), and TPU (3) +!realizedfjelect: the realized electron transport rate <= jrubp (=when RuBP regeneration limits photosynthesis). + integer ilimittype,iminimum,idorubisco,idorubp,idotpu + double precision vcmax,jrubp,vtpu,stargamma,kco,co2i, + &alpha,rd,anet,wc,wj,wp,anet_wp,term1,term2,co2c,co2i_wc,co2i_wj, + &co2i_wp,co2c_wc,co2c_wj,co2c_wp,rwp,resistwp,rch,resistch, + &realizedfjelect,co2i_obs + wc=1.0d+10 + wj=1.0d+15 + wp=1.0d+20 + co2i=-9999.0d0 + anet_wp=-9999.0d0 + co2c_wp=-9999.0d0 + co2i_wp=-9999.0d0 + realizedfjelect=-9999.0d0 + rwp=dmax1(0.0d0,resistwp) + rch=dmax1(0.0d0,resistch) +!This way of initialization is deliberate. If co2c <0, the priority of limitation +!state is Rubisco, RuBP regeneration, TPU + idorubisco=0 + idorubp=0 + idotpu=0 + iminimum=0 + if(ilimittype.le.3.or.ilimittype.eq.5)then + idorubisco=1 + endif + if(ilimittype.le.2.or.ilimittype.eq.4.or. + & ilimittype.eq.6)then + idorubp=1 + endif + if(ilimittype.eq.1.or.ilimittype.eq.3.or. + & ilimittype.eq.4.or.ilimittype.eq.7)then + idotpu=1 + endif + if(idorubisco.eq.1)then +! x=vcmax +! y=1.0d0 +! z=kco + call getCO2ibackwards(vcmax,1.0d0,kco,anet,rwp,rch,rd,stargamma, + &co2i_wc,co2c_wc) + if(co2c_wc.gt.0.0d0)wc=co2c_wc*vcmax/(co2c_wc+kco) + endif + if(idorubp.eq.1)then +! x=jrubp +! y=4.0d0 + term1=8.0d0*stargamma + call getCO2ibackwards(jrubp,4.0d0,term1,anet,rwp,rch,rd, + &stargamma,co2i_wj,co2c_wj) + if(co2c_wj.gt.0.0d0)wj= + &co2c_wj*jrubp/(4.0d0*co2c_wj+8.0d0*stargamma) + endif + if(idotpu.eq.1)then + if(alpha.gt.0.0d0)then + term1=3.0d0*vtpu + term2=-(1.0d0+3.0d0*alpha)*stargamma + call getCO2ibackwards(term1,1.0d0,term2,anet,rwp,rch,rd, + &stargamma,co2i_wp,co2c_wp) + if(co2c_wp.gt.(-term2))wp=co2c_wp*term1/(co2c_wp+term2) + else +!CO2i is undefined for alpha=0 so we use the normal forward mode; in this case, CO2i is an input +!and anet is an output. + term1=3.0d0*vtpu + term2=-stargamma + call findco2c(term1,term2,co2i_obs,rd,stargamma,rwp,rch, + &co2c_wp) + co2i_wp=co2i_obs + if(co2c_wp.gt.stargamma)wp= + &co2c_wp*3.0d0*vtpu/(co2c_wp-stargamma) + anet_wp=3.0d0*vtpu-rd + endif + endif + if(ilimittype.ge.5)then + if(ilimittype.eq.5)then + iminimum=1 + co2i=co2i_wc + co2c=co2c_wc + endif + if(ilimittype.eq.6)then + iminimum=2 + co2i=co2i_wj + co2c=co2c_wj + endif + if(ilimittype.eq.7)then + iminimum=3 + co2i=co2i_wp + co2c=co2c_wp + endif + else + if(wc.lt.wj)then + if(wc.le.wp)then + co2i=co2i_wc + co2c=co2c_wc + iminimum=1 + else + co2i=co2i_wp + co2c=co2c_wp + iminimum=3 + endif + else + if(wj.le.wp)then + co2i=co2i_wj + co2c=co2c_wj + iminimum=2 + else + co2i=co2i_wp + co2c=co2c_wp + iminimum=3 + endif + endif + endif + if(iminimum.eq.2)then + realizedfjelect=jrubp + else + if(co2c.eq.stargamma)then + realizedfjelect=0.0d0 + else + realizedfjelect= + &(anet+rd)*(4.0d0*co2c+8.0d0*stargamma)/(co2c-stargamma) + endif + endif + return + end subroutine CO2i_Final +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine getCO2ibackwards(x,y,z,anet,rwp,rch,rd,stargamma, + &co2i,co2c) + implicit none +!Calculate CO2i and CO2c from anet +!Vc=xCO2c/(yCO2c+z) +!Rubisco: x=Vcmax, y=1, z=kco +!RuBP: x=jrubp, y=4, z=8*stargamma +!TPU: x=3*tpu, y=1, z=-(1+3*alpha)*stargamma +! + double precision x,y,z,anet,rwp,rch,rd,stargamma,co2i,co2c + co2c=(x*stargamma+z*(anet+rd))/(x-(anet+rd)*y) + co2i=co2c*(1.0d0+x*rch/(y*co2c+z))+anet*rwp + return + end diff --git a/leafres/testarea/FreeCombinatorial.f b/leafres/testarea/FreeCombinatorial.f new file mode 100644 index 0000000..c58e34d --- /dev/null +++ b/leafres/testarea/FreeCombinatorial.f @@ -0,0 +1,385 @@ + subroutine FreeCombinatorial() + include '../testarea/LeafGasHybridFit.h' + integer + &i01,i02,i03,i04,i05,i06,i07,i08,i09,i10, + &i11,i12,i13,i14,i15,i16,i17,i18,i19,i20, + &i21,i22,i23,i24,i25,i26,i27,i28,i29,i30, + &i31,i32,i33,i34,i35,i36,i37,i38,i39,i40, + &i41,i42,i43,i44,i45,i46,i47,i48,i49,i50, + &maxfreeruns + double precision ran2,r + if(nFreePoints.eq.0)then + call UnivPhotoFit() + return + endif + if(nFreePoints.gt.5)then + maxfreeruns=100 + do i01=1,maxfreeruns + do i02=1,nFreePoints + r=ran2() + if(r.lt.0.35d0)then + Freeiphotolimit(i02)=1 + else + if(r.gt.0.65d0)then + Freeiphotolimit(i02)=2 + else + Freeiphotolimit(i02)=3 + endif + endif + enddo + call UnivPhotoFit() + enddo + return + endif + do 1 i01=1,3 + Freeiphotolimit(1)=i01 + if(nFreePoints.eq.1)then + call UnivPhotoFit() + goto 1 + endif + do 2 i02=1,3 + Freeiphotolimit(2)=i02 + if(nFreePoints.eq.2)then + call UnivPhotoFit() + goto 2 + endif + do 3 i03=1,3 + Freeiphotolimit(3)=i03 + if(nFreePoints.eq.3)then + call UnivPhotoFit() + goto 3 + endif + do 4 i04=1,3 + Freeiphotolimit(4)=i04 + if(nFreePoints.eq.4)then + call UnivPhotoFit() + goto 4 + endif + do 5 i05=1,3 + Freeiphotolimit(5)=i05 + if(nFreePoints.eq.5)then + call UnivPhotoFit() + goto 5 + endif + do 6 i06=1,3 + Freeiphotolimit(6)=i06 + if(nFreePoints.eq.6)then + call UnivPhotoFit() + goto 6 + endif + do 7 i07=1,3 + Freeiphotolimit(7)=i07 + if(nFreePoints.eq.7)then + call UnivPhotoFit() + goto 7 + endif + do 8 i08=1,3 + Freeiphotolimit(8)=i08 + if(nFreePoints.eq.8)then + call UnivPhotoFit() + goto 8 + endif + do 9 i09=1,3 + Freeiphotolimit(9)=i09 + if(nFreePoints.eq.9)then + call UnivPhotoFit() + goto 9 + endif + do 10 i10=1,3 + Freeiphotolimit(10)=i10 + if(nFreePoints.eq.10)then + call UnivPhotoFit() + goto 10 + endif + do 11 i11=1,3 + Freeiphotolimit(11)=i11 + if(nFreePoints.eq.11)then + call UnivPhotoFit() + goto 11 + endif + do 12 i12=1,3 + Freeiphotolimit(12)=i12 + if(nFreePoints.eq.12)then + call UnivPhotoFit() + goto 12 + endif + do 13 i13=1,3 + Freeiphotolimit(13)=i13 + if(nFreePoints.eq.13)then + call UnivPhotoFit() + goto 13 + endif + do 14 i14=1,3 + Freeiphotolimit(14)=i14 + if(nFreePoints.eq.14)then + call UnivPhotoFit() + goto 14 + endif + do 15 i15=1,3 + Freeiphotolimit(15)=i15 + if(nFreePoints.eq.15)then + call UnivPhotoFit() + goto 15 + endif + do 16 i16=1,3 + Freeiphotolimit(16)=i16 + if(nFreePoints.eq.16)then + call UnivPhotoFit() + goto 16 + endif + do 17 i17=1,3 + Freeiphotolimit(17)=i17 + if(nFreePoints.eq.17)then + call UnivPhotoFit() + goto 17 + endif + do 18 i18=1,3 + Freeiphotolimit(18)=i18 + if(nFreePoints.eq.18)then + call UnivPhotoFit() + goto 18 + endif + do 19 i19=1,3 + Freeiphotolimit(19)=i19 + if(nFreePoints.eq.19)then + call UnivPhotoFit() + goto 19 + endif + do 20 i20=1,3 + Freeiphotolimit(20)=i20 + if(nFreePoints.eq.20)then + call UnivPhotoFit() + goto 20 + endif + do 21 i21=1,3 + Freeiphotolimit(21)=i21 + if(nFreePoints.eq.21)then + call UnivPhotoFit() + goto 21 + endif + do 22 i22=1,3 + Freeiphotolimit(22)=i22 + if(nFreePoints.eq.22)then + call UnivPhotoFit() + goto 22 + endif + do 23 i23=1,3 + Freeiphotolimit(23)=i23 + if(nFreePoints.eq.23)then + call UnivPhotoFit() + goto 23 + endif + do 24 i24=1,3 + Freeiphotolimit(24)=i24 + if(nFreePoints.eq.24)then + call UnivPhotoFit() + goto 24 + endif + do 25 i25=1,3 + Freeiphotolimit(25)=i25 + if(nFreePoints.eq.25)then + call UnivPhotoFit() + goto 25 + endif + do 26 i26=1,3 + Freeiphotolimit(26)=i26 + if(nFreePoints.eq.26)then + call UnivPhotoFit() + goto 26 + endif + do 27 i27=1,3 + Freeiphotolimit(27)=i27 + if(nFreePoints.eq.27)then + call UnivPhotoFit() + goto 27 + endif + do 28 i28=1,3 + Freeiphotolimit(28)=i28 + if(nFreePoints.eq.28)then + call UnivPhotoFit() + goto 28 + endif + do 29 i29=1,3 + Freeiphotolimit(29)=i29 + if(nFreePoints.eq.29)then + call UnivPhotoFit() + goto 29 + endif + do 30 i30=1,3 + Freeiphotolimit(30)=i30 + if(nFreePoints.eq.30)then + call UnivPhotoFit() + goto 30 + endif + do 31 i31=1,3 + Freeiphotolimit(31)=i31 + if(nFreePoints.eq.31)then + call UnivPhotoFit() + goto 31 + endif + do 32 i32=1,3 + Freeiphotolimit(32)=i32 + if(nFreePoints.eq.32)then + call UnivPhotoFit() + goto 32 + endif + do 33 i33=1,3 + Freeiphotolimit(33)=i33 + if(nFreePoints.eq.33)then + call UnivPhotoFit() + goto 33 + endif + do 34 i34=1,3 + Freeiphotolimit(34)=i34 + if(nFreePoints.eq.34)then + call UnivPhotoFit() + goto 34 + endif + do 35 i35=1,3 + Freeiphotolimit(35)=i35 + if(nFreePoints.eq.35)then + call UnivPhotoFit() + goto 35 + endif + do 36 i36=1,3 + Freeiphotolimit(36)=i36 + if(nFreePoints.eq.36)then + call UnivPhotoFit() + goto 36 + endif + do 37 i37=1,3 + Freeiphotolimit(37)=i37 + if(nFreePoints.eq.37)then + call UnivPhotoFit() + goto 37 + endif + do 38 i38=1,3 + Freeiphotolimit(38)=i38 + if(nFreePoints.eq.38)then + call UnivPhotoFit() + goto 38 + endif + do 39 i39=1,3 + Freeiphotolimit(39)=i39 + if(nFreePoints.eq.39)then + call UnivPhotoFit() + goto 39 + endif + do 40 i40=1,3 + Freeiphotolimit(40)=i40 + if(nFreePoints.eq.40)then + call UnivPhotoFit() + goto 40 + endif + do 41 i41=1,3 + Freeiphotolimit(41)=i41 + if(nFreePoints.eq.41)then + call UnivPhotoFit() + goto 41 + endif + do 42 i42=1,3 + Freeiphotolimit(42)=i42 + if(nFreePoints.eq.42)then + call UnivPhotoFit() + goto 42 + endif + do 43 i43=1,3 + Freeiphotolimit(43)=i43 + if(nFreePoints.eq.43)then + call UnivPhotoFit() + goto 43 + endif + do 44 i44=1,3 + Freeiphotolimit(44)=i44 + if(nFreePoints.eq.44)then + call UnivPhotoFit() + goto 44 + endif + do 45 i45=1,3 + Freeiphotolimit(45)=i45 + if(nFreePoints.eq.45)then + call UnivPhotoFit() + goto 45 + endif + do 46 i46=1,3 + Freeiphotolimit(46)=i46 + if(nFreePoints.eq.46)then + call UnivPhotoFit() + goto 46 + endif + do 47 i47=1,3 + Freeiphotolimit(47)=i47 + if(nFreePoints.eq.47)then + call UnivPhotoFit() + goto 47 + endif + do 48 i48=1,3 + Freeiphotolimit(48)=i48 + if(nFreePoints.eq.48)then + call UnivPhotoFit() + goto 48 + endif + do 49 i49=1,3 + Freeiphotolimit(49)=i49 + if(nFreePoints.eq.49)then + call UnivPhotoFit() + goto 49 + endif + do 50 i50=1,3 + Freeiphotolimit(50)=i50 + if(nFreePoints.eq.50)then + call UnivPhotoFit() + goto 50 + endif +50 continue +49 continue +48 continue +47 continue +46 continue +45 continue +44 continue +43 continue +42 continue +41 continue +40 continue +39 continue +38 continue +37 continue +36 continue +35 continue +34 continue +33 continue +32 continue +31 continue +30 continue +29 continue +28 continue +27 continue +26 continue +25 continue +24 continue +23 continue +22 continue +21 continue +20 continue +19 continue +18 continue +17 continue +16 continue +15 continue +14 continue +13 continue +12 continue +11 continue +10 continue +9 continue +8 continue +7 continue +6 continue +5 continue +4 continue +3 continue +2 continue +1 continue + return + end subroutine FreeCombinatorial diff --git a/leafres/testarea/HybridCombinatorial.f b/leafres/testarea/HybridCombinatorial.f new file mode 100644 index 0000000..bace95a --- /dev/null +++ b/leafres/testarea/HybridCombinatorial.f @@ -0,0 +1,732 @@ +!We consider four types of leaf gas exchange measurements. These four types must be clearly indicated in the input: +!1. Points whose limitation states are known from other means (e.g. chlorophyll fluorescence): these points will be called fixed points and +! their limitation states will not be changed by the parameter estimation program. +!2. Points from conventional CO2 response measurements (A/Ci curves) that are done without fluorescence. Limitation states are not known but follow +! the order of Rubisco, RuBP and TPU along the CO2i axis as suggested in Gu et al. (2010) PCE paper. We call these points ACi points. +! The ACi points must be already ordered from low to high CO2i. +!3. Points from conventional light response measurements (A/PAR curves) that are done without fluorescence. Limitation states are not known but follow +! the order of RuBP, Rubisco and TPU along the PAR axis. We call these points ALight points. The ALight points must be already ordered from low to high PAR. +!4. Points whose limitation states follow no order. We call these points free points. They are obtained with no control of environmental conditions. + subroutine HybridCombinatorial() + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' + integer i,j,k,m,mm,n,iacirubismin(numACicurves), + &iacirubismax(numACicurves),iacitpumin(numACicurves), + &iacitpumax(numACicurves),ialightrubismin(numALightcurves), + &ialighttpumin(numALightcurves),ilastrubis1,ilastrubp1, + &ilastrubis2,ilastrubp2,ilastrubis3,ilastrubp3,ilastrubis4, + &ilastrubp4,ilastrubis5,ilastrubp5,ilastrubis6,ilastrubp6, + &ilastrubis7,ilastrubp7,ilastrubis8,ilastrubp8, + &ilastrubis9,ilastrubp9,ilastrubis10,ilastrubp10, + &ilastrubis11,ilastrubp11,ilastrubis12,ilastrubp12, + &ilastrubis13,ilastrubp13,ilastrubis14,ilastrubp14, + &ilastrubis15,ilastrubp15,k1,k2,k3,k4,k5,k6,k7,k8, + &k9,k10,k11,k12,k13,k14,k15,ilasttpu1,ilasttpu2, + &ilasttpu3,ilasttpu4,ilasttpu5,ilasttpu6,ilasttpu7, + &ilasttpu8,ilasttpu9,ilasttpu10,ilasttpu11,ilasttpu12, + &ilasttpu13,ilasttpu14,ilasttpu15 + double precision rdlight,atp,resistwp,resistch,stargamma, + &realizedfjelect,term +! +!common block variables:idokco,idoalpha,minimumrubis,minimumfj,minimumvt,nACiPoints,ACiiphotolimit(nACiPoints) + minimumfj=2 + if(idokc.eq.0.and.idoko.eq.0)then + minimumrubis=2 + else + if(idokc.eq.0.or.idoko.eq.0)then + minimumrubis=3 + else + minimumrubis=4 + endif + endif + if((nFixedPoints+numACicurves+nFreePoints).eq.0)minimumrubis=2 + if(idoalpha.eq.0)then + minimumvt=2 + else + minimumvt=3 + endif + i=0 + do k1=1,numACicurves + do k2=nendaci(k1)+1,nACiPoints(k1) + i=i+1 + enddo + enddo + if(i.gt.0)minimumvt=i +! + ntotunivparams=19 + univparamsmin(1)=resistwp25min + univparamsmax(1)=resistwp25max + univparamsmin(2)=resistch25min + univparamsmax(2)=resistch25max + univparamsmin(3)=rdlight25min + univparamsmax(3)=rdlight25max + univparamsmin(4)=stargamma25min + univparamsmax(4)=stargamma25max + univparamsmin(5)=vcmax25min + univparamsmax(5)=vcmax25max + univparamsmin(6)=fkc25min + univparamsmax(6)=fkc25max + univparamsmin(7)=fko25min + univparamsmax(7)=fko25max + univparamsmin(8)=fjmax25min + univparamsmax(8)=fjmax25max + univparamsmin(9)=tpu25min + univparamsmax(9)=tpu25max + univparamsmin(10)=alpha25min + univparamsmax(10)=alpha25max + univparamsmin(11)=phifactormin + univparamsmax(11)=phifactormax + univparamsmin(12)=thetafactormin + univparamsmax(12)=thetafactormax + univparamsmin(13)=betaPSIImin + univparamsmax(13)=betaPSIImax + univparamsmin(14)=ha_darkrespmin + univparamsmax(14)=ha_darkrespmax + univparamsmin(15)=ha_stargammamin + univparamsmax(15)=ha_stargammamax + univparamsmin(16)=ha_vcmaxmin + univparamsmax(16)=ha_vcmaxmax + univparamsmin(17)=ha_jmaxmin + univparamsmax(17)=ha_jmaxmax + univparamsmin(18)=ha_tpumin + univparamsmax(18)=ha_tpumax + univparamsmin(19)=ha_gmesomin + univparamsmax(19)=ha_gmesomax + bestilimittype=-9999 + do ilastrubis1=1,7 + subbestsumsquare(ilastrubis1)=1.0d+100 + subbestunivparams(1,ilastrubis1)=resistwp25_ori + subbestunivparams(2,ilastrubis1)=resistch25_ori + subbestunivparams(3,ilastrubis1)=rdlight25_ori + subbestunivparams(4,ilastrubis1)=stargamma25_ori + subbestunivparams(5,ilastrubis1)=vcmax25_ori + subbestunivparams(6,ilastrubis1)=fkc25_ori + subbestunivparams(7,ilastrubis1)=fko25_ori + subbestunivparams(8,ilastrubis1)=fjmax25_ori + subbestunivparams(9,ilastrubis1)=tpu25_ori + subbestunivparams(10,ilastrubis1)=alpha25_ori + subbestunivparams(11,ilastrubis1)=phifactor_ori + subbestunivparams(12,ilastrubis1)=thetafactor_ori + subbestunivparams(13,ilastrubis1)=betaPSII_ori + subbestunivparams(14,ilastrubis1)=ha_darkresp_ori + subbestunivparams(15,ilastrubis1)=ha_stargamma_ori + subbestunivparams(16,ilastrubis1)=ha_vcmax_ori + subbestunivparams(17,ilastrubis1)=ha_jmax_ori + subbestunivparams(18,ilastrubis1)=ha_tpu_ori + subbestunivparams(19,ilastrubis1)=ha_gmeso_ori + do i=1,ntotsamples + subbestiphotolimit(i,ilastrubis1)=-9999 + enddo + enddo + do i=1,ntotsamples + forcings(i,1)=pco2i_ori(i) + forcings(i,2)=aPPFDlf_ori(i) + forcings(i,3)=templeaf_ori(i) + forcings(i,4)=po2i_ori(i) + responses(i,1)=anet_obs(i) + weitforcings(i,1)=1.0d0 + weitforcings(i,2)=1.0d0 + weitforcings(i,3)=1.0d0 + weitforcings(i,4)=1.0d0 + weitresponses(i,1)=1.0d0 + if(ntotphips2.ge.1)then + if(chlflphips2_ori(i).gt.0.0d0)then +!for least square regression + responses(i,2)=chlflphips2_ori(i) +!a factor of 100 makes PhiPSII comparable to Anet in magnitude + weitresponses(i,2)=100.0d0 + else + responses(i,2)=chlflphips2_ori(i) + weitresponses(i,2)=0.0d0 + endif + endif + if(Prioriknowlimit.eq.-1)then +!fluorescence fit only. chlflphips2 becomes a forcing variable + forcings(i,5)=chlflphips2_ori(i) + weitforcings(i,5)=1.0d0 + if(chlflphips2_ori(i).le.0.0d0)then + weitforcings(i,5)=0.0d0 + weitresponses(i,1)=0.0d0 + endif + endif + enddo + do i=1,12 + gacontrol(i)=-1.0d0 + enddo + gacontrol(1)=500.0d0 + gacontrol(2)=10000.0d0 + gacontrol(3)=8.0d0 +!Priorilimittype: indicator for the choice of overall mixtures of limitation types +! = 1, Rubisco+RuBP+TPU +! = 2, Rubisco+RuBP +! = 3, Rubisco+TPU +! = 4, RuBP+TPU +! = 5, Rubisco Only +! = 6, RuBP Only +! = 7, TPU Only + +!Prioriknowlimit: indicator for how the limitation type of each point is set before the fitting +! = 0, the limitation type of each individual point has not been pre-set when mixed +! limitation states are present in the dataset. When Priorilimittype = 5, 6, 7, +! all points are limited by one type. +! = 1, the limit type of each individual point has been pre-set. Don't allow the fitting +! algorithm to change the limitation type of each point during the first fit. But +! check the admissibility after the first fit. If the admissibility is violated, +! treat the osicilation points as colimited; if there is no osicilation, use the penalty +! approach to refit. +! = 2, the limit type of each individual point has been pre-set. Allow the fitting +! algorithm to change the limitation type of each point during the fit. Penalize any fit +! that results in any point to have a limitation type different from the pre-set type. +! =-1, only do a fluorescence fit +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + if(Prioriknowlimit.eq.-1)then +!fluorescence only fit + Priorilimittype=6 + Currentilimittype=Priorilimittype + Currentiknowlimit=Prioriknowlimit +!we pass UnivPhotoFit and call DoUnivPhotoFit directly + call DoUnivPhotoFit() + if(numALightcurves.gt.0.and.idorch.eq.1)then +!we only need to call fluorescencemax once. + call fluorescencejmax() + endif + return + endif +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + k1=0 + do i=1,numACicurves + if(nendaci(i).lt.nACiPoints(i))k1=1 +!TPU limitation must be present + enddo + k2=0 + do i=1,numALightcurves + if(nstartalight(i).gt.1)k2=1 +!RuBP points must be present + enddo + Prioriknowlimit=0 + bestsumsquare=1.0d+100 + do Priorilimittype=1,7 + if(k1.eq.1)then + if(Priorilimittype.eq.2.or.Priorilimittype.eq.5 + &.or.Priorilimittype.eq.6)goto 2001 + endif + if(k2.eq.1)then + if(Priorilimittype.eq.3.or.Priorilimittype.eq.5 + &.or.Priorilimittype.eq.7)goto 2001 + endif + if(Priorilimittype.gt.4)then + gacontrol(1)=100.0d0 + gacontrol(2)=1000.0d0 + endif + call UnivPhotoFit() + if(subbestsumsquare(Priorilimittype).le.bestsumsquare)then + bestilimittype=Priorilimittype + bestsumsquare=subbestsumsquare(Priorilimittype) + do i=1,ntotunivparams + bestunivparams(i)=subbestunivparams(i,Priorilimittype) + enddo + do i=1,ntotsamples + bestiphotolimit(i)=subbestiphotolimit(i,Priorilimittype) + enddo + endif +2001 continue + enddo + +! goto 1000 + + gacontrol(1)=200.0d0 + gacontrol(2)=2000.0d0 +!------------------------------------------------------------------- + k=nFixedPoints + do i=1,numACicurves +!Find the position (iacirubismin) of the last point of the first continuous rubisco section. +! However, if the curve does not start with rubisco points, iacirubismin=0 +!Find the position (iacirubismax) of the last rubisco point of the whole curve +! If the curve does not contain any rubusco points, iacirubismax=0 +!Find the position (iacitpumin) of the first tpu point of the whole curve + iacirubismin(i)=0 + iacirubismax(i)=0 + iacitpumin(i)=nACiPoints(i)+1 + n=0 + m=0 + do j=1,nACiPoints(i) + k=k+1 + if(bestiphotolimit(k).eq.1)then + if(n.eq.0)iacirubismin(i)=j + iacirubismax(i)=j + else + n=1 + if(bestiphotolimit(k).eq.3.and.m.eq.0)then + iacitpumin(i)=j + m=1 + endif + endif + enddo + if(iacirubismin(i).eq.0)then + iacirubismax(i)=nendaci(i) + else + iacirubismin(i)=max0(0,iacirubismin(i)-2) + iacirubismax(i)=min0(nendaci(i),iacirubismax(i)+2) + endif + iacitpumax(i)=iacitpumin(i) + iacitpumin(i)=max0(nstartaci(i),iacitpumin(i)-2) + iacitpumin(i)=min0(nendaci(i)-2,iacitpumin(i)) + iacitpumin(i)=max0(0,iacitpumin(i)) + iacitpumax(i)=min0(nendaci(i),nACiPoints(i),iacitpumax(i)+2) + enddo + do i=1,numALightcurves +!Find the position (iacirubismin) of the last point of the first continuous rubisco section. +! However, if the curve does not start with rubisco points, iacirubismin=0 +!Find the position (iacirubismax) of the last rubisco point of the whole curve +! If the curve does not contain any rubusco points, iacirubismax=0 +!Find the position (iacitpumin) of the first tpu point of the whole curve + ialightrubpmin(i)=0 + ialightrubpmax(i)=0 + ialighttpumin(i)=nALightPoints(i)+1 + ialightrubismin(i)=nALightPoints(i)+1 + n=0 + m=0 + mm=0 + do j=1,nALightPoints(i) + k=k+1 + if(bestiphotolimit(k).eq.2)then + if(n.eq.0)ialightrubpmin(i)=j + ialightrubpmax(i)=j + else + n=1 + if(bestiphotolimit(k).eq.3.and.m.eq.0)then + ialighttpumin(i)=j + m=1 + endif + if(bestiphotolimit(k).eq.1.and.mm.eq.0)then + ialightrubismin(i)=j + mm=1 + endif + endif + enddo + ialightrubpmin(i)=max0(0,ialightrubpmin(i)-2,nstartalight(i)) + ialightrubpmax(i)=min0(nendalight(i),ialightrubpmax(i)+2) + ialightrubpmax(i)=max0(ialightrubpmax(i),ialightrubpmin(i)+2) +!we generally assume the points of an A/Light curve are lined up in a sequence of (RuBP, TPU and Rubisco), +!which is indicated by ialightorder=0. However, if Ci increases steadily from nstartalight to the end, we +!assume a sequence of (RuBP, Rubisco and TPU),which is indicated by ialightorder=2. + ialightmin(i)=nALightPoints(i) + ialightmax(i)=nALightPoints(i) + if(ialighttpumin(i).lt.ialightrubismin(i))then +!(RuBP,TPU,Rubisco) + ialightorder(i)=0 + if(ialightrubismin(i).le.nALightPoints(i))then + ialightmin(i)=max0(ialightrubismin(i)-2,nstartalight(i)) + ialightmax(i)=ialightrubismin(i)+2 + endif + else + if(ialighttpumin(i).gt.ialightrubismin(i))then +!(RuBP,Rubisco,TPU) + ialightorder(i)=2 + if(ialighttpumin(i).le.nALightPoints(i))then + ialightmin(i)=max0(ialighttpumin(i)-2,nstartalight(i)) + ialightmax(i)=ialighttpumin(i)+2 + endif + endif + endif + ialightmax(i)=max0(ialightrubpmax(i)+1,ialightmax(i)) + ialightmax(i)=min0(nALightPoints(i),ialightmax(i)) + if(ialightmax(i).lt.ialightmin(i))ialightmin(i)=ialightmax(i) + enddo +!------------------------------------------------------------------- + bestilimittype=-9999 + Prioriknowlimit=1 + Priorilimittype=-9999 +! +c gacontrol( 1) - number of individuals in a population (default +c is 100) +c gacontrol( 2) - number of generations over which solution is +c to evolve (default is 500) +c gacontrol( 3) - number of significant digits (i.e., number of +c genes) retained in chromosomal encoding (default +c is 6) (Note: This number is limited by the +c machine floating point precision. Most 32-bit +c floating point representations have only 6 full +c digits of precision. To achieve greater preci- +c sion this routine could be converted to double +c precision, but note that this would also require +c a double precision random number generator, which +c likely would not have more than 9 digits of +c precision if it used 4-byte integers internally.) +c gacontrol( 4) - crossover probability; must be <= 1.0 (default +c is 0.85). If crossover takes place, either one +c or two splicing points are used, with equal +c probabilities +c gacontrol( 5) - mutation mode; 1/2/3/4/5 (default is 2) +c 1=one-point mutation, fixed rate +c 2=one-point, adjustable rate based on fitness +c 3=one-point, adjustable rate based on distance +c 4=one-point+creep, fixed rate +c 5=one-point+creep, adjustable rate based on fitness +c 6=one-point+creep, adjustable rate based on distance +c gacontrol( 6) - initial mutation rate; should be small (default +c is 0.005) (Note: the mutation rate is the proba- +c bility that any one gene locus will mutate in +c any one generation.) +c gacontrol( 7) - minimum mutation rate; must be >= 0.0 (default +c is 0.0005) +c gacontrol( 8) - maximum mutation rate; must be <= 1.0 (default +c is 0.25) +c gacontrol( 9) - relative fitness differential; range from 0 +c (none) to 1 (maximum). (default is 1.) +c gacontrol(10) - reproduction plan; 1/2/3=Full generational +c replacement/Steady-state-replace-random/Steady- +c state-replace-worst (default is 3) +c gacontrol(11) - elitism flag; 0/1=off/on (default is 0) +c (Applies only to reproduction plans 1 and 2) +c gacontrol(12) - printed output 0/1/2=None/Minimal/Verbose +c (default is 0) +c + if(numACicurves.eq.0)then +!no conventional A/Ci curves. go to light response curves directly. + call ALightCombinatorial() + goto 1000 + endif +!Assume rubisco, rubp and tpu limitations in the order of (rubisco, rubp, tpu) but any limitation can be missing in any ACi curves. +!The nACiPoints points of each ACi curve must have been already ordered from low to high Ci within each individual ACi curve. + do ilastrubis1=iacirubismin(1),iacirubismax(1) + do i=1,ilastrubis1 + ACiiphotolimit(i,1)=1 + enddo + k1=max0(ilastrubis1,iacitpumin(1)) + do 1 ilasttpu1=k1,iacitpumax(1) + do i=ilasttpu1+1,nACiPoints(1) + ACiiphotolimit(i,1)=3 + enddo + do i=ilastrubis1+1,ilasttpu1 + ACiiphotolimit(i,1)=2 + enddo + if(numACicurves.eq.1)then + call ALightCombinatorial() + goto 1 + endif + + do ilastrubis2=iacirubismin(2),iacirubismax(2) + do i=1,ilastrubis2 + ACiiphotolimit(i,2)=1 + enddo + k2=max0(ilastrubis2,iacitpumin(2)) + do 2 ilasttpu2=k2,iacitpumax(2) + do i=ilasttpu2+1,nACiPoints(2) + ACiiphotolimit(i,2)=3 + enddo + do i=ilastrubis2+1,ilasttpu2 + ACiiphotolimit(i,2)=2 + enddo + if(numACicurves.eq.2)then + call ALightCombinatorial() + goto 2 + endif + + do ilastrubis3=iacirubismin(3),iacirubismax(3) + do i=1,ilastrubis3 + ACiiphotolimit(i,3)=1 + enddo + k3=max0(ilastrubis3,iacitpumin(3)) + do 3 ilasttpu3=k3,iacitpumax(3) + do i=ilasttpu3+1,nACiPoints(3) + ACiiphotolimit(i,3)=3 + enddo + do i=ilastrubis3+1,ilasttpu3 + ACiiphotolimit(i,3)=2 + enddo + if(numACicurves.eq.3)then + call ALightCombinatorial() + goto 3 + endif + + do ilastrubis4=iacirubismin(4),iacirubismax(4) + do i=1,ilastrubis4 + ACiiphotolimit(i,4)=1 + enddo + k4=max0(iacitpumin(4),ilastrubis4) + do 4 ilasttpu4=k4,iacitpumax(4) + do i=ilasttpu4+1,nACiPoints(4) + ACiiphotolimit(i,4)=3 + enddo + do i=ilastrubis4+1,ilasttpu4 + ACiiphotolimit(i,4)=2 + enddo + if(numACicurves.eq.4)then + call ALightCombinatorial() + goto 4 + endif + + do ilastrubis5=iacirubismin(5),iacirubismax(5) + do i=1,ilastrubis5 + ACiiphotolimit(i,5)=1 + enddo + k5=max0(iacitpumin(5),ilastrubis5) + do 5 ilasttpu5=k5,iacitpumax(5) + do i=ilasttpu5+1,nACiPoints(5) + ACiiphotolimit(i,5)=3 + enddo + do i=ilastrubis5+1,ilasttpu5 + ACiiphotolimit(i,5)=2 + enddo + if(numACicurves.eq.5)then + call ALightCombinatorial() + goto 5 + endif + + do ilastrubis6=iacirubismin(6),iacirubismax(6) + do i=1,ilastrubis6 + ACiiphotolimit(i,6)=1 + enddo + k6=max0(iacitpumin(6),ilastrubis6) + do 6 ilasttpu6=k6,iacitpumax(6) + do i=ilasttpu6+1,nACiPoints(6) + ACiiphotolimit(i,6)=3 + enddo + do i=ilastrubis6+1,ilasttpu6 + ACiiphotolimit(i,6)=2 + enddo + if(numACicurves.eq.6)then + call ALightCombinatorial() + goto 6 + endif + + do ilastrubis7=iacirubismin(7),iacirubismax(7) + do i=1,ilastrubis7 + ACiiphotolimit(i,7)=1 + enddo + k7=max0(iacitpumin(7),ilastrubis7) + do 7 ilasttpu7=k7,iacitpumax(7) + do i=ilasttpu7+1,nACiPoints(7) + ACiiphotolimit(i,7)=3 + enddo + do i=ilastrubis7+1,ilasttpu7 + ACiiphotolimit(i,7)=2 + enddo + if(numACicurves.eq.7)then + call ALightCombinatorial() + goto 7 + endif + + do ilastrubis8=iacirubismin(8),iacirubismax(8) + do i=1,ilastrubis8 + ACiiphotolimit(i,8)=1 + enddo + k8=max0(iacitpumin(8),ilastrubis8) + do 8 ilasttpu8=k8,iacitpumax(8) + do i=ilasttpu8+1,nACiPoints(8) + ACiiphotolimit(i,8)=3 + enddo + do i=ilastrubis8+1,ilasttpu8 + ACiiphotolimit(i,8)=2 + enddo + if(numACicurves.eq.8)then + call ALightCombinatorial() + goto 8 + endif + + do ilastrubis9=iacirubismin(9),iacirubismax(9) + do i=1,ilastrubis9 + ACiiphotolimit(i,9)=1 + enddo + k9=max0(iacitpumin(9),ilastrubis9) + do 9 ilasttpu9=k9,iacitpumax(9) + do i=ilasttpu9+1,nACiPoints(9) + ACiiphotolimit(i,9)=3 + enddo + do i=ilastrubis9+1,ilasttpu9 + ACiiphotolimit(i,9)=2 + enddo + if(numACicurves.eq.9)then + call ALightCombinatorial() + goto 9 + endif + + do ilastrubis10=iacirubismin(10),iacirubismax(10) + do i=1,ilastrubis10 + ACiiphotolimit(i,10)=1 + enddo + k10=max0(iacitpumin(10),ilastrubis10) + do 10 ilasttpu10=k10,iacitpumax(10) + do i=ilasttpu10+1,nACiPoints(10) + ACiiphotolimit(i,10)=3 + enddo + do i=ilastrubis10+1,ilasttpu10 + ACiiphotolimit(i,10)=2 + enddo + if(numACicurves.eq.10)then + call ALightCombinatorial() + goto 10 + endif + + do ilastrubis11=iacirubismin(11),iacirubismax(11) + do i=1,ilastrubis11 + ACiiphotolimit(i,11)=1 + enddo + k11=max0(iacitpumin(11),ilastrubis11) + do 11 ilasttpu11=k11,iacitpumax(11) + do i=ilasttpu11+1,nACiPoints(11) + ACiiphotolimit(i,11)=3 + enddo + do i=ilastrubis11+1,ilasttpu11 + ACiiphotolimit(i,11)=2 + enddo + if(numACicurves.eq.11)then + call ALightCombinatorial() + goto 11 + endif + + do ilastrubis12=iacirubismin(12),iacirubismax(12) + do i=1,ilastrubis12 + ACiiphotolimit(i,12)=1 + enddo + k12=max0(iacitpumin(12),ilastrubis12) + do 12 ilasttpu12=k12,iacitpumax(12) + do i=ilasttpu12+1,nACiPoints(12) + ACiiphotolimit(i,12)=3 + enddo + do i=ilastrubis12+1,ilasttpu12 + ACiiphotolimit(i,12)=2 + enddo + if(numACicurves.eq.12)then + call ALightCombinatorial() + goto 12 + endif + + do ilastrubis13=iacirubismin(13),iacirubismax(13) + do i=1,ilastrubis13 + ACiiphotolimit(i,13)=1 + enddo + k13=max0(iacitpumin(13),ilastrubis13) + do 13 ilasttpu13=k13,iacitpumax(13) + do i=ilasttpu13+1,nACiPoints(13) + ACiiphotolimit(i,13)=3 + enddo + do i=ilastrubis13+1,ilasttpu13 + ACiiphotolimit(i,13)=2 + enddo + if(numACicurves.eq.13)then + call ALightCombinatorial() + goto 13 + endif + + do ilastrubis14=iacirubismin(14),iacirubismax(14) + do i=1,ilastrubis14 + ACiiphotolimit(i,14)=1 + enddo + k14=max0(iacitpumin(14),ilastrubis14) + do 14 ilasttpu14=k14,iacitpumax(14) + do i=ilasttpu14+1,nACiPoints(14) + ACiiphotolimit(i,14)=3 + enddo + do i=ilastrubis14+1,ilasttpu14 + ACiiphotolimit(i,14)=2 + enddo + if(numACicurves.eq.14)then + call ALightCombinatorial() + goto 14 + endif + + do ilastrubis15=iacirubismin(15),iacirubismax(15) + do i=1,ilastrubis15 + ACiiphotolimit(i,15)=1 + enddo + k15=max0(iacitpumin(15),ilastrubis15) + do 15 ilasttpu15=k15,iacitpumax(15) + do i=ilasttpu15+1,nACiPoints(15) + ACiiphotolimit(i,15)=3 + enddo + do i=ilastrubis15+1,ilasttpu15 + ACiiphotolimit(i,15)=2 + enddo + if(numACicurves.eq.15)then + call ALightCombinatorial() + goto 15 + endif +15 continue + enddo +14 continue + enddo +13 continue + enddo +12 continue + enddo +11 continue + enddo +10 continue + enddo +9 continue + enddo +8 continue + enddo +7 continue + enddo +6 continue + enddo +5 continue + enddo +4 continue + enddo +3 continue + enddo +2 continue + enddo +1 continue + enddo + bestsumsquare=1.0d+100 + do Priorilimittype=1,7 + if(subbestsumsquare(Priorilimittype).le.bestsumsquare)then + bestilimittype=Priorilimittype + bestsumsquare=subbestsumsquare(Priorilimittype) + do i=1,ntotunivparams + bestunivparams(i)=subbestunivparams(i,Priorilimittype) + enddo + do i=1,ntotsamples + bestiphotolimit(i)=subbestiphotolimit(i,Priorilimittype) + enddo + endif + enddo +1000 do i=1,ntotunivparams + univparams(i)=bestunivparams(i) + enddo + call UnivParamsAlloc(2) + call ilimittypestats(ntotsamples,bestiphotolimit, + &bestilimittype,bestnumrubis,bestnumrubp,bestnumtpu) + if(bestnumrubis.eq.0)then + vcmax25=-9999 + if(idokc.eq.1)fkc25=-9999.0d0 + if(idoko.eq.1)fko25=-9999.0d0 + endif + if(bestnumrubp.eq.0)fjmax25=-9999 + if(bestnumtpu.eq.0)then + tpu25=-9999 + if(idoalpha.eq.1)alpha25=-9999 + endif + do i=1,ntotsamples + ilastrubp1=bestiphotolimit(i)+4 + call leafunivphotosyn(Prioriknowlimit,ilastrubp1,ifitmode, + &aPPFDlf(i),templeaf(i),pco2i(i),po2i(i),chlflphips2(i), + &anet_obs(i),weitresponses(i:i,1:1),weitresponses(i:i,1:1), + &weitresponses(i:i,2:2),weitresponses(i:i,1:1), + &pco2i_pred(i),anet_pred(i),Postiphotolimit(i),pco2c(i), + &PhiPSII_pred(i),anet_pred_flu(i),pco2i_pred_flu(i), + &pco2c_anet_flu(i),pco2c_pco2i_flu(i),term) + if(chlflphips2(i).lt.0.0d0)then + anet_pred_flu(i)=-9999.0d0 + pco2i_pred_flu(i)=-9999.0d0 + pco2c_anet_flu(i)=-9999.0d0 + pco2c_pco2i_flu(i)=-9999.0d0 + else + if(iabs(ifitmode).eq.1)then + pco2i_pred_flu(i)=-9999.0d0 + pco2c_pco2i_flu(i)=-9999.0d0 + endif + if(iabs(ifitmode).eq.2)then + anet_pred_flu(i)=-9999.0d0 + pco2c_anet_flu(i)=-9999.0d0 + endif + endif + enddo + return + end subroutine HybridCombinatorial diff --git a/leafres/testarea/LeafGasFit_Stom.f b/leafres/testarea/LeafGasFit_Stom.f new file mode 100644 index 0000000..fe3d03e --- /dev/null +++ b/leafres/testarea/LeafGasFit_Stom.f @@ -0,0 +1,627 @@ + subroutine LeafGasFit_Stom(unitparamsout,unitwuecicacomp, + &unitstomcomp,curveno,curvename,npoints0,aPPFDlf0,templeaf0, + &tempair0,co2i_pa,co2a_pa,pres_air0,yAnet0,gswmeas0,vpdl0,trmmol0, + &abspt_lf_par,co2c_pa,co2recycleratio,stargamma25,ha_stargamma, +! + & siteID,Latitude,Longitude,Elevation,yearsampled, + & sampledoy,GrowingSeasonStart,GrowingSeasonEnd, + & standage,CanopyHeight,LeafAreaIndex,species, + & avetimeresolution,avetimesampled,SampleHeight, + & Needleage,specificLAI,nitrogencontent,carboncontent, + & phoscontent,woodporosity,sapwooddensity,leafratio) + implicit none +! +!----------Inputs------------------------------------------- + integer npoints0,unitparamsout,unitwuecicacomp,unitstomcomp, + &curveno + double precision aPPFDlf0(npoints0),templeaf0(npoints0), + &tempair0(npoints0),co2i_pa(npoints0),co2a_pa(npoints0), + &pres_air0(npoints0),yAnet0(npoints0),gswmeas0(npoints0), + &vpdl0(npoints0),trmmol0(npoints0),abspt_lf_par, + &co2c_pa(4,npoints0),co2recycleratio0(6,npoints0), + &stargamma25(6),ha_stargamma + + character*100 curvename + character siteID*(*),species*(*),woodporosity*(*) + double precision Latitude,Longitude,Elevation,yearsampled, + &sampledoy,GrowingSeasonStart,GrowingSeasonEnd,standage, + &CanopyHeight,LeafAreaIndex,avetimeresolution,avetimesampled, + &SampleHeight,Needleage,specificLAI,nitrogencontent, + &carboncontent,phoscontent,sapwooddensity,leafratio +!----------Internal variables------------------------------- + integer npoints_stom,i,j,k,numparams,INFO,istommodel,malfit, + &imodel,iwrong,idostom,idocica,idowue,npoints + double precision co2threshold,co2current,vpdl_ref,gascon, + &templeaf_stom(npoints0),gswmeas_stom(npoints0), + &pres_air_stom(npoints0),xpco2i_stom(npoints0), + &yAnet_stom(npoints0),trmmol_stom(npoints0),stargamma(npoints0), + &pco2s(npoints0),rehulfsurf(npoints0),pvapordef_s(npoints0), + &combined1(npoints0),combined2(npoints0),wue(npoints0), + &wuemod(npoints0),wue_intrin(npoints0),wue_intrinmod(npoints0), + &cicameas(npoints0),cicamod(npoints0),gswmodcp(npoints0), + &gswmod1(npoints0),gswmod2(npoints0),gswmod(4,npoints0), + &sig(npoints0),ballintersurf,ballslopesurf,ballrsqsurf, + &ballinterinside,ballslopeinside, + &ballrsqinside,ballinter,ballslope,ballrsqgsw,esat,raysurfinter, + &raysurfslope,raysurfd0,raysurfrsqgsw,belindainter,belindaslope, + &belindad0,belindarsqgsw,dewarinter,dewarslope,deward0,dewarrsqgsw, + &wueref,der_wueref,rsqwue,alfit(10),der_alfit(10),wueref_intrin, + &der_wueref_intrin,rsqwue_intrin,blfit(10),der_blfit(10),cicaref, + &der_cicaref,rsqcica,avetleaf,avetair,avevpdl,avepari,term, + &ballrmsgsw,ballagrindgsw,raysurfrmsgsw,raysurfagrindgsw, + &belindarmsgsw,belindaagrindgsw,dewarrmsgsw,dewaragrindgsw,rmswue, + &agrindwue,rmswue_intrin,agrindwue_intrin,stomintercept,stomslope, + &rayDzero,rsqgsw,rmsgsw,agrindgsw,rmscica,agrindcica,cicafit(10), + &der_cicafit(10),bmin(10),bmax(10),rsqccci(4),rmsccci(4), + &agrindccci(4),cccifit(4,10),der_cccifit(4,10),ccciref(4), + &der_ccciref(4),co2iref,cccimeas(4,npoints0),cccimod(4,npoints0), + &avepres_air,rsqrecyc(6),rmsrecyc(6),agrindrecyc(6),recycfit(6,10), + &der_recycfit(6,10),recycref(6),der_recycref(6), + &recycmod(6,npoints0),aPPFDlf(npoints0),templeaf(npoints0), + &tempair(npoints0),co2i_ppm(npoints0),co2a_ppm(npoints0), + &pres_air(npoints0),yAnet(npoints0),gswmeas(npoints0), + &vpdl(npoints0),trmmol(npoints0),co2c_ppm(4,npoints0), + &co2recycleratio(6,npoints0) + + parameter(gascon=8.314472d0,co2threshold=0.0d0,co2current=400.0d0, + &vpdl_ref=1600.0d0) +!if ambient co2 is too low, the ball-berry stomatal conductance model does not apply so we need to +!set up a threshold here +!this ambient CO2 threshold (250ppm) is taken from Gutschick and Simmonneau (2002) +!WUE are standardized for VPD at 50% relative humidity at 25 oC. + + external lfitbasisfuncs +!------------------------------------------------------------------------------------------- + idostom=1 + idowue=1 + idocica=1 + npoints=0 + do j=1,npoints0 + if(gswmeas0(j).gt.0.0d0.and.co2i_pa(j).gt.0.0d0.and. + &trmmol0(j).gt.0.0d0)then + npoints=npoints+1 + aPPFDlf(npoints)=aPPFDlf0(j) + templeaf(npoints)=templeaf0(j) + tempair(npoints)=tempair0(j) + yAnet(npoints)=yAnet0(j) + co2i_ppm(npoints)=co2i_pa(j)*1.0d+6/pres_air0(j) + if(co2a_pa(j).gt.0.0d0)then + co2a_ppm(npoints)=co2a_pa(j)*1.0d+6/pres_air0(j) + else + co2a_ppm(npoints)=-9999.0d0 + idocica=0 + endif + pres_air(npoints)=pres_air0(j) + gswmeas(npoints)=gswmeas0(j) + trmmol(npoints)=trmmol0(j) + vpdl(npoints)=vpdl0(j) + do k=1,4 + if(dabs(co2c_pa(k,j)+9999.0d0).gt.1.0d-5)then + co2c_ppm(k,npoints)=co2c_pa(k,j)*1.0d+6/pres_air0(j) + else + co2c_ppm(k,npoints)=-9999.0d0 + endif + enddo + do k=1,6 + co2recycleratio(k,npoints)=co2recycleratio0(k,j) + enddo + endif + enddo + if(npoints.le.3)return + avevpdl=0.0d0 + avetleaf=0.0d0 + avetair=0.0d0 + avepari=0.0d0 + avepres_air=0.0d0 + do j=1,npoints + avevpdl=avevpdl+vpdl(j) + avetleaf=avetleaf+templeaf(j) + avetair=avetair+tempair(j) + avepari=avepari+aPPFDlf(j)/abspt_lf_par + avepres_air=avepres_air+pres_air(j) + enddo + avevpdl=avevpdl/dble(npoints) + avetleaf=avetleaf/dble(npoints)-273.15d0 + avetair=avetair/dble(npoints)-273.15d0 + avepari=avepari/dble(npoints) + avepres_air=avepres_air/dble(npoints) + if(avepres_air.lt.0.0d0)avepres_air=98000.0d0 +!$$$$$$$$$$$$ Fitting stomatal conductance models $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +!Now fit the stomatal conductance models + npoints_stom=-9999 + if(idostom.eq.1)then + npoints_stom=0 + do j=1,npoints + if(co2a_ppm(j).gt.co2threshold.and.yAnet(j).gt.0.0d0)then + npoints_stom=npoints_stom+1 + templeaf_stom(npoints_stom)=templeaf(j) + pres_air_stom(npoints_stom)=pres_air(j) + xpco2i_stom(npoints_stom)=co2i_ppm(j) + yAnet_stom(npoints_stom)=yAnet(j) + trmmol_stom(npoints_stom)=trmmol(j) + gswmeas_stom(npoints_stom)=gswmeas(j) + endif + enddo + if(npoints_stom.le.3)then + idostom=0 + endif + endif + if(idostom.eq.1)then + do j=1,npoints_stom + call co2compens(templeaf_stom(j),stargamma25(5),ha_stargamma, + & gascon,stargamma(j)) +!stargamma is in Pa, so convert it to ppm + term=esat(templeaf_stom(j),pres_air_stom(j)) + stargamma(j)=1.0d+6*stargamma(j)/pres_air_stom(j) + pco2s(j)=xpco2i_stom(j)+1.6d0*yAnet_stom(j)/gswmeas_stom(j) +!mole fraction + pvapordef_s(j)=term/pres_air_stom(j)- + & 0.001d0*trmmol_stom(j)/gswmeas_stom(j) +!partial pressure + pvapordef_s(j)=pres_air_stom(j)*pvapordef_s(j) +!partial pressure deficit + pvapordef_s(j)=term-pvapordef_s(j) + pvapordef_s(j)=dmax1(0.0d0,pvapordef_s(j)) + pvapordef_s(j)=dmin1(term,pvapordef_s(j)) + rehulfsurf(j)=1.0d0-pvapordef_s(j)/term + combined1(j)=yAnet_stom(j)*rehulfsurf(j)/pco2s(j) + combined2(j)=yAnet_stom(j)*rehulfsurf(j)/xpco2i_stom(j) + enddo + malfit=2 + do j=1,npoints_stom + sig(j)=1.0d0 + enddo + call lfit(combined1,gswmeas_stom,sig,npoints_stom,alfit, + & malfit,malfit,lfitbasisfuncs,INFO) + do j=1,npoints_stom + gswmod1(j)=alfit(1)+alfit(2)*combined1(j) + enddo + call rsq_rms(gswmeas_stom,gswmod1,npoints_stom,rsqgsw, + & rmsgsw,agrindgsw) + ballintersurf=alfit(1) + ballslopesurf=alfit(2) + ballrsqsurf=rsqgsw + malfit=2 + do j=1,npoints_stom + sig(j)=1.0d0 + enddo + call lfit(combined2,gswmeas_stom,sig,npoints_stom,alfit, + & malfit,malfit,lfitbasisfuncs,INFO) + do j=1,npoints_stom + gswmod2(j)=alfit(1)+alfit(2)*combined2(j) + enddo + call rsq_rms(gswmeas_stom,gswmod2,npoints_stom,rsqgsw, + & rmsgsw,agrindgsw) + ballinterinside=alfit(1) + ballslopeinside=alfit(2) + ballrsqinside=rsqgsw + do istommodel=1,4 + stomintercept=0.0001d0 + stomslope=10.0d0 + rayDzero=2000.0d0 + if(istommodel.le.3)then + call StomRegression(npoints_stom,istommodel,pco2s, + & rehulfsurf,stargamma,yAnet_stom,gswmeas_stom, + & stomintercept,stomslope,pvapordef_s,rayDzero) + call stomoptimization(npoints_stom,istommodel,pco2s, + & rehulfsurf,stargamma,yAnet_stom,gswmeas_stom, + & stomintercept,stomslope,pvapordef_s,rayDzero) + do j=1,npoints_stom + call StomatalConductance(pco2s(j),rehulfsurf(j), + &stargamma(j),pvapordef_s(j),rayDzero,yAnet_stom(j),istommodel, + &stomintercept,stomslope,term) + gswmod(istommodel,j)=term + gswmodcp(j)=term + enddo + endif + if(istommodel.eq.4)then +!We experiment using internal CO2 to fit the dewar model + call StomRegression(npoints_stom,istommodel,xpco2i_stom, + & rehulfsurf,stargamma,yAnet_stom,gswmeas_stom, + & stomintercept,stomslope,pvapordef_s,rayDzero) + call stomoptimization(npoints_stom,istommodel,xpco2i_stom, + & rehulfsurf,stargamma,yAnet_stom,gswmeas_stom, + & stomintercept,stomslope,pvapordef_s,rayDzero) + do j=1,npoints_stom + call StomatalConductance(xpco2i_stom(j), + & rehulfsurf(j),stargamma(j),pvapordef_s(j),rayDzero, + & yAnet_stom(j),istommodel, + & stomintercept,stomslope,term) + gswmod(istommodel,j)=term + gswmodcp(j)=term + enddo + endif + call rsq_rms(gswmeas_stom,gswmodcp, + & npoints_stom,rsqgsw,rmsgsw,agrindgsw) + if(istommodel.eq.1)then + ballinter=stomintercept + ballslope=stomslope + ballrsqgsw=rsqgsw + ballrmsgsw=rmsgsw + ballagrindgsw=agrindgsw + endif + if(istommodel.eq.2)then + raysurfinter=stomintercept + raysurfslope=stomslope + raysurfd0=rayDzero + raysurfrsqgsw=rsqgsw + raysurfrmsgsw=rmsgsw + raysurfagrindgsw=agrindgsw + endif + if(istommodel.eq.3)then + belindainter=stomintercept + belindaslope=stomslope + belindad0=-9999.0d0 + belindarsqgsw=rsqgsw + belindarmsgsw=rmsgsw + belindaagrindgsw=agrindgsw + endif + if(istommodel.eq.4)then + dewarinter=stomintercept + dewarslope=stomslope + deward0=rayDzero + dewarrsqgsw=rsqgsw + dewarrmsgsw=rmsgsw + dewaragrindgsw=agrindgsw + endif + enddo + do j=1,npoints_stom + write(unitstomcomp,370)curveno,trim(curvename), + & gswmeas_stom(j),gswmod1(j),gswmod2(j),gswmod(1,j), + & gswmod(2,j),gswmod(3,j),gswmod(4,j),xpco2i_stom(j), + & pco2s(j),rehulfsurf(j),stargamma(j),pvapordef_s(j), + & pres_air_stom(j),yAnet_stom(j) + enddo + else + ballintersurf=-9999.0d0 + ballslopesurf=-9999.0d0 + ballrsqsurf=-9999.0d0 + ballinterinside=-9999.0d0 + ballslopeinside=-9999.0d0 + ballrsqinside=-9999.0d0 + ballinter=-9999.0d0 + ballslope=-9999.0d0 + ballrsqgsw=-9999.0d0 + ballrmsgsw=-9999.0d0 + ballagrindgsw=-9999.0d0 + raysurfinter=-9999.0d0 + raysurfslope=-9999.0d0 + raysurfd0=-9999.0d0 + raysurfrsqgsw=-9999.0d0 + raysurfrmsgsw=-9999.0d0 + raysurfagrindgsw=-9999.0d0 + belindainter=-9999.0d0 + belindaslope=-9999.0d0 + belindad0=-9999.0d0 + belindarsqgsw=-9999.0d0 + belindarmsgsw=-9999.0d0 + belindaagrindgsw=-9999.0d0 + dewarinter=-9999.0d0 + dewarslope=-9999.0d0 + deward0=-9999.0d0 + dewarrsqgsw=-9999.0d0 + dewarrmsgsw=-9999.0d0 + dewaragrindgsw=-9999.0d0 + endif +!$$$$$$$$$$$$ End of Stomatal Conductance Fit $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +!Now analyze the relationship of water use efficiency with ambient CO2 + if(idowue.eq.1)then + do j=1,npoints + wue(j)=yAnet(j)/trmmol(j) + sig(j)=1.0d0 + enddo +! malfit=3 +! do j=1,npoints +! sig(j)=1.0d0 +! enddo +! call lfit(co2a_ppm,wue,sig,npoints,alfit,malfit,malfit, +! & lfitbasisfuncs,INFO) +! do j=1,npoints +! wuemod(j)=alfit(1)+alfit(2)*co2a_ppm(j)+alfit(3)* +! & co2a_ppm(j)*co2a_ppm(j)/1000.0d0 +! enddo +! call rsq_rms(wue,wuemod,npoints,rsqwue,rmswue,agrindwue) +! wueref=alfit(1)+alfit(2)*co2current+alfit(3)* +! & co2current*co2current/1000.0d0 +! der_wueref=alfit(2)+2.0d0*alfit(3)*co2current/1000.0d0 + + alfit(1)=1.0d0 + alfit(2)=0.1d0 + alfit(3)=-20.0d0 + alfit(4)=0.1d0 + alfit(5)=100.0d0 + bmin(1)=-1.0d+3 + bmax(1)=1.0d+4 + bmin(2)=-1.0d+4 + bmax(2)=1.0d+5 + bmin(3)=-1.0d+5 + bmax(3)=1.0d+5 + bmin(4)=-1.0d+5 + bmax(4)=1.0d+5 + bmin(5)=-1.0d+5 + bmax(5)=1.0d+5 + imodel=1 + numparams=5 + call cica_Regression5(npoints,wue,co2a_ppm,alfit,numparams, + &imodel,bmin,bmax) + call cicaoptimization5(npoints,wue,co2a_ppm,alfit,numparams, + &imodel,bmin,bmax) + do j=1,npoints + call cica_ca5(imodel,numparams,alfit,co2a_ppm(j),wuemod(j), + &der_wueref,der_alfit) + enddo + call cica_ca5(imodel,numparams,alfit,co2current,wueref, + &der_wueref,der_alfit) + call rsq_rms(wue,wuemod,npoints,rsqwue,rmswue,agrindwue) +!------------------------------------------------------------------------------ + do j=1,npoints + wue_intrin(j)=yAnet(j)/gswmeas(j) + enddo +! call lfit(co2a_ppm,wue_intrin,sig,npoints,blfit,malfit, +! & malfit,lfitbasisfuncs,INFO) +! do j=1,npoints +! wue_intrinmod(j)=blfit(1)+blfit(2)*co2a_ppm(j)+ +! & blfit(3)*co2a_ppm(j)*co2a_ppm(j)/1000.0d0 +! enddo +! call rsq_rms(wue_intrin,wue_intrinmod,npoints,rsqwue_intrin, +! & rmswue,agrindwue) +! wueref_intrin=blfit(1)+blfit(2)*co2current+blfit(3)* +! & co2current*co2current/1000.0d0 +! der_wueref_intrin=blfit(2)+2.0d0*blfit(3)*co2current/1000.0d0 + + blfit(1)=1.0d0 + blfit(2)=0.10 + blfit(3)=-20.0d0 + blfit(4)=0.1d0 + blfit(5)=100.0d0 + + bmin(1)=-1.0d+5 + bmax(1)=1.0d+5 + bmin(2)=-1.0d+5 + bmax(2)=1.0d+5 + bmin(3)=-1.0d+5 + bmax(3)=1.0d+5 + bmin(4)=-1.0d+5 + bmax(4)=1.0d+5 + bmin(5)=-1.0d+5 + bmax(5)=1.0d+5 + numparams=5 + imodel=1 + call cica_Regression5(npoints,wue_intrin,co2a_ppm, + &blfit,numparams,imodel,bmin,bmax) + call cicaoptimization5(npoints,wue_intrin,co2a_ppm, + &blfit,numparams,imodel,bmin,bmax) + do j=1,npoints + call cica_ca5(imodel,numparams,blfit,co2a_ppm(j), + &wue_intrinmod(j),der_wueref_intrin,der_blfit) + enddo + call cica_ca5(imodel,numparams,blfit,co2current, + &wueref_intrin,der_wueref_intrin,der_blfit) + call rsq_rms(wue_intrin,wue_intrinmod,npoints,rsqwue_intrin, + &rmswue,agrindwue) + else + rsqwue=-9999.0d0 + rmswue=-9999.0d0 + agrindwue=-9999.d0 + wueref=-9999.0d0 + der_wueref=-9999.0d0 + avevpdl=-9999.0d0 + avetleaf=-9999.0d0 + avetair=-9999.0d0 + do j=1,npoints + wue(j)=-9999.0d0 + wuemod(j)=-9999.0d0 + wue_intrin(j)=-9999.0d0 + wue_intrinmod(j)=-9999.0d0 + enddo + rsqwue_intrin=-9999.0d0 + wueref_intrin=-9999.0d0 + der_wueref_intrin=-9999.0d0 + do j=1,numparams + alfit(j)=-9999.0d0 + blfit(j)=-9999.0d0 + enddo + endif + +!---------------------------------------------------------------------------- +!Now analyze the relationship of Ci/Ca ratio with ambient CO2 and Cc/Ci with Ci +100 term=co2a_ppm(1) + do j=2,npoints + if(co2a_ppm(j).gt.term)then + term=co2a_ppm(j) + endif + enddo + bmin(1)=-1.0d+2 + bmax(1)=1.0d+2 + bmin(2)=-300.0d0/term + bmax(2)=1.0d+6 + + if(idocica.eq.1)then + do j=1,npoints + cicameas(j)=co2i_ppm(j)/co2a_ppm(j) + enddo + +!Ci/Ca=a*exp(-b*Ca)+c+d*ln(co2a)+e*(ln(co2))**2 + + cicafit(1)=1.5874d0 + cicafit(2)=2.0343d0 + cicafit(3)=0.8779d0 + cicafit(4)=0.1d0 + cicafit(5)=0.01d0 + + bmin(3)=-1.0d+2 + bmax(3)=1.0d+2 + bmin(4)=-1.0d+2 + bmax(4)=1.0d+2 + bmin(5)=-1.0d+2 + bmax(5)=1.0d+2 + + numparams=5 + imodel=3 + call cica_Regression5(npoints,cicameas,co2a_ppm, + &cicafit,numparams,imodel,bmin,bmax) + call cicaoptimization5(npoints,cicameas,co2a_ppm, + &cicafit,numparams,imodel,bmin,bmax) + do j=1,npoints + call cica_ca5(imodel,numparams,cicafit,co2a_ppm(j), + &cicamod(j),der_cicaref,der_cicafit) + enddo + call cica_ca5(imodel,numparams,cicafit,co2current, + &cicaref,der_cicaref,der_cicafit) + call rsq_rms(cicameas,cicamod,npoints,rsqcica,rmscica, + & agrindcica) + else + do j=1,npoints + cicamod(j)=-9999.0d0 + enddo + rsqcica=-9999.0d0 + rmscica=-9999.0d0 + agrindcica=-9999.0d0 + cicaref=-9999.0d0 + der_cicaref=-9999.0d0 + do j=1,numparams + cicafit(j)=-9999.0d0 + der_cicafit(j)=-9999.0d0 + enddo + endif +!-------------------------------------------------------------------------- +!below we fit Cc/Ci +110 do i=1,4 + do j=1,npoints + cccimeas(i,j)=co2c_ppm(i,j)/co2i_ppm(j) + enddo + if(co2c_ppm(i,1).ge.0.0d0)then + cccifit(i,1)=2.5874d0 + cccifit(i,2)=2.0343d0 + cccifit(i,3)=0.8779d0 + cccifit(i,4)=0.1d0 + cccifit(i,5)=0.01d0 + cccifit(i,6)=0.001d0 + + bmin(3)=-1.0d+2 + bmax(3)=1.0d+2 + bmin(4)=-1.0d+2 + bmax(4)=1.0d+2 + bmin(5)=-1.0d+2 + bmax(5)=1.0d+2 + bmin(6)=-1.0d+2 + bmax(6)=1.0d+2 + + numparams=6 + imodel=3 + call cica_Regression5(npoints,cccimeas(i:i,1:npoints), + &co2i_ppm,cccifit(i:i,1:numparams),numparams,imodel,bmin,bmax) + call cicaoptimization5(npoints,cccimeas(i:i,1:npoints), + &co2i_ppm,cccifit(i:i,1:numparams),numparams,imodel,bmin,bmax) + do j=1,npoints + call cica_ca5(imodel,numparams,cccifit(i:i,1:numparams), + &co2i_ppm(j),cccimod(i,j),der_ccciref(i),der_cccifit) + enddo + if(dabs(cicaref+9999.0d0).gt.1.0d-5)then + co2iref=cicaref*co2current + else + co2iref=0.75d0*co2current + endif + call cica_ca5(imodel,numparams,cccifit(i:i,1:numparams), + &co2iref,ccciref(i),der_ccciref(i),der_cccifit) + call rsq_rms(cccimeas(i:i,1:npoints),cccimod(i:i,1:npoints), + &npoints,rsqccci(i),rmsccci(i),agrindccci(i)) + else + do j=1,npoints + cccimod(i,j)=-9999.0d0 + enddo + rsqccci(i)=-9999.0d0 + rmsccci(i)=-9999.0d0 + agrindccci(i)=-9999.0d0 + ccciref(i)=-9999.0d0 + der_ccciref(i)=-9999.0d0 + do j=1,numparams + cccifit(i,j)=-9999.0d0 + enddo + endif + enddo +!----------------------------------------------------------------------- +!now we fit CO2 recycling ratio + do i=1,6 + if(co2recycleratio(i,1).ge.0.0d0)then + recycfit(i,1)=2.5874d0 + recycfit(i,2)=2.0343d0 + recycfit(i,3)=0.8779d0 + recycfit(i,4)=0.1d0 + recycfit(i,5)=0.01d0 + recycfit(i,6)=0.001d0 + bmin(3)=-1.0d+2 + bmax(3)=1.0d+2 + bmin(4)=-1.0d+2 + bmax(4)=1.0d+2 + bmin(5)=-1.0d+2 + bmax(5)=1.0d+2 + bmin(6)=-1.0d+2 + bmax(6)=1.0d+2 + numparams=5 + imodel=3 + call cica_Regression5(npoints,co2recycleratio(i:i,1:npoints), + &co2i_ppm,recycfit(i:i,1:numparams),numparams,imodel,bmin,bmax) + call cicaoptimization5(npoints,co2recycleratio(i:i,1:npoints), + &co2i_ppm,recycfit(i:i,1:numparams),numparams,imodel,bmin,bmax) + do j=1,npoints + call cica_ca5(imodel,numparams,recycfit(i:i,1:numparams), + &co2i_ppm(j),recycmod(i,j),der_recycref(i),der_recycfit) + enddo + if(dabs(cicaref+9999.0d0).gt.1.0d-5)then + co2iref=cicaref*co2current + else + co2iref=0.75d0*co2current + endif + call cica_ca5(imodel,numparams,recycfit(i:i,1:numparams), + &co2iref,recycref(i),der_recycref(i),der_recycfit) + call rsq_rms(co2recycleratio(i:i,1:npoints), + &recycmod(i:i,1:npoints),npoints,rsqrecyc(i),rmsrecyc(i), + &agrindrecyc(i)) + else + do j=1,npoints + recycmod(i,j)=-9999.0d0 + enddo + rsqrecyc(i)=-9999.0d0 + rmsrecyc(i)=-9999.0d0 + agrindrecyc(i)=-9999.0d0 + recycref(i)=-9999.0d0 + der_recycref(i)=-9999.0d0 + do j=1,numparams + recycfit(i,j)=-9999.0d0 + enddo + endif + enddo +!----------------------------------------------------------------------- + do j=1,npoints + write(unitwuecicacomp,380)curveno,trim(curvename),co2a_ppm(j), + &vpdl(j),wue(j),wuemod(j),cicameas(j),cicamod(j),wue_intrin(j), + &wue_intrinmod(j),((cccimeas(k,j),cccimod(k,j)),k=1,4), + &((co2recycleratio(k,j),recycmod(k,j)),k=1,6) + enddo + write(unitparamsout,390)curveno,trim(curvename),npoints_stom, + &co2threshold,co2current,vpdl_ref,ballintersurf,ballslopesurf, + &ballrsqsurf,ballinterinside,ballslopeinside,ballrsqinside, + &ballinter,ballslope,ballrsqgsw,raysurfinter,raysurfslope, + &raysurfd0,raysurfrsqgsw,belindainter,belindaslope, + &belindad0,belindarsqgsw,dewarinter,dewarslope,deward0, + &dewarrsqgsw,wueref,der_wueref,rsqwue,(alfit(i),i=1,5), + &wueref_intrin,der_wueref_intrin,rsqwue_intrin,(blfit(i),i=1,5), + &cicaref,der_cicaref,rsqcica,(cicafit(i),i=1,5), + &avetleaf,avetair,avevpdl,avepari,((ccciref(i),der_ccciref(i), + &rsqccci(i),(cccifit(i,j),j=1,6)),i=1,4), + &((recycref(i),der_recycref(i), + &rsqrecyc(i),(recycfit(i,j),j=1,5)),i=1,6), +! + &trim(siteID),Latitude,Longitude,Elevation,yearsampled, + &sampledoy,GrowingSeasonStart,GrowingSeasonEnd, + &standage,CanopyHeight,LeafAreaIndex,trim(species), + &avetimeresolution,avetimesampled,SampleHeight, + &Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,trim(woodporosity),sapwooddensity,leafratio +370 format(i0,',',a,',',13(f0.8,','),f0.8) +380 format(i0,',',a,',',27(f0.8,','),f0.8) +390 format(i0,',',a,',',i0,',',136(f0.8,','),a,',',10(f0.8,','), + &a,',',8(f0.8,','),a,',',f0.8,',',f0.8) + return + end subroutine LeafGasFit_Stom diff --git a/leafres/testarea/LeafGasHybridFit.h b/leafres/testarea/LeafGasHybridFit.h new file mode 100644 index 0000000..33a2d71 --- /dev/null +++ b/leafres/testarea/LeafGasHybridFit.h @@ -0,0 +1,239 @@ +! This file contains common blocks used in the optimization runs. +! +! ------ Optimization variables common Blocks --------------------- +! maxobs: the maximum number of observations +! maxpsnparam: the maximum number of parameters to be optimized +! aPPFDlf: PAR absorbed by leaf (umol m-2 s-1) +! templeaf: leaf temperature (K) +! xpco2i: Intercellular CO2 partial pressure (Pa) +! po2i: Intercellular oxygen partial pressure (Pa) +! obs_psn: net photosynthetic rate (umol m-2 s-1) +! psnparamx: parameters in the leaf photosynthetic model +! nobs: integer, the actual number of observations +! IFIXBcp: the index for the parameters in psnparams that are being +! optimized (0= not optimized; 1= optimized) +! ilimittype: indicator for the choice of limitation types +! = 1, Rubisco+RuBP+TPU' +! = 2, Rubisco+RuBP +! = 3, Rubisco+TPU +! = 4, RuBP+TPU +! = 5, Rubisco Only +! = 6, RuBP Only +! = 7, TPU Only +! betamin: the lower bound of the parameters to be optimized +! betamax: the upper bound of the parameters to be optimized +!resistwp: =rwp, resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: =rch, resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!idorwp, =0 zero rwp +! =1 fit for rwp +! =2 keep input rwp and don't optimize it +!idorch, =0 zero rch +! =1 fit for rch +! =2 keep input rch and don't optimize it +! ntotparams: the total number of optimized and unoptimized parameters +! isitgridsearch=0, in optimization mode (cij+cic is the transition RuBp-TPU CO2i threshold) +! =1, in grid search mode (cij is the transition RuBp-TPU CO2i threshold) + integer maxobs,maxcurves + parameter (maxobs=200,maxcurves=15) + + double precision anet_obs(maxobs),pco2i(maxobs),templeaf(maxobs), + &aPPFDlf(maxobs),pres_air(maxobs),po2i(maxobs),chlflphips2(maxobs), + &pco2ambient(maxobs),trmmol(maxobs),gswmeas(maxobs),vpdl(maxobs), + &tempair(maxobs),eambient(maxobs),resiststomco2(maxobs),sumsquare, + &pco2i_ori(maxobs),templeaf_ori(maxobs),aPPFDlf_ori(maxobs), + &pres_air_ori(maxobs),po2i_ori(maxobs),chlflphips2_ori(maxobs), + &pco2ambient_ori(maxobs),trmmol_ori(maxobs),gswmeas_ori(maxobs), + &vpdl_ori(maxobs),tempair_ori(maxobs),eambient_ori(maxobs), + &fo_pam(maxobs),fm_pam(maxobs),fs_pam(maxobs), + &pam_measlight(maxobs),yield_ps2(maxobs),yield_npq(maxobs), + &qlake(maxobs),qpuddle(maxobs),kps2_norm(maxobs),knpq_norm(maxobs), + &resiststomco2_ori(maxobs),pco2i_pred(maxobs),anet_pred(maxobs), + &PhiPSII_pred(maxobs),pco2c(maxobs),bestsumsquare, + &subbestsumsquare(7),forcings(maxobs,10),weitforcings(maxobs,10), + &responses(maxobs,5),weitresponses(maxobs,5), + &pco2i_pred_flu(maxobs),anet_pred_flu(maxobs), + &pco2c_pco2i_flu(maxobs),pco2c_anet_flu(maxobs), + &PhiPSIIlights_pred(maxobs),templflights(maxobs), + &aparlights(maxobs),flphips2lights(maxobs),flujmaxfval, + + &Fixedanet_obs(maxobs/4),Fixedpco2i(maxobs/4), + &Fixedtempleaf(maxobs/4),FixedaPPFDlf(maxobs/4), + &Fixedpres_air(maxobs/4),Fixedpo2i(maxobs/4), + &Fixedchlflphips2(maxobs/4),Fixedpco2ambient(maxobs/4), + &Fixedtrmmol(maxobs/4),Fixedgswmeas(maxobs/4), + &Fixedvpdl(maxobs/4),Fixedtempair(maxobs/4), + &Fixedeambient(maxobs/4),Fixedfo_pam(maxobs/4), + &Fixedfm_pam(maxobs/4),Fixedfs_pam(maxobs/4), + &Fixedpam_measlight(maxobs/4),Fixedyield_ps2(maxobs/4), + &Fixedyield_npq(maxobs/4),Fixedqlake(maxobs/4), + &Fixedqpuddle(maxobs/4),Fixedkps2_norm(maxobs/4), + &Fixedknpq_norm(maxobs/4),Fixedresiststomco2(maxobs/4), + + &ACianet_obs0(maxobs/4,maxcurves),ACipco2i0(maxobs/4,maxcurves), + &ACitempleaf0(maxobs/4,maxcurves),ACiaPPFDlf0(maxobs/4,maxcurves), + &ACipres_air0(maxobs/4,maxcurves),ACipo2i0(maxobs/4,maxcurves), + &ACichlflphips20(maxobs/4,maxcurves), + &ACipco2ambient0(maxobs/4,maxcurves), + &ACitrmmol0(maxobs/4,maxcurves),ACigswmeas0(maxobs/4,maxcurves), + &ACivpdl0(maxobs/4,maxcurves),ACitempair0(maxobs/4,maxcurves), + &ACieambient0(maxobs/4,maxcurves),ACifo_pam0(maxobs/4,maxcurves), + &ACifm_pam0(maxobs/4,maxcurves),ACifs_pam0(maxobs/4,maxcurves), + &ACipam_measlight0(maxobs/4,maxcurves), + &ACiyield_ps20(maxobs/4,maxcurves), + &ACiyield_npq0(maxobs/4,maxcurves),ACiqlake0(maxobs/4,maxcurves), + &ACiqpuddle0(maxobs/4,maxcurves),ACikps2_norm0(maxobs/4,maxcurves), + &ACiknpq_norm0(maxobs/4,maxcurves), + &ACiresiststomco20(maxobs/4,maxcurves), + &ACianet_obs(maxobs/4,maxcurves),ACipco2i(maxobs/4,maxcurves), + &ACitempleaf(maxobs/4,maxcurves),ACiaPPFDlf(maxobs/4,maxcurves), + &ACipres_air(maxobs/4,maxcurves),ACipo2i(maxobs/4,maxcurves), + &ACichlflphips2(maxobs/4,maxcurves), + &ACipco2ambient(maxobs/4,maxcurves), + &ACitrmmol(maxobs/4,maxcurves),ACigswmeas(maxobs/4,maxcurves), + &ACivpdl(maxobs/4,maxcurves),ACitempair(maxobs/4,maxcurves), + &ACieambient(maxobs/4,maxcurves),ACifo_pam(maxobs/4,maxcurves), + &ACifm_pam(maxobs/4,maxcurves),ACifs_pam(maxobs/4,maxcurves), + &ACipam_measlight(maxobs/4,maxcurves), + &ACiyield_ps2(maxobs/4,maxcurves), + &ACiyield_npq(maxobs/4,maxcurves),ACiqlake(maxobs/4,maxcurves), + &ACiqpuddle(maxobs/4,maxcurves),ACikps2_norm(maxobs/4,maxcurves), + &ACiknpq_norm(maxobs/4,maxcurves), + &ACiresiststomco2(maxobs/4,maxcurves), + + &ALightanet_obs0(maxobs/4,maxcurves), + &ALightpco2i0(maxobs/4,maxcurves), + &ALighttempleaf0(maxobs/4,maxcurves), + &ALightaPPFDlf0(maxobs/4,maxcurves), + &ALightpres_air0(maxobs/4,maxcurves), + &ALightpo2i0(maxobs/4,maxcurves), + &ALightchlflphips20(maxobs/4,maxcurves), + &ALightpco2ambient0(maxobs/4,maxcurves), + &ALighttrmmol0(maxobs/4,maxcurves), + &ALightgswmeas0(maxobs/4,maxcurves), + &ALightvpdl0(maxobs/4,maxcurves), + &ALighttempair0(maxobs/4,maxcurves), + &ALighteambient0(maxobs/4,maxcurves), + &ALightfo_pam0(maxobs/4,maxcurves), + &ALightfm_pam0(maxobs/4,maxcurves), + &ALightfs_pam0(maxobs/4,maxcurves), + &ALightpam_measlight0(maxobs/4,maxcurves), + &ALightyield_ps20(maxobs/4,maxcurves), + &ALightyield_npq0(maxobs/4,maxcurves), + &ALightqlake0(maxobs/4,maxcurves), + &ALightqpuddle0(maxobs/4,maxcurves), + &ALightkps2_norm0(maxobs/4,maxcurves), + &ALightknpq_norm0(maxobs/4,maxcurves), + &ALightresiststomco20(maxobs/4,maxcurves), + &ALightanet_obs(maxobs/4,maxcurves), + &ALightpco2i(maxobs/4,maxcurves), + &ALighttempleaf(maxobs/4,maxcurves), + &ALightaPPFDlf(maxobs/4,maxcurves), + &ALightpres_air(maxobs/4,maxcurves), + &ALightpo2i(maxobs/4,maxcurves), + &ALightchlflphips2(maxobs/4,maxcurves), + &ALightpco2ambient(maxobs/4,maxcurves), + &ALighttrmmol(maxobs/4,maxcurves), + &ALightgswmeas(maxobs/4,maxcurves), + &ALightvpdl(maxobs/4,maxcurves), + &ALighttempair(maxobs/4,maxcurves), + &ALighteambient(maxobs/4,maxcurves), + &ALightfo_pam(maxobs/4,maxcurves), + &ALightfm_pam(maxobs/4,maxcurves), + &ALightfs_pam(maxobs/4,maxcurves), + &ALightpam_measlight(maxobs/4,maxcurves), + &ALightyield_ps2(maxobs/4,maxcurves), + &ALightyield_npq(maxobs/4,maxcurves), + &ALightqlake(maxobs/4,maxcurves), + &ALightqpuddle(maxobs/4,maxcurves), + &ALightkps2_norm(maxobs/4,maxcurves), + &ALightknpq_norm(maxobs/4,maxcurves), + &ALightresiststomco2(maxobs/4,maxcurves), + + &Freeanet_obs(maxobs/4),Freepco2i(maxobs/4), + &Freetempleaf(maxobs/4),FreeaPPFDlf(maxobs/4), + &Freepres_air(maxobs/4),Freepo2i(maxobs/4), + &Freechlflphips2(maxobs/4),Freepco2ambient(maxobs/4), + &Freetrmmol(maxobs/4),Freegswmeas(maxobs/4), + &Freevpdl(maxobs/4),Freetempair(maxobs/4), + &Freeeambient(maxobs/4),Freefo_pam(maxobs/4), + &Freefm_pam(maxobs/4),Freefs_pam(maxobs/4), + &Freepam_measlight(maxobs/4),Freeyield_ps2(maxobs/4), + &Freeyield_npq(maxobs/4),Freeqlake(maxobs/4), + &Freeqpuddle(maxobs/4),Freekps2_norm(maxobs/4), + &Freeknpq_norm(maxobs/4),Freeresiststomco2(maxobs/4) + + integer ifitmode,ntotsamples,ntotphips2,nFixedPoints,numACicurves, + &nACiPoints(maxcurves),numALightcurves,nALightPoints(maxcurves), + &nFreePoints,Fixediphotolimit(maxobs), + &ACiiphotolimit(maxobs/4,maxcurves), + &ALightiphotolimit(maxobs/4,maxcurves),Freeiphotolimit(maxobs/4), + &Prioriphotolimit(maxobs),Priorilimittype,Prioriknowlimit, + &Currentiphotolimit(maxobs),Currentilimittype,Currentiknowlimit, + &Postiphotolimit(maxobs),bestiphotolimit(maxobs),bestilimittype, + &subbestiphotolimit(maxobs,7),nendaci(maxcurves), + &nstartaci(maxcurves),nendalight(maxcurves), + &nstartalight(maxcurves),ialightorder(maxcurves),ntotlights, + &ialightrubpmin(maxcurves),ialightrubpmax(maxcurves), + &ialightmin(maxcurves),ialightmax(maxcurves) + + common /dbleleafgasobservations/anet_obs,pco2i,templeaf, + &aPPFDlf,pres_air,po2i,chlflphips2,pco2ambient,trmmol,gswmeas, + &vpdl,tempair,eambient,resiststomco2,sumsquare,pco2i_ori, + &templeaf_ori,aPPFDlf_ori,pres_air_ori,po2i_ori,chlflphips2_ori, + &pco2ambient_ori,trmmol_ori,gswmeas_ori,vpdl_ori,tempair_ori, + &eambient_ori,fo_pam,fm_pam,fs_pam,pam_measlight,yield_ps2, + &yield_npq,qlake,qpuddle,kps2_norm,knpq_norm, + &resiststomco2_ori,pco2i_pred,anet_pred,PhiPSII_pred, + &pco2c,bestsumsquare,subbestsumsquare,forcings,weitforcings, + &responses,weitresponses,pco2i_pred_flu,anet_pred_flu, + &pco2c_pco2i_flu,pco2c_anet_flu,PhiPSIIlights_pred,templflights, + &aparlights,flphips2lights,flujmaxfval, + + &Fixedanet_obs,Fixedpco2i,Fixedtempleaf,FixedaPPFDlf,Fixedpres_air, + &Fixedpo2i,Fixedchlflphips2,Fixedpco2ambient,Fixedtrmmol, + &Fixedgswmeas,Fixedvpdl,Fixedtempair,Fixedeambient,Fixedfo_pam, + &Fixedfm_pam,Fixedfs_pam,Fixedpam_measlight,Fixedyield_ps2, + &Fixedyield_npq,Fixedqlake,Fixedqpuddle,Fixedkps2_norm, + &Fixedknpq_norm,Fixedresiststomco2, + &ACianet_obs0,ACipco2i0,ACitempleaf0,ACiaPPFDlf0,ACipres_air0, + &ACipo2i0,ACichlflphips20,ACipco2ambient0,ACitrmmol0,ACigswmeas0, + &ACivpdl0,ACitempair0,ACieambient0,ACifo_pam0,ACifm_pam0, + &ACifs_pam0,ACipam_measlight0,ACiyield_ps20,ACiyield_npq0, + &ACiqlake0,ACiqpuddle0,ACikps2_norm0,ACiknpq_norm0, + &ACiresiststomco20,ACianet_obs, + &ACipco2i,ACitempleaf,ACiaPPFDlf,ACipres_air,ACipo2i, + &ACichlflphips2,ACipco2ambient,ACitrmmol,ACigswmeas,ACivpdl, + &ACitempair,ACieambient,ACifo_pam,ACifm_pam,ACifs_pam, + &ACipam_measlight,ACiyield_ps2,ACiyield_npq,ACiqlake,ACiqpuddle, + &ACikps2_norm,ACiknpq_norm,ACiresiststomco2,ALightanet_obs0, + &ALightpco2i0,ALighttempleaf0,ALightaPPFDlf0,ALightpres_air0, + &ALightpo2i0,ALightchlflphips20,ALightpco2ambient0,ALighttrmmol0, + &ALightgswmeas0,ALightvpdl0,ALighttempair0,ALighteambient0, + &ALightfo_pam0,ALightfm_pam0,ALightfs_pam0,ALightpam_measlight0, + &ALightyield_ps20,ALightyield_npq0,ALightqlake0,ALightqpuddle0, + &ALightkps2_norm0,ALightknpq_norm0, + &ALightresiststomco20,ALightanet_obs,ALightpco2i,ALighttempleaf, + &ALightaPPFDlf,ALightpres_air,ALightpo2i,ALightchlflphips2, + &ALightpco2ambient,ALighttrmmol,ALightgswmeas,ALightvpdl, + &ALighttempair,ALighteambient,ALightfo_pam,ALightfm_pam, + &ALightfs_pam,ALightpam_measlight,ALightyield_ps2, + &ALightyield_npq,ALightqlake,ALightqpuddle,ALightkps2_norm, + &ALightknpq_norm,ALightresiststomco2,Freeanet_obs, + &Freetempleaf,FreeaPPFDlf,Freepres_air,Freepo2i,Freechlflphips2, + &Freepco2ambient,Freetrmmol,Freegswmeas,Freevpdl,Freetempair, + &Freeeambient,Freefo_pam,Freefm_pam,Freefs_pam,Freepam_measlight, + &Freeyield_ps2,Freeyield_npq,Freeqlake,Freeqpuddle,Freekps2_norm, + &Freeknpq_norm,Freeresiststomco2 + + common /intleafgasobservations/ifitmode,ntotsamples,ntotphips2, + &nFixedPoints,numACicurves,nACiPoints,numALightcurves, + &nALightPoints,nFreePoints, + &Fixediphotolimit,ACiiphotolimit,ALightiphotolimit,Freeiphotolimit, + &Prioriphotolimit,Priorilimittype,Prioriknowlimit, + &Currentiphotolimit,Currentilimittype,Currentiknowlimit, + &Postiphotolimit,bestiphotolimit,bestilimittype,subbestiphotolimit, + &nendaci,nstartaci,nendalight,nstartalight,ialightorder,ntotlights, + &ialightrubpmin,ialightrubpmax,ialightmin,ialightmax + + save /dbleleafgasobservations/,/intleafgasobservations/ +!-------- End of list of common block variables ------------------ diff --git a/leafres/testarea/LeafGasPISCAL_mpi.f b/leafres/testarea/LeafGasPISCAL_mpi.f new file mode 100644 index 0000000..fdcb914 --- /dev/null +++ b/leafres/testarea/LeafGasPISCAL_mpi.f @@ -0,0 +1,364 @@ +!Photosynthetic, Internal and Stomatal Conductance Analyses of Leaves (PISCAL) +! +!Created by: Lianhong Gu +! Environmental Sciences Dvision +! Oak Ridge National Laboratory +! Oak Ridge, TN 37831 +! lianhong-gu@ornl.gov +!with support from Department of Energy Office of Science, Biological +!and Environmental Research Program +! +!PISCAL first created 10 July 2008 +!Paralle PISCAL 20 Feb 2013 +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() + program main + implicit none + include 'mpif.h' + integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2, + &ntotfiles,noutputfiles,i,j,k,rank_mpi,numproc_mpi,numproc, + &ierror_mpi,nshare,nmod,npartfiles,istartno,iendno,indexunit(20), + &numchar,needheader(20),rootprocess + character rundate*8,runtime*10,runzone*5,longchar*5000,achar*5, + &longchar1*5000 + character*100 datapath,outpath,storein,storeout,ACidata(8000) + character*50 AllACiFiles,outputfile(20) + +! Set input / output directory + parameter( + & datapath= +! &'/home/l2g/ngeetropics/gamboa/curves/', +! &'/home/l2g/ngeetropics/metropolitano/curves/', +! &'/home/l2g/ngeetropics/fortsherman/curves/', +! & '/home/l2g/ngeetropics/kelsey/curves/', +! & '/home/l2g/leafres/hybriddata/Berner/', + & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! &'/home/l2g/leafweb/data/dweston/Sphagnum_leafweb_Oct2015/', + +! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/', +! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/ +! &', +! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data3/', +! &'/home/l2g/leafres/hybriddata/cernusak/2014data/', +! & '/home/l2g/dataassim/leaf/data/moflux/2008/inputs/', +! & '/home/l2g/leafres/hybriddata/sphagnum/2014data1/', +!for moflux data, 2004-2008 requires correction of Ci. Other years do not +! & '/home/l2g/dataassim/leaf/data/LawData/inputs/', +! & '/home/l2g/dataassim/leaf/data/dweston/inputs/', +! & '/home/l2g/dataassim/leaf/data/johnbaker/inputs/', +! & '/home/l2g/dataassim/leaf/data/martins/inputs/', +! & '/home/l2g/dataassim/leaf/data/benzi/inputs/', +! & '/home/l2g/dataassim/leaf/data/loos/inputs/', +! & '/home/l2g/dataassim/leaf/data/ellsworth/inputs/', + +! & '/home/l2g/dataassim/leaf/data/fromleafweb/inputs/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/testkco/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/rwprch/', +! & '/home/l2g/dataassim/leaf/data/panama/sept2012/inputs/', +! &'/home/l2g/dataassim/leaf/data/williams/inputs/', +! & '/home/l2g/dataassim/leaf/test/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/Martins/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/collantes/', +! & '/home/l2g/dataassim/leaf/data/dweston/inputs/', +! & '/home/l2g/GEMSiS/curves/', + & outpath= +! &'/home/l2g/ngeetropics/gamboa/results/', +! &'/home/l2g/ngeetropics/metropolitano/results/', +! &'/home/l2g/ngeetropics/fortsherman/', +! &'/home/l2g/ngeetropics/kelsey/results/', +! & '/home/l2g/leafres/hybriddata/Berner/', + & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! &'/home/l2g/leafweb/data/dweston/Sphagnum_leafweb_Oct2015/', +! &'/home/l2g/leafres/hybriddata/cernusak/2014data/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/', +! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data3/', +! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/ +! &', +! & '/home/l2g/dataassim/leaf/data/moflux/2008/outputs/', +! & '/home/l2g/dataassim/leaf/data/moflux/2012/outputs/', +! & '/home/l2g/dataassim/leaf/data/LawData/outputs/', +! & '/home/l2g/dataassim/leaf/data/dweston/outputs/', +! & '/home/l2g/dataassim/leaf/data/johnbaker/outputs/', +! & '/home/l2g/dataassim/leaf/data/martins/outputs/', +! & '/home/l2g/dataassim/leaf/data/benzi/outputs/', +! & '/home/l2g/dataassim/leaf/data/loos/outputs/', +! & '/home/l2g/dataassim/leaf/data/ellsworth/outputs/', + +! &'/home/l2g/leafres/hybriddata/sphagnum/2014results1/', +! &'/home/l2g/junk/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/testkco/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/rwprch/results/', +! & '/home/l2g/dataassim/leaf/data/panama/sept2012/outputs/', +! &'/home/l2g/dataassim/leaf/data/panama/sept2012/outputs/rwprch/', +! & '/home/l2g/mpitest/', +! &'/home/l2g/dataassim/leaf/data/williams/outputs/', +! & '/home/l2g/dataassim/leaf/data/fromleafweb/outputs/withpad/', +! & '/home/l2g/dataassim/leaf/test/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/collantes/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/Martins/', +! & '/home/l2g/dataassim/leaf/data/dweston/outputs/', +! & '/home/l2g/GEMSiS/results/', +! &storein='/home/l2g/leafweb/users/curves/', +! &storeout='/home/l2g/leafweb/users/results/', + + &storein='/home/l2g/clm/results/', + &storeout='/home/l2g/clm/results/', +! &storein='/home/l2g/junk/', +! &storeout='/home/l2g/junk/', +! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/', +! &storeout='/home/l2g/dataassim/leaf/data/ellsworth/outputs/', + + & AllACiFiles='AllLeafGasFiles') +!---------------End of variable declaration---------------- + rootprocess=0 + dataunit=1 + spareunit=3 +! if(rank_mpi.ne.rootprocess)goto 25 +!read A/Ci curve names stored in AllACiFiles + open(unit=2,file=trim(datapath)//trim(AllACiFiles)) + ntotfiles=1 +10 read(2,fmt=300,end=20)longchar + i=len(longchar) + j=0 +15 j=j+1 + if(longchar(j:j).ne.''.or.longchar(j:j).ne.' ')then + ipos1=j + else + if(j.ge.i)goto 10 + goto 15 + endif + j=i+1 +16 j=j-1 + if(longchar(j:j).ne.''.or.longchar(j:j).ne.' ')then + ipos2=j + else + if(j.le.1)goto 10 + goto 16 + endif + ACidata(ntotfiles)=longchar(ipos1:ipos2) + ntotfiles=ntotfiles+1 + goto 10 +20 ntotfiles=ntotfiles-1 + close(2) + outputfile(1)='leafgasparameters.csv' + outputfile(2)='leafgascomparison.csv' + outputfile(3)='stomwuecicaparameters.csv' + outputfile(4)='stomcomparison.csv' + outputfile(5)='wuecicacomparison.csv' + outputfile(6)='fluorescencefit.csv' + outputfile(7)='fluoresparameters.csv' + outputfile(8)='aciempfitparameters.csv' + outputfile(9)='alightempfitparameters.csv' + outputfile(10)='warningmessage' + outputfile(11)='errormessage' + noutputfiles=11 +!10 to 20 are used for file units for output files + do i=1,noutputfiles + indexunit(i)=i+9 + enddo + call MPI_INIT(ierror_mpi) + call MPI_COMM_RANK(MPI_COMM_WORLD,rank_mpi,ierror_mpi) + call MPI_COMM_SIZE(MPI_COMM_WORLD,numproc,ierror_mpi) +!25 continue +! call MPI_BCAST(ACidata,ntotfiles,MPI_CHARACTER,rootprocess, +! &MPI_COMM_WORLD,ierror_mpi) +! call MPI_BCAST(ntotfiles,1,MPI_INTEGER,rootprocess, +! &MPI_COMM_WORLD,ierror_mpi) +! call MPI_BCAST(outputfile,noutputfiles,MPI_CHARACTER,rootprocess, +! &MPI_COMM_WORLD,ierror_mpi) +! call MPI_BCAST(indexunit,noutputfiles,MPI_INTEGER,rootprocess, +! &MPI_COMM_WORLD,ierror_mpi) +! call MPI_BCAST(noutputfiles,1,MPI_INTEGER,rootprocess, +! &MPI_COMM_WORLD,ierror_mpi) +!make sure the number of processors actually needed not to exceed the number of curves + numproc_mpi=min0(ntotfiles,numproc) +!only processors with ranks 0,1,.......numproc_mpi-1 actually do work and the rest +!go idle + if(rank_mpi.ge.numproc_mpi)goto 45 + nshare=ntotfiles/numproc_mpi + nmod=ntotfiles-nshare*numproc_mpi + if((rank_mpi+1).le.nmod)then + npartfiles=nshare+1 + istartno=rank_mpi*npartfiles+1 + iendno=(rank_mpi+1)*npartfiles + else + npartfiles=nshare + istartno=nmod*(nshare+1)+(rank_mpi+1-nmod-1)*nshare+1 + iendno=istartno+nshare-1 + endif + numchar=1 +30 if(rank_mpi.lt.(10**numchar))goto 40 + numchar=numchar+1 + goto 30 +40 call NumberToChar(rank_mpi,numchar,achar) + do i=1,noutputfiles-1 + open(unit=indexunit(i), + &file=trim(outpath)//trim(outputfile(i))//trim(achar)) + enddo + call ToLeafGasOptimization(npartfiles,ACidata(istartno:iendno), + &dataunit,spareunit,datapath,indexunit,ierr) + do i=1,noutputfiles-1 + close(indexunit(i)) + enddo + if(ierr(1).ne.0)then + i=indexunit(noutputfiles) + open(unit=i, + &file=trim(outpath)//trim(outputfile(noutputfiles))//trim(achar)) + write(i,*)'Input data error in ',ACidata(ierr(2)+istartno-1) + write(i,*) + &'Please resubmit the data after correcting the following error:' + if(ierr(1).eq.1)then + write(i,*)'Photosynthesis (umol/m2/s) out of range' + endif + if(ierr(1).eq.2)then + write(i,*)'Intercellular CO2(ppm) out of range' + endif + if(ierr(1).eq.3)then + write(i,*)'Leaf temperature (oC) out of range' + endif + if(ierr(1).eq.4)then + write(i,*)'Chamber PAR (umol/m2/s) out of range' + endif + if(ierr(1).eq.5)then + write(i,*)'Atmospheric pressure (Pa) out of range' + endif + if(ierr(1).eq.13)then + write(i,*)'Check line 13 for data entry error' + endif + if(ierr(1).eq.14)then + write(i,*)'Specified chloroplastic CO2 compensation point', + &'(Pa) out of range' + endif + if(ierr(1).eq.15)then + write(i,*)'Specified Michaelis-Menten constant for the', + &'carboxylase (Kc) out of range' + endif + if(ierr(1).eq.16)then + write(i,*)'Specified Michaelis-Menten constant for the', + &'oxygenase (Ko) out of range' + endif + if(ierr(1).eq.17)then + write(i,*)'Specified fraction of nonreturned glycolate', + &'carbon(alpha) out of range 0~1' + endif + if(ierr(1).eq.18)then + write(i,*)'Specified dark respiration rate Rd out of range >0' + endif + if(ierr(1).eq.19)then + write(i,*)'Specified mesophyll) resistance rch or rwp out of', + &'of range >0' + endif + if(ierr(1).eq.34)then + write(i,*)'Check Column 33 or 34. Mixing area- and mass-based + &measurements is not allowed' + endif + if(ierr(1).eq.36)then + write(i,*)'Check line 16 for data entry error' + endif + if(ierr(1).eq.39)then + write(i,*) + &'Check the main body of data for data entry error, starting from + &line 19' + endif + if(ierr(1).eq.40)then + write(i,*) + &'Data file format cannot be recognized' + endif + + close(i) + endif +!make sure everyone is done before wrapping up. +45 call MPI_BARRIER(MPI_COMM_WORLD,ierror_mpi) + if(rank_mpi.eq.rootprocess)then + do j=1,noutputfiles + open(unit=indexunit(j),file= + &trim(outpath)//trim(outputfile(j))) + needheader(j)=0 + enddo +!needheader=0: the two headerlines as well as data have not been written yet +!needheader=1: the two headerlines but no data have been written +!needheader=2: the two headerlines and data have been written + do i=1,numproc_mpi + rank_mpi=i-1 + numchar=1 +50 if(rank_mpi.lt.(10**numchar))goto 60 + numchar=numchar+1 + goto 50 +60 call NumberToChar(rank_mpi,numchar,achar) + do j=1,noutputfiles-2 + k=0 + open(unit=2,file= + &trim(outpath)//trim(outputfile(j))//trim(achar)) + if(needheader(j).eq.1.or.needheader(j).eq.2)then + read(2,*,end=70) + read(2,*,end=70) + else + read(2,fmt=300,end=70)longchar + read(2,fmt=300,end=70)longchar1 + write(indexunit(j),310)trim(longchar) + write(indexunit(j),310)trim(longchar1) + needheader(j)=1 + endif +65 read(2,fmt=300,end=70)longchar + write(indexunit(j),310)trim(longchar) + needheader(j)=2 + k=1 + goto 65 +70 close(2,status='delete') + enddo + do j=noutputfiles-1,noutputfiles + open(unit=2,file= + &trim(outpath)//trim(outputfile(j))//trim(achar)) +75 read(2,fmt=300,end=80)longchar + write(indexunit(j),310)trim(longchar) + needheader(j)=2 + goto 75 +80 close(2,status='delete') + enddo + enddo + do j=1,noutputfiles + if(needheader(j).eq.2)then +!keep files that contain data + close(indexunit(j)) + else +!delete files that contain no data + close(indexunit(j),status='delete') + endif + enddo +!---------------------------------------------------------- +!intercept the data + goto 450 +399 call date_and_time(rundate,runtime,runzone,runvalues) + do i=1,ntotfiles + open(unit=1,file=trim(datapath)//trim(ACidata(i))) + open(unit=2,file= + &trim(storein)//rundate//runtime(1:6)//trim(ACidata(i))) +400 read(1,fmt=300,end=410)longchar + write(2,310)trim(longchar) + goto 400 +410 close(1) + close(2) + enddo + do i=1,6 + k=0 + open(unit=1,file=trim(outpath)//trim(outputfile(i))) + open(unit=2,file= + &trim(storeout)//rundate//runtime(1:6)//trim(outputfile(i))) +420 read(1,fmt=300,end=430)longchar + write(2,310)trim(longchar) + k=1 + goto 420 +430 if(k.eq.1)then + close(1) + close(2) + else + close(1,status='delete') + close(2,status='delete') + endif + enddo + endif +450 call MPI_FINALIZE(ierror_mpi) +!---------------------------------------------------------- +300 format(a5000) +310 format(a) + end +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ diff --git a/leafres/testarea/LeafGasPISCAL_single.f b/leafres/testarea/LeafGasPISCAL_single.f new file mode 100644 index 0000000..2e7e069 --- /dev/null +++ b/leafres/testarea/LeafGasPISCAL_single.f @@ -0,0 +1,297 @@ +!Photosynthetic, Internal and Stomatal Conductance Analyses of Leaves (PISCAL) +! +!Created by: Lianhong Gu +! Environmental Sciences Dvision +! Oak Ridge National Laboratory +! Oak Ridge, TN 37831 +! lianhong-gu@ornl.gov +!with support from Department of Energy Office of Science, Biological +!and Environmental Research Program +! +!PISCAL first created 10 July 2008 +!Paralle PISCAL 20 Feb 2013 +!Updated 24 Jan 1014 +!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()() + program main + implicit none + integer dataunit,spareunit,ierr(2),runvalues(8),ipos1,ipos2, + &ntotfiles,noutputfiles,i,j,k,indexunit(20) + character rundate*8,runtime*10,runzone*5,longchar*5000 + character*100 datapath,outpath,storein,storeout, + &ACidata(8000) + character*50 AllACiFiles,outputfile(20) + +! Set input / output directory + parameter(datapath= +! &'/home/l2g/ngeetropics/gamboa/curves/', +! &'/home/l2g/ngeetropics/metropolitano/curves/', +! &'/home/l2g/ngeetropics/fortsherman/curves/', +! &'/home/l2g/ngeetropics/kelsey/curves/', + & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data3/', +! &'/home/l2g/leafres/hybriddata/cernusak/2014data/', +! &'/home/l2g/leafres/hybriddata/hanjimei/', +! &'/home/l2g/junk/', +! & '/home/l2g/leafres/hybriddata/Berner/', +! & '/home/l2g/leafres/hybriddata/huidafeng/', +! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/ +! &'/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! & '/home/l2g/dataassim/leaf/data/moflux/2008/inputs/', +! & '/home/l2g/leafres/hybriddata/sphagnum/2014data1/', +! & '/home/l2g/dataassim/leaf/data/moflux/2010/inputs/', +!for moflux data, 2004-2008 requires correction of Ci. Other years do not +! & '/home/l2g/dataassim/leaf/data/LawData/inputs/', +! & '/home/l2g/dataassim/leaf/data/dweston/inputs/', +! & '/home/l2g/dataassim/leaf/data/johnbaker/inputs/', +! & '/home/l2g/dataassim/leaf/data/martins/inputs/', +! & '/home/l2g/dataassim/leaf/data/benzi/inputs/', +! & '/home/l2g/dataassim/leaf/data/loos/inputs/', +! & '/home/l2g/dataassim/leaf/data/ellsworth/inputs/', + +! & '/home/l2g/dataassim/leaf/data/fromleafweb/inputs/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/testkco/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/rwprch/', +! & '/home/l2g/dataassim/leaf/data/panama/sept2012/inputs/', +! &'/home/l2g/dataassim/leaf/data/williams/inputs/', +! & '/home/l2g/dataassim/leaf/test/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/Martins/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/collantes/', +! & '/home/l2g/dataassim/leaf/data/dweston/inputs/', +! & '/home/l2g/GEMSiS/curves/', + & outpath= +! &'/home/l2g/ngeetropics/gamboa/results/', +! &'/home/l2g/ngeetropics/metropolitano/results/', +! &'/home/l2g/ngeetropics/fortsherman/results/', +! &'/home/l2g/ngeetropics/kelsey/results/', +! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data3/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/wenting/', +! &'/home/l2g/leafres/testdata/', +! &'/home/l2g/leafres/hybriddata/hanjimei/', +! +! & '/home/l2g/leafres/hybriddata/Berner/', + & '/home/l2g/SingleLeafModel/ACiSimulation/hybrid/', +! & '/home/l2g/leafres/hybriddata/huidafeng/', +! &'/home/l2g/leafres/hybriddata/dwestonpoplus/data_Pn_tree_1_195_v2/ +! &', +! & '/home/l2g/dataassim/leaf/data/moflux/2008/outputs/', +! & '/home/l2g/dataassim/leaf/data/moflux/2012/outputs/', +! & '/home/l2g/dataassim/leaf/data/LawData/outputs/', +! & '/home/l2g/dataassim/leaf/data/dweston/outputs/', +! & '/home/l2g/dataassim/leaf/data/johnbaker/outputs/', +! & '/home/l2g/dataassim/leaf/data/martins/outputs/', +! & '/home/l2g/dataassim/leaf/data/benzi/outputs/', +! & '/home/l2g/dataassim/leaf/data/loos/outputs/', +! & '/home/l2g/dataassim/leaf/data/ellsworth/outputs/', +! &'/home/l2g/leafres/hybriddata/sphagnum/2014results1/', +! &'/home/l2g/junk/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/testkco/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/rwprch/results/', +! & '/home/l2g/dataassim/leaf/data/panama/sept2012/outputs/', +! &'/home/l2g/dataassim/leaf/data/panama/sept2012/outputs/rwprch/', +! & '/home/l2g/mpitest/', +! &'/home/l2g/dataassim/leaf/data/williams/outputs/', +! & '/home/l2g/dataassim/leaf/data/fromleafweb/outputs/withpad/', +! & '/home/l2g/dataassim/leaf/test/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/collantes/', +! & '/home/l2g/SingleLeafModel/ACiSimulation/Martins/', +! & '/home/l2g/dataassim/leaf/data/dweston/outputs/', +! & '/home/l2g/GEMSiS/results/', +! &storein='/home/l2g/leafweb/users/curves/', +! &storeout='/home/l2g/leafweb/users/results/', + + &storein='/home/l2g/leafres/testdata/', + &storeout='/home/l2g/leafres/testdata/', +! &storein='/home/l2g/junk/', +! &storeout='/home/l2g/junk/', +! &storein='/home/l2g/dataassim/leaf/data/ellsworth/outputs/', +! &storeout='/home/l2g/dataassim/leaf/data/ellsworth/outputs/', + + & AllACiFiles='AllLeafGasFiles') +!---------------End of variable declaration---------------- + ierr(1)=-1 + ierr(2)=-1 + outputfile(1)='leafgasparameters.csv' + outputfile(2)='leafgascomparison.csv' + outputfile(3)='stomwuecicaparameters.csv' + outputfile(4)='stomcomparison.csv' + outputfile(5)='wuecicacomparison.csv' + outputfile(6)='fluorescencefit.csv' + outputfile(7)='fluoresparameters.csv' + outputfile(8)='aciempfitparameters.csv' + outputfile(9)='alightempfitparameters.csv' + outputfile(10)='warningmessage' + outputfile(11)='errormessage' + noutputfiles=11 + do i=1,noutputfiles + indexunit(i)=i+9 + enddo + do i=1,noutputfiles-1 + open(unit=indexunit(i),file=trim(outpath)//trim(outputfile(i))) + enddo +!read A/Ci curve names stored in AllACiFiles + dataunit=1 + spareunit=3 + open(unit=dataunit,status='scratch') + open(unit=spareunit,file=trim(datapath)//trim(AllACiFiles)) + read(spareunit,fmt=300,err=40,end=40)longchar + rewind(spareunit) +2 read(spareunit,fmt=300,err=40,end=5)longchar +3 k=index(longchar,char(13)) + if(k.gt.0)then +!DOS text format, convert it to unix format + longchar(k:k+len(char(10))-1)=char(10) + goto 3 + endif + write(dataunit,310)trim(longchar) + goto 2 +5 close(spareunit) + rewind(dataunit) + ntotfiles=1 +10 read(dataunit,fmt=300,end=20)longchar + i=len(longchar) + j=0 +15 j=j+1 + if(ichar(longchar(j:j)).ge.33.and.ichar(longchar(j:j)).le.127)then + ipos1=j + else + if(j.ge.i)goto 10 + goto 15 + endif + j=i+1 +16 j=j-1 + if(ichar(longchar(j:j)).ge.33.and.ichar(longchar(j:j)).le.127)then + ipos2=j + else + if(j.le.1)goto 10 + goto 16 + endif + ACidata(ntotfiles)=longchar(ipos1:ipos2) + ntotfiles=ntotfiles+1 + goto 10 +20 ntotfiles=ntotfiles-1 + close(dataunit) + call ToLeafGasOptimization(ntotfiles,ACidata,dataunit,spareunit, + &datapath,indexunit,ierr) +40 do i=1,noutputfiles-1 + close(indexunit(i)) + enddo + if(ierr(1).ne.0)then + i=indexunit(noutputfiles) + open(unit=i,file=trim(outpath)//trim(outputfile(noutputfiles))) + if(ierr(1).eq.-1)then + close(spareunit) + write(i,*) + &'No data files to analyze or incorrect file name format' + else + write(i,*)'Input data error in ',trim(ACidata(ierr(2))) + write(i,*) + &'Please resubmit the data after correcting the following error:' + endif + if(ierr(1).eq.1)then + write(i,*)'Photosynthesis (umol/m2/s) out of range' + endif + if(ierr(1).eq.2)then + write(i,*)'Intercellular CO2(ppm) out of range' + endif + if(ierr(1).eq.3)then + write(i,*)'Leaf temperature (oC) out of range' + endif + if(ierr(1).eq.4)then + write(i,*)'Chamber PAR (umol/m2/s) out of range' + endif + if(ierr(1).eq.5)then + write(i,*)'Atmospheric pressure (Pa) out of range' + endif + if(ierr(1).eq.13)then + write(i,*)'Check line 13 for data entry error' + endif + if(ierr(1).eq.14)then + write(i,*)'Specified chloroplastic CO2 compensation point', + &'(Pa) out of range' + endif + if(ierr(1).eq.15)then + write(i,*)'Specified Michaelis-Menten constant for the', + &'carboxylase (Kc) out of range' + endif + if(ierr(1).eq.16)then + write(i,*)'Specified Michaelis-Menten constant for the', + &'oxygenase (Ko) out of range' + endif + if(ierr(1).eq.17)then + write(i,*)'Specified fraction of nonreturned glycolate', + &'carbon(alpha) out of range 0~1' + endif + if(ierr(1).eq.18)then + write(i,*)'Specified dark respiration rate Rd out of range >0' + endif + if(ierr(1).eq.19)then + write(i,*)'Specified internal (mesophyll) conductance gi out', + &'of range >0' + endif + if(ierr(1).eq.34)then + write(i,*)'Check Column 33 or 34. Mixing area- and mass-based + &measurements is not allowed' + endif + if(ierr(1).eq.36)then + write(i,*)'Check line 16 for data entry error' + endif + if(ierr(1).eq.39)then + write(i,*) + &'Check the main body of data for data entry error, starting from + &line 19' + endif + if(ierr(1).eq.40)then + write(i,*) + &'Data file format cannot be recognized' + endif + + close(i) + endif + do j=1,noutputfiles + open(unit=2,file=trim(outpath)//trim(outputfile(j))) + read(2,*,end=70) + if(j.le.(noutputfiles-2))then + read(2,*,end=70) + read(2,*,end=70) + endif + close(2) + goto 80 +70 close(2,status='delete') +80 enddo +!---------------------------------------------------------- +!intercept the data + goto 450 +399 call date_and_time(rundate,runtime,runzone,runvalues) + do i=1,ntotfiles + open(unit=1,file=trim(datapath)//trim(ACidata(i))) + open(unit=2,file= + &trim(storein)//rundate//runtime(1:6)//trim(ACidata(i))) +400 read(1,fmt=300,end=410)longchar + write(2,310)trim(longchar) + goto 400 +410 close(1) + close(2) + enddo + do i=1,6 + k=0 + open(unit=1,file=trim(outpath)//trim(outputfile(i))) + open(unit=2,file= + &trim(storeout)//rundate//runtime(1:6)//trim(outputfile(i))) +420 read(1,fmt=300,end=430)longchar + write(2,310)trim(longchar) + k=1 + goto 420 +430 if(k.eq.1)then + close(1) + close(2) + else + close(1,status='delete') + close(2,status='delete') + endif + enddo +450 continue +!---------------------------------------------------------- +300 format(a5000) +310 format(a) + end +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ diff --git a/leafres/testarea/LeafGasParams.h b/leafres/testarea/LeafGasParams.h new file mode 100644 index 0000000..7e530fb --- /dev/null +++ b/leafres/testarea/LeafGasParams.h @@ -0,0 +1,96 @@ +! This file contains common blocks used in the optimization runs. +! +! ------ Optimization variables common Blocks --------------------- +! maxobs: the maximum number of observations +! maxpsnparam: the maximum number of parameters to be optimized +! aPPFDlf: PAR absorbed by leaf (umol m-2 s-1) +! templeaf: leaf temperature (K) +! xpco2i: Intercellular CO2 partial pressure (Pa) +! po2i: Intercellular oxygen partial pressure (Pa) +! obs_psn: net photosynthetic rate (umol m-2 s-1) +! psnparamx: parameters in the leaf photosynthetic model +! nobs: integer, the actual number of observations +! IFIXBcp: the index for the parameters in psnparams that are being +! optimized (0= not optimized; 1= optimized) +! ilimittype: indicator for the choice of limitation types +! = 1, Rubisco+RuBP+TPU' +! = 2, Rubisco+RuBP +! = 3, Rubisco+TPU +! = 4, RuBP+TPU +! = 5, Rubisco Only +! = 6, RuBP Only +! = 7, TPU Only +! betamin: the lower bound of the parameters to be optimized +! betamax: the upper bound of the parameters to be optimized +!resistwp: =rwp, resistance to CO2 via cell walls and plasmalemma (Pa s m2 umol-1). If less than zero, set to zero. +!resistch: =rch, resistance to CO2 via chloroplast envelope and stroma (Pa s m2 umol-1). If less than zero, set to zero. +!idorwp, =0 zero rwp +! =1 fit for rwp +! =2 keep input rwp and don't optimize it +!idorch, =0 zero rch +! =1 fit for rch +! =2 keep input rch and don't optimize it +! ntotparams: the total number of optimized and unoptimized parameters +! isitgridsearch=0, in optimization mode (cij+cic is the transition RuBp-TPU CO2i threshold) +! =1, in grid search mode (cij is the transition RuBp-TPU CO2i threshold) + + integer maxpsnparam + parameter (maxpsnparam=50) + + double precision univparams(maxpsnparam), + &univparamsmin(maxpsnparam),univparamsmax(maxpsnparam), + &betamin(maxpsnparam),betamax(maxpsnparam),resistwp25,resistch25, + &rdlight25,stargamma25,vcmax25,fkc25,fko25,fjmax25,tpu25,alpha25, + &bestunivparams(maxpsnparam),resistwp25_ori,resistch25_ori, + &rdlight25_ori,stargamma25_ori,vcmax25_ori,fkc25_ori,fko25_ori, + &fjmax25_ori,tpu25_ori,alpha25_ori,gascon,ha_vcmax,hd_vcmax, + &sv_vcmax,ha_jmax,hd_jmax,sv_jmax,ha_tpu,hd_tpu,sv_tpu, + &ha_gmeso,hd_gmeso,sv_gmeso,ha_darkresp,ha_stargamma,ha_kc,ha_ko, + &abspt_lf_par,resistwp25min,resistch25min,rdlight25min, + &stargamma25min,vcmax25min,fkc25min,fko25min,fjmax25min,tpu25min, + &alpha25min,resistwp25max,resistch25max,rdlight25max, + &stargamma25max,vcmax25max,fkc25max,fko25max,fjmax25max,tpu25max, + &alpha25max,gacontrol(maxpsnparam), + &subbestunivparams(maxpsnparam,7),phifactor,phifactormin, + &phifactormax,thetafactor,thetafactormin,thetafactormax, + &phifactor_ori,thetafactor_ori,betaPSII,betaPSIImin,betaPSIImax, + &betaPSII_ori,ha_darkrespmin,ha_darkrespmax,ha_darkresp_ori, + &ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin, + &ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori, + &ha_tpumin,ha_tpumax,ha_tpu_ori,ha_gmesomin,ha_gmesomax, + &ha_gmeso_ori + + integer minimumrubis,minimumfj,minimumvt,idorwp,idorch,idord, + &idostargamma,idoalpha,idokc,idoko,ifixunivparams(maxpsnparam), + &ntotunivparams,bestnumrubis,bestnumrubp,bestnumtpu,isitbounded, + &idophifactor,idothetafactor,idobetaPSII,idoha_darkresp, + &idoha_stargamma,idoha_vcmax,idoha_jmax,idoha_tpu,idoha_gmeso + + common /dbleleafparams/univparams,univparamsmin,univparamsmax, + &betamin,betamax,resistwp25,resistch25,rdlight25,stargamma25, + &vcmax25,fkc25,fko25,fjmax25,tpu25,alpha25,bestunivparams, + &resistwp25_ori,resistch25_ori,rdlight25_ori,stargamma25_ori, + &vcmax25_ori,fkc25_ori,fko25_ori,fjmax25_ori,tpu25_ori,alpha25_ori, + &gascon,ha_vcmax,hd_vcmax,sv_vcmax,ha_jmax,hd_jmax,sv_jmax,ha_tpu, + &hd_tpu,sv_tpu,ha_gmeso,hd_gmeso,sv_gmeso,ha_darkresp,ha_stargamma, + &ha_kc,ha_ko,abspt_lf_par,resistwp25min,resistch25min,rdlight25min, + &stargamma25min,vcmax25min,fkc25min,fko25min,fjmax25min,tpu25min, + &alpha25min,resistwp25max,resistch25max,rdlight25max, + &stargamma25max,vcmax25max,fkc25max,fko25max,fjmax25max,tpu25max, + &alpha25max,gacontrol,subbestunivparams,phifactor,phifactormin, + &phifactormax,thetafactor,thetafactormin,thetafactormax, + &phifactor_ori,thetafactor_ori,betaPSII,betaPSIImin,betaPSIImax, + &betaPSII_ori,ha_darkrespmin,ha_darkrespmax,ha_darkresp_ori, + &ha_stargammamin,ha_stargammamax,ha_stargamma_ori,ha_vcmaxmin, + &ha_vcmaxmax,ha_vcmax_ori,ha_jmaxmin,ha_jmaxmax,ha_jmax_ori, + &ha_tpumin,ha_tpumax,ha_tpu_ori,ha_gmesomin,ha_gmesomax, + &ha_gmeso_ori + + common /intleafparams/minimumrubis,minimumfj,minimumvt,idorwp, + &idorch,idord,idostargamma,idoalpha,idokc,idoko,ifixunivparams, + &ntotunivparams,bestnumrubis,bestnumrubp,bestnumtpu,isitbounded, + &idophifactor,idothetafactor,idobetaPSII,idoha_darkresp, + &idoha_stargamma,idoha_vcmax,idoha_jmax,idoha_tpu,idoha_gmeso + + save /dbleleafparams/,/intleafparams/ +!-------- End of list of common block variables ------------------ diff --git a/leafres/testarea/LeafGasPrintToFiles.f b/leafres/testarea/LeafGasPrintToFiles.f new file mode 100644 index 0000000..fa7ad41 --- /dev/null +++ b/leafres/testarea/LeafGasPrintToFiles.f @@ -0,0 +1,884 @@ + subroutine LeafGasPrintToFiles(isitmassbased,indexunit) + implicit none + integer isitmassbased,indexunit(20),paramunit,compareunit, + &stomwuecicaoutunit,stomcompunit,wuecicacompunit,fluorescenceunit, + &fluoresparamunit,aciempfitunit,alightempfitunit + character *25, + & sitevars(50),unitsitevars(50), + & paramsvar(0:50),unitparamsvar(0:50), + & stomwuecica(200),unitstomwuecica(200), + & univcomvars(50),unitunivcomvars(50), + & univsumvars(50),unitunivsumvars(50), + & ACichars(50),unitACichars(50), + & ALightchars(50),unitALightchars(50), + &cterm1,cterm2 + integer i + +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + paramunit=indexunit(1) + compareunit=indexunit(2) + stomwuecicaoutunit=indexunit(3) + stomcompunit=indexunit(4) + wuecicacompunit=indexunit(5) + fluorescenceunit=indexunit(6) + fluoresparamunit=indexunit(7) + aciempfitunit=indexunit(8) + alightempfitunit=indexunit(9) + +!Fit for Amax_ACi and Asat_ALight + ACichars(1)='CurveID' + ACichars(2)='ACicurveNo' + ACichars(3)='CiatZeroAnet' + ACichars(4)='der_atCi' + ACichars(5)='Amax_ACi' + ACichars(6)='ACiIntercept' + ACichars(7)='der_atInterceptCi' + ACichars(8)='der_atACiend' + ACichars(9)='PhiPSIImax_ACi' + ACichars(10)='PhiPSIICiIntercept' + ACichars(11)='der_atInterceptCi' + ACichars(12)='der_atPhiPSIIendCi' + ACichars(13)='ACiMaxCurvature' + ACichars(14)='CO2i_ACiMaxcurva' + ACichars(15)='PhiPSIIMaxCurvatCi' + ACichars(16)='CO2i_PhiPSIIMaxCur' + ACichars(17)='CaatZeroAnet' + ACichars(18)='der_atCa' + ACichars(19)='Amax_ACa' + ACichars(20)='ACaIntercept' + ACichars(21)='der_atInterceptCa' + ACichars(22)='der_ACaat400ppm' + ACichars(23)='anet_ACaat400ppm' + ACichars(24)='PhiPSIImax_ACa' + ACichars(25)='PhiPSIICaIntercept' + ACichars(26)='der_atInterceptCa' + ACichars(27)='der_atPhiPSIIendCa' + ACichars(28)='ACaMaxCurvature' + ACichars(29)='CO2a_ACaMaxcurva' + ACichars(30)='PhiPSIIMaxCurvatCa' + ACichars(31)='CO2a_PhiPSIIMaxCur' + ACichars(32)='AveLeafTemp' + ACichars(33)='AvePAR' + ACichars(34)='AvepO2i' + + unitACichars(1)='NA' + unitACichars(2)='NA' + unitACichars(3)='Pa' + unitACichars(4)='umolm-2s-1Pa-1' + unitACichars(5)='umolm-2s-1' + unitACichars(6)='umolm-2s-1' + unitACichars(7)='umolm-2s-1Pa-1' + unitACichars(8)='umolm-2s-1Pa-1' + unitACichars(9)='NA' + unitACichars(10)='NA' + unitACichars(11)='Pa-1' + unitACichars(12)='Pa-1' + unitACichars(13)='X1000' + unitACichars(14)='Pa' + unitACichars(15)='X1000' + unitACichars(16)='Pa' + unitACichars(17)='Pa' + unitACichars(18)='umolm-2s-1Pa-1' + unitACichars(19)='umolm-2s-1' + unitACichars(20)='umolm-2s-1' + unitACichars(21)='umolm-2s-1Pa-1' + unitACichars(22)='umolm-2s-1Pa-1' + unitACichars(23)='umolm-2s-1' + unitACichars(24)='NA' + unitACichars(25)='NA' + unitACichars(26)='Pa-1' + unitACichars(27)='Pa-1' + unitACichars(28)='X1000' + unitACichars(29)='Pa' + unitACichars(30)='X1000' + unitACichars(31)='Pa' + unitACichars(32)='oC' + unitACichars(33)='umolm-2s-1' + unitACichars(34)='Pa' + if(isitmassbased.eq.1)then + unitACichars(4)='umolkg-1s-1Pa-1' + unitACichars(5)='umolkg-1s-1' + unitACichars(6)='umolkg-1s-1' + unitACichars(7)='umolkg-1s-1Pa-1' + unitACichars(8)='umolkg-1s-1Pa-1' + unitACichars(18)='umolkg-1s-1Pa-1' + unitACichars(19)='umolkg-1s-1' + unitACichars(20)='umolkg-1s-1' + unitACichars(21)='umolkg-1s-1Pa-1' + unitACichars(22)='umolkg-1s-1Pa-1' + unitACichars(23)='umolkg-1s-1' + unitACichars(33)='umolkg-1s-1' + endif + + ALightchars(1)='CurveID' + ALightchars(2)='ALightcurveNo' + ALightchars(3)='PARatZeroAnet' + ALightchars(4)='der_atPAR' + ALightchars(5)='Asat_ALight' + ALightchars(6)='ALightIntercept' + ALightchars(7)='der_atIntercept' + ALightchars(8)='der_atPARend' + ALightchars(9)='PhiPSIILightIntercept' + ALightchars(10)='der_atIntercept' + ALightchars(11)='ExcessLightFactor' + ALightchars(12)='der_atPAR1000' + ALightchars(13)='ALightMaxCurvature' + ALightchars(14)='PAR_MaxCurvature' + ALightchars(15)='PhiPSIIALightMaxCur' + ALightchars(16)='PAR_PhiPSIIMaxCurva' + ALightchars(17)='AveLeafTemp' + ALightchars(18)='AvepCO2ambient' + ALightchars(19)='AvepO2i' + + unitALightchars(1)='NA' + unitALightchars(2)='NA' + unitALightchars(3)='umolm-2s-1' + unitALightchars(4)='umol/umol' + unitALightchars(5)='umolm-2s-1' + unitALightchars(6)='umolm-2s-1' + unitALightchars(7)='umol/umol' + unitALightchars(8)='umol/umol' + unitALightchars(9)='NA' + unitALightchars(10)='umol-1m2s' + unitALightchars(11)='NA' + unitALightchars(12)='umol-1m2s' + unitALightchars(13)='X1000' + unitALightchars(14)='umolm-2s-1' + unitALightchars(15)='X1000' + unitALightchars(16)='umolm-2s-1' + unitALightchars(17)='oC' + unitALightchars(18)='Pa' + unitALightchars(19)='Pa' + if(isitmassbased.eq.1)then + unitALightchars(3)='umolkg-1s-1' + unitALightchars(5)='umolkg-1s-1' + unitALightchars(6)='umolkg-1s-1' + unitALightchars(10)='umol-1kgs' + unitALightchars(12)='umol-1kgs' + unitALightchars(14)='umolkg-1s-1' + unitALightchars(16)='umolkg-1s-1' + endif + + univcomvars(1)='CurveID' + univcomvars(2)='FitRwp|Rch|ha?' + univcomvars(3)='Fitha_Vcmax|Jmax|Tpu?' + univcomvars(4)='FitGamma*|ha?' + univcomvars(5)='FitKc|ha?' + univcomvars(6)='FitKo|ha?' + univcomvars(7)='FitRd|ha?' + univcomvars(8)='FitAlpha?' + univcomvars(9)='FitbetaPSII?' + univcomvars(10)='CO2i_obs' + univcomvars(11)='CO2i_Pred' + univcomvars(12)='CO2c' + univcomvars(13)='Anet_Obs' + univcomvars(14)='Anet_Pred' + univcomvars(15)='LimitState' + univcomvars(16)='RecycRate' + univcomvars(17)='CO2S' + univcomvars(18)='Pres_O2' + univcomvars(19)='Pres_H2O' + univcomvars(20)='Pres_Air' + univcomvars(21)='VPDL' + univcomvars(22)='PARi' + univcomvars(23)='LeafTemp' + univcomvars(24)='ChamberAirTemp' + univcomvars(25)='Trmmol' + univcomvars(26)='StomatalCond_H2O' + univcomvars(27)='ChlFlPHIPSII_Obs' + univcomvars(28)='ChlFlPHIPSII_Pred' + univcomvars(29)='CO2i_Pred_ChlFl' + univcomvars(30)='Anet_Pred_ChlFl' + univcomvars(31)='CO2c_CO2i_ChlFl' + univcomvars(32)='CO2c_Anet_ChlFl' + + univcomvars(33)='fo_pam' + univcomvars(34)='fm_pam' + univcomvars(35)='fs_pam' + univcomvars(36)='pam_measlight' + univcomvars(37)='yield_ps2' + univcomvars(38)='yield_npq' + univcomvars(39)='qlake' + univcomvars(40)='qpuddle' + univcomvars(41)='kps2_norm' + univcomvars(42)='knpq_norm' + + unitunivcomvars(1)='NA' + unitunivcomvars(2)='1=No2=Yes' + unitunivcomvars(3)='1=No2=Yes' + unitunivcomvars(4)='1=No2=Yes' + unitunivcomvars(5)='1=No2=Yes' + unitunivcomvars(6)='1=No2=Yes' + unitunivcomvars(7)='1=No2=Yes' + unitunivcomvars(8)='1=No2=Yes' + unitunivcomvars(9)='1=No2=Yes' + unitunivcomvars(10)='Pa' + unitunivcomvars(11)='Pa' + unitunivcomvars(12)='Pa' + unitunivcomvars(13)='umolm-2s-1' + unitunivcomvars(14)='umolm-2s-1' + unitunivcomvars(15)='Rubis1RUBP2TPU3' + unitunivcomvars(16)='%' + unitunivcomvars(17)='Pa' + unitunivcomvars(18)='KPa' + unitunivcomvars(19)='KPa' + unitunivcomvars(20)='KPa' + unitunivcomvars(21)='KPa' + unitunivcomvars(22)='umolm-2s-1' + unitunivcomvars(23)='oC' + unitunivcomvars(24)='oC' + unitunivcomvars(25)='mmolm-2s-1' + unitunivcomvars(26)='molm-2s-1' + unitunivcomvars(27)='NA' + unitunivcomvars(28)='NA' + unitunivcomvars(29)='Pa' + unitunivcomvars(30)='umolm-2s-1' + unitunivcomvars(31)='Pa' + unitunivcomvars(32)='Pa' + + unitunivcomvars(33)='ArbitUnit' + unitunivcomvars(34)='ArbitUnit' + unitunivcomvars(35)='ArbitUnit' + unitunivcomvars(36)='umolm-2s-1' + unitunivcomvars(37)='0-1' + unitunivcomvars(38)='0-1' + unitunivcomvars(39)='0-1' + unitunivcomvars(40)='0-1' + unitunivcomvars(41)='kps2/(kf+kd)' + unitunivcomvars(42)='knpq/(kf+fd)' + + if(isitmassbased.eq.1)then + unitunivcomvars(13)='umolkg-1s-1' + unitunivcomvars(14)='umolkg-1s-1' + unitunivcomvars(22)='umolkg-1s-1' + unitunivcomvars(25)='mmolkg-1s-1' + unitunivcomvars(26)='molkg-1s-1' + unitunivcomvars(30)='molkg-1s-1' + unitunivcomvars(36)='umolkg-1s-1' + endif + + write(compareunit,'(1000A)')(trim(univcomvars(i)),',', + &i=1,31),trim(univcomvars(32)) + write(compareunit,'(1000A)')(trim(unitunivcomvars(i)), + &',',i=1,31),trim(unitunivcomvars(32)) + + paramsvar(0)='LimitState' + paramsvar(1)='Vcmax25' + paramsvar(2)='Jmax25' + paramsvar(3)='Rdlight25' + paramsvar(4)='Resistwp25' + paramsvar(5)='Resistch25' + paramsvar(6)='tpu25' + paramsvar(7)='gamma*25' + paramsvar(8)='fkc25' + paramsvar(9)='fko25' + paramsvar(10)='alpha' + paramsvar(11)='ha_vcmax' + paramsvar(12)='hd_vcmax' + paramsvar(13)='sv_vcmax' + paramsvar(14)='ha_jmax' + paramsvar(15)='hd_jmax' + paramsvar(16)='sv_jmax' + paramsvar(17)='ha_tpu' + paramsvar(18)='hd_tpu' + paramsvar(19)='sv_tpu' + paramsvar(20)='ha_gmeso' + paramsvar(21)='hd_gmeso' + paramsvar(22)='sv_gmeso' + paramsvar(23)='ha_darkresp' + paramsvar(24)='ha_stargamma' + paramsvar(25)='ha_kc' + paramsvar(26)='ha_ko' + paramsvar(27)='phifactor' + paramsvar(28)='thetafactor' + paramsvar(29)='betaPSII' + paramsvar(30)='numrubisco' + paramsvar(31)='numrubp' + paramsvar(32)='numtpu' + paramsvar(33)='NumSamplePoints' + paramsvar(34)='SumSquare' + paramsvar(35)='Rdlight' + paramsvar(36)='Resistwp' + paramsvar(37)='Resistch' + paramsvar(38)='gamma*' + paramsvar(39)='co2iRubismax25' + paramsvar(40)='co2iRuBpmax25' + paramsvar(41)='anetRubismax25' + paramsvar(42)='anetRuBpmax25' + + unitparamsvar(0)='Occurrence' + unitparamsvar(1)='umolm-2s-1' + unitparamsvar(2)='umolm-2s-1' + unitparamsvar(3)='umolm-2s-1' + unitparamsvar(4)='Pasm2umol-1' + unitparamsvar(5)='Pasm2umol-1' + unitparamsvar(6)='umolm-2s-1' + unitparamsvar(7)='Pa' + unitparamsvar(8)='Pa' + unitparamsvar(9)='Pa' + unitparamsvar(10)='0_1' + unitparamsvar(11)='kJmol-1' + unitparamsvar(12)='kJmol-1' + unitparamsvar(13)='KJmol-1K-1' + unitparamsvar(14)='kJmol-1' + unitparamsvar(15)='kJmol-1' + unitparamsvar(16)='KJmol-1K-1' + unitparamsvar(17)='kJmol-1' + unitparamsvar(18)='kJmol-1' + unitparamsvar(19)='KJmol-1K-1' + unitparamsvar(20)='kJmol-1' + unitparamsvar(21)='kJmol-1' + unitparamsvar(22)='KJmol-1K-1' + unitparamsvar(23)='kJmol-1' + unitparamsvar(24)='kJmol-1' + unitparamsvar(25)='kJmol-1' + unitparamsvar(26)='kJmol-1' + unitparamsvar(27)='NA' + unitparamsvar(28)='NA' + unitparamsvar(29)='NA' + unitparamsvar(30)='rubispoints' + unitparamsvar(31)='rubppoints' + unitparamsvar(32)='tpupoints' + unitparamsvar(33)='<=rubis+rubp+tpu' + unitparamsvar(34)='NA' + unitparamsvar(35)='umolm-2s-1' + unitparamsvar(36)='Pasm2umol-1' + unitparamsvar(37)='Pasm2umol-1' + unitparamsvar(38)='Pa' + unitparamsvar(39)='Pa' + unitparamsvar(40)='Pa' + unitparamsvar(41)='umolm-2s-1' + unitparamsvar(42)='umolm-2s-1' + + if(isitmassbased.eq.1)then + unitparamsvar(1)='umolkg-1s-1' + unitparamsvar(2)='umolkg-1s-1' + unitparamsvar(3)='umolkg-1s-1' + unitparamsvar(4)='Paskgumol-1' + unitparamsvar(5)='Paskgumol-1' + unitparamsvar(6)='umolkg-1s-1' + unitparamsvar(35)='umolkg-1s-1' + unitparamsvar(36)='Paskgumol-1' + unitparamsvar(37)='Paskgumol-1' + unitparamsvar(41)='umolkg-1s-1' + unitparamsvar(42)='umolkg-1s-1' + endif + + sitevars(1)='siteID' + sitevars(2)='Latitude' + sitevars(3)='Longitude' + sitevars(4)='Elevation' + sitevars(5)='yearsampled' + sitevars(6)='sampledoy' + sitevars(7)='GrowingSeasonStart' + sitevars(8)='GrowingSeasonEnd' + sitevars(9)='standage' + sitevars(10)='CanopyHeight' + sitevars(11)='LeafAreaIndex' + sitevars(12)='species' + sitevars(13)='avetimeresolution' + sitevars(14)='avetimesampled' + sitevars(15)='SampleHeight' + sitevars(16)='Needleage' + sitevars(17)='specificLAI' + sitevars(18)='nitrogencontent' + sitevars(19)='carboncontent' + sitevars(20)='phosphoruscontent' + sitevars(21)='woodporosity' + sitevars(22)='sapwooddensity' + sitevars(23)='leafratio' + + unitsitevars(1)='NA' + unitsitevars(2)='DegNorthPositive' + unitsitevars(3)='DegEastPositive' + unitsitevars(4)='m' + unitsitevars(5)='Year' + unitsitevars(6)='DayofYear' + unitsitevars(7)='DayofYear' + unitsitevars(8)='DayofYear' + unitsitevars(9)='years' + unitsitevars(10)='m' + unitsitevars(11)='m2m-2' + unitsitevars(12)='species' + unitsitevars(13)='minutes' + unitsitevars(14)='HourFraction' + unitsitevars(15)='m' + unitsitevars(16)='days' + unitsitevars(17)='cm2g-1' + unitsitevars(18)='%' + unitsitevars(19)='%' + unitsitevars(20)='%' + unitsitevars(21)='ring/diffuse' + unitsitevars(22)='g/cm3' + unitsitevars(23)='Unitless' + + write(paramunit,'(2000A)')(trim(univcomvars(i)),',',i=1,9), + &(trim(paramsvar(i)),',',i=0,34),(trim(paramsvar(i)),',',i=39,42), + &(trim(sitevars(i)),',',i=1,22),trim(sitevars(23)) + write(paramunit,'(2000A)')(trim(unitunivcomvars(i)),',',i=1,9), + &(trim(unitparamsvar(i)),',',i=0,34), + &(trim(unitparamsvar(i)),',',i=39,42), + &(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23)) + + write(fluorescenceunit,'(1000A)')trim(univcomvars(1)),',', + &(trim(univcomvars(i)),',',i=10,14), + &(trim(univcomvars(i)),',',i=17,27), + &(trim(paramsvar(i)),',',i=3,5),trim(paramsvar(7)),',', + &trim(paramsvar(29)),',',trim(paramsvar(34)),',', + &trim(paramsvar(23)),',',(trim(paramsvar(i)),',',i=36,37), + &trim(paramsvar(24)),',',(trim(univcomvars(i)),',',i=33,41), + &trim(univcomvars(42)) + write(fluorescenceunit,'(1000A)')trim(unitunivcomvars(1)),',', + &(trim(unitunivcomvars(i)),',',i=10,14), + &(trim(unitunivcomvars(i)),',',i=17,27), + &(trim(unitparamsvar(i)),',',i=3,5),trim(unitparamsvar(7)),',', + &trim(unitparamsvar(29)),',',trim(unitparamsvar(34)),',', + &trim(unitparamsvar(23)),',',(trim(unitparamsvar(i)),',',i=36,37), + &trim(unitparamsvar(24)),',',(trim(unitunivcomvars(i)),',', + &i=33,41),trim(unitunivcomvars(42)) + + cterm1='Flu.Anet.SumSqure' + cterm2='Flu.Electron.SumS' + write(fluoresparamunit,'(1000A)')trim(univcomvars(1)),',', + &trim(paramsvar(2)),',',trim(paramsvar(3)),',', + &trim(paramsvar(3)),'/0rch,',trim(paramsvar(4)),',', + &trim(paramsvar(4)),'/0rch,',trim(paramsvar(5)),',', + &trim(paramsvar(7)),',',trim(paramsvar(7)),'/0rch,', + &(trim(paramsvar(i)),',',i=27,29),trim(paramsvar(29)),'/0rch,', + &'fo_dark,fm_dark,resp_dark,temp_dark,',trim(cterm1),',', + &trim(cterm2) + write(fluoresparamunit,'(1000A)')trim(unitunivcomvars(1)),',', + &trim(unitparamsvar(2)),',',trim(unitparamsvar(3)),',', + &trim(unitparamsvar(3)),',',trim(unitparamsvar(4)),',', + &trim(unitparamsvar(4)),',',trim(unitparamsvar(5)),',', + &trim(unitparamsvar(7)),',',trim(unitparamsvar(7)),',', + &(trim(unitparamsvar(i)),',',i=27,29),trim(unitparamsvar(29)),',', + &'ArbitUnit,ArbitUnit,',trim(unitparamsvar(3)),',oC,', + &trim(cterm1),',',trim(cterm2) + + write(aciempfitunit,'(2000A)')(trim(ACichars(i)),',',i=1,34), + &(trim(sitevars(i)),',',i=1,22),trim(sitevars(23)) + write(aciempfitunit,'(2000A)')(trim(unitACichars(i)),',',i=1,34), + &(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23)) + + write(alightempfitunit,'(2000A)') + &(trim(ALightchars(i)),',',i=1,19), + &(trim(sitevars(i)),',',i=1,22),trim(sitevars(23)) + write(alightempfitunit,'(2000A)') + &(trim(unitALightchars(i)),',',i=1,19), + &(trim(unitsitevars(i)),',',i=1,22),trim(unitsitevars(23)) +!------------------------------------------------ +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ +!Stomatal conductance, water use efficiency and ci/ca + stomwuecica(1)='curveno' + stomwuecica(2)='curvename' + stomwuecica(3)='gswmeas_stom' + stomwuecica(4)='gswCO2sLin' + stomwuecica(5)='gswCO2iLin' + stomwuecica(6)='gswCO2iBall' + stomwuecica(7)='gswCO2sRay' + stomwuecica(8)='gswCO2iRay' + stomwuecica(9)='gswDewar' + stomwuecica(10)='CO2i' + stomwuecica(11)='CO2s' + stomwuecica(12)='RH' + stomwuecica(13)='gammas' + stomwuecica(14)='vpd_surf' + stomwuecica(15)='Pres_air' + stomwuecica(16)='Anet_Meas' + + unitstomwuecica(1)='NA' + unitstomwuecica(2)='NA' + unitstomwuecica(3)='molm-2s-1' + unitstomwuecica(4)='molm-2s-1' + unitstomwuecica(5)='molm-2s-1' + unitstomwuecica(6)='molm-2s-1' + unitstomwuecica(7)='molm-2s-1' + unitstomwuecica(8)='molm-2s-1' + unitstomwuecica(9)='molm-2s-1' + unitstomwuecica(10)='ppm' + unitstomwuecica(11)='ppm' + unitstomwuecica(12)='0-1' + unitstomwuecica(13)='ppm' + unitstomwuecica(14)='Pa' + unitstomwuecica(15)='Pa' + unitstomwuecica(16)='umolm-2s-1' + if(isitmassbased.eq.1)then + unitstomwuecica(3)='molkg-1s-1' + unitstomwuecica(4)='molkg-1s-1' + unitstomwuecica(5)='molkg-1s-1' + unitstomwuecica(6)='molkg-1s-1' + unitstomwuecica(7)='molkg-1s-1' + unitstomwuecica(8)='molkg-1s-1' + unitstomwuecica(9)='molkg-1s-1' + unitstomwuecica(16)='umolkg-1s-1' + endif + + write(stomcompunit,'(100A)')((trim(stomwuecica(i)),','), + &i=1,15),trim(stomwuecica(16)) + write(stomcompunit,'(100A)')((trim(unitstomwuecica(i)),','), + &i=1,15),trim(unitstomwuecica(16)) +!------------------------------------------------------------ + stomwuecica(1)='curveno' + stomwuecica(2)='curvename' + stomwuecica(3)='co2ambient' + stomwuecica(4)='vpdl' + stomwuecica(5)='WUEmeasured' + stomwuecica(6)='WUEmodeled' + stomwuecica(7)='cicameasured' + stomwuecica(8)='cicamodeled' + stomwuecica(9)='IntrinsicWUE' + stomwuecica(10)='IntWUEModel' + stomwuecica(11)='cccimeasured1' + stomwuecica(12)='cccimodeled1' + stomwuecica(13)='cccimeasured2' + stomwuecica(14)='cccimodeled2' + stomwuecica(15)='cccimeasured3' + stomwuecica(16)='cccimodeled3' + stomwuecica(17)='cccimeasured4' + stomwuecica(18)='cccimodeled4' + stomwuecica(19)='recycmeasured1' + stomwuecica(20)='recycmodeled1' + stomwuecica(21)='recycmeasured2' + stomwuecica(22)='recycmodeled2' + stomwuecica(23)='recycmeasured3' + stomwuecica(24)='recycmodeled3' + stomwuecica(25)='recycmeasured4' + stomwuecica(26)='recycmodeled4' + stomwuecica(27)='recycmeasured5' + stomwuecica(28)='recycmodeled5' + stomwuecica(29)='recycmeasured6' + stomwuecica(30)='recycmodeled6' + + unitstomwuecica(1)='NA' + unitstomwuecica(2)='NA' + unitstomwuecica(3)='ppm' + unitstomwuecica(4)='Pa' + unitstomwuecica(5)='umolmmol-1' + unitstomwuecica(6)='umolmmol-1' + unitstomwuecica(7)='NA' + unitstomwuecica(8)='NA' + unitstomwuecica(9)='umolmol-1' + unitstomwuecica(10)='umolmol-1' + unitstomwuecica(11)='NA' + unitstomwuecica(12)='NA' + unitstomwuecica(13)='NA' + unitstomwuecica(14)='NA' + unitstomwuecica(15)='NA' + unitstomwuecica(16)='NA' + unitstomwuecica(17)='NA' + unitstomwuecica(18)='NA' + unitstomwuecica(19)='NA' + unitstomwuecica(20)='NA' + unitstomwuecica(21)='NA' + unitstomwuecica(22)='NA' + unitstomwuecica(23)='NA' + unitstomwuecica(24)='NA' + unitstomwuecica(25)='NA' + unitstomwuecica(26)='NA' + unitstomwuecica(27)='NA' + unitstomwuecica(28)='NA' + unitstomwuecica(29)='NA' + unitstomwuecica(30)='NA' + + write(wuecicacompunit,'(200A)')((trim(stomwuecica(i)),','), + &i=1,29),trim(stomwuecica(30)) + write(wuecicacompunit,'(200A)')((trim(unitstomwuecica(i)),','), + &i=1,29),trim(stomwuecica(30)) + + stomwuecica(1)='curveno' + stomwuecica(2)='curvename' + stomwuecica(3)='TotPoints' + stomwuecica(4)='gswCO2ithresl' + stomwuecica(5)='CO2AmbCurrent' + stomwuecica(6)='vpdl_ref' + stomwuecica(7)='Ballg0CO2sLin' + stomwuecica(8)='BallmCO2sLin' + stomwuecica(9)='BallrsqsLin' + stomwuecica(10)='Ballg0CO2iLin' + stomwuecica(11)='BallmCO2iLin' + stomwuecica(12)='BallrsqiLin' + stomwuecica(13)='Ballg0CO2s' + stomwuecica(14)='BallmCO2s' + stomwuecica(15)='Ballrsqs' + stomwuecica(16)='Rayg0CO2s' + stomwuecica(17)='RaymCO2s' + stomwuecica(18)='Rayd0CO2s' + stomwuecica(19)='RayrsqCO2s' + stomwuecica(20)='Belindag0CO2s' + stomwuecica(21)='Belindag1CO2s' + stomwuecica(22)='Belindad0CO2s' + stomwuecica(23)='BelindarsqCO2s' + stomwuecica(24)='Dewarg0CO2i' + stomwuecica(25)='DewarmCO2i' + stomwuecica(26)='Deward0CO2i' + stomwuecica(27)='DewarrsqCO2i' + stomwuecica(28)='WUEref' + stomwuecica(29)='der_WUEref' + stomwuecica(30)='rsqwue' + stomwuecica(31)='wuefit1' + stomwuecica(32)='wuefit2' + stomwuecica(33)='wuefit3' + stomwuecica(34)='wuefit4' + stomwuecica(35)='wuefit5' + stomwuecica(36)='IntrWUEref' + stomwuecica(37)='Intrder_WUEref' + stomwuecica(38)='Intrrsqwue' + stomwuecica(39)='Intrwuefit1' + stomwuecica(40)='Intrwuefit2' + stomwuecica(41)='Intrwuefit3' + stomwuecica(42)='Intrwuefit4' + stomwuecica(43)='Intrwuefit5' + stomwuecica(44)='CiCa-1Ref' + stomwuecica(45)='der_CiCa-1Ref' + stomwuecica(46)='rsqCiCa-1' + stomwuecica(47)='CiCa-1Fit1' + stomwuecica(48)='CiCa-1Fit2' + stomwuecica(49)='CiCa-1Fit3' + stomwuecica(50)='CiCa-1Fit4' + stomwuecica(51)='CiCa-1Fit5' + stomwuecica(52)='MeanLfTemp' + stomwuecica(53)='MeanAirTemp' + stomwuecica(54)='MeanVPDL' + stomwuecica(55)='MeanPARi' + stomwuecica(56)='CcCi-1Ref' + stomwuecica(57)='der_CcCi-1Ref' + stomwuecica(58)='rsqCcCi-1' + stomwuecica(59)='CcCi-1Fit1' + stomwuecica(60)='CcCi-1Fit2' + stomwuecica(61)='CcCi-1Fit3' + stomwuecica(62)='CcCi-1Fit4' + stomwuecica(63)='CcCi-1Fit5' + stomwuecica(64)='CcCi-1Fit6' + stomwuecica(65)='CcCi-2Ref' + stomwuecica(66)='der_CcCi-2Ref' + stomwuecica(67)='rsqCcCi-2' + stomwuecica(68)='CcCi-2Fit1' + stomwuecica(69)='CcCi-2Fit2' + stomwuecica(70)='CcCi-2Fit3' + stomwuecica(71)='CcCi-2Fit4' + stomwuecica(72)='CcCi-2Fit5' + stomwuecica(73)='CcCi-2Fit6' + stomwuecica(74)='CcCi-3Ref' + stomwuecica(75)='der_CcCi-3Ref' + stomwuecica(76)='rsqCcCi-3' + stomwuecica(77)='CcCi-3Fit1' + stomwuecica(78)='CcCi-3Fit2' + stomwuecica(79)='CcCi-3Fit3' + stomwuecica(80)='CcCi-3Fit4' + stomwuecica(81)='CcCi-3Fit5' + stomwuecica(82)='CcCi-3Fit6' + stomwuecica(83)='CcCi-4Ref' + stomwuecica(84)='der_CcCi-4Ref' + stomwuecica(85)='rsqCcCi-4' + stomwuecica(86)='CcCi-4Fit1' + stomwuecica(87)='CcCi-4Fit2' + stomwuecica(88)='CcCi-4Fit3' + stomwuecica(89)='CcCi-4Fit4' + stomwuecica(90)='CcCi-4Fit5' + stomwuecica(91)='CcCi-4Fit6' + stomwuecica(92)='Recyc-1Ref' + stomwuecica(93)='der_Recyc-1Ref' + stomwuecica(94)='rsqRecyc-1' + stomwuecica(95)='Recyc-1Fit1' + stomwuecica(96)='Recyc-1Fit2' + stomwuecica(97)='Recyc-1Fit3' + stomwuecica(98)='Recyc-1Fit4' + stomwuecica(99)='Recyc-1Fit5' + stomwuecica(100)='Recyc-2Ref' + stomwuecica(101)='der_Recyc-2Ref' + stomwuecica(102)='rsqRecyc-2' + stomwuecica(103)='Recyc-2Fit1' + stomwuecica(104)='Recyc-2Fit2' + stomwuecica(105)='Recyc-2Fit3' + stomwuecica(106)='Recyc-2Fit4' + stomwuecica(107)='Recyc-2Fit5' + stomwuecica(108)='Recyc-3Ref' + stomwuecica(109)='der_Recyc-3Ref' + stomwuecica(110)='rsqRecyc-3' + stomwuecica(111)='Recyc-3Fit1' + stomwuecica(112)='Recyc-3Fit2' + stomwuecica(113)='Recyc-3Fit3' + stomwuecica(114)='Recyc-3Fit4' + stomwuecica(115)='Recyc-3Fit5' + stomwuecica(116)='Recyc-4Ref' + stomwuecica(117)='der_Recyc-4Ref' + stomwuecica(118)='rsqRecyc-4' + stomwuecica(119)='Recyc-4Fit1' + stomwuecica(120)='Recyc-4Fit2' + stomwuecica(121)='Recyc-4Fit3' + stomwuecica(122)='Recyc-4Fit4' + stomwuecica(123)='Recyc-4Fit5' + stomwuecica(124)='Recyc-5Ref' + stomwuecica(125)='der_Recyc-5Ref' + stomwuecica(126)='rsqRecyc-5' + stomwuecica(127)='Recyc-5Fit1' + stomwuecica(128)='Recyc-5Fit2' + stomwuecica(129)='Recyc-5Fit3' + stomwuecica(130)='Recyc-5Fit4' + stomwuecica(131)='Recyc-5Fit5' + stomwuecica(132)='Recyc-6Ref' + stomwuecica(133)='der_Recyc-6Ref' + stomwuecica(134)='rsqRecyc-6' + stomwuecica(135)='Recyc-6Fit1' + stomwuecica(136)='Recyc-6Fit2' + stomwuecica(137)='Recyc-6Fit3' + stomwuecica(138)='Recyc-6Fit4' + stomwuecica(139)='Recyc-6Fit5' + + unitstomwuecica(1)='NA' + unitstomwuecica(2)='NA' + unitstomwuecica(3)='NA' + unitstomwuecica(4)='ppm' + unitstomwuecica(5)='ppm' + unitstomwuecica(6)='PA' + unitstomwuecica(7)='molm-2s-1' + unitstomwuecica(8)='NA' + unitstomwuecica(9)='NA' + unitstomwuecica(10)='molm-2s-1' + unitstomwuecica(11)='NA' + unitstomwuecica(12)='NA' + unitstomwuecica(13)='molm-2s-1' + unitstomwuecica(14)='NA' + unitstomwuecica(15)='NA' + unitstomwuecica(16)='molm-2s-1' + unitstomwuecica(17)='NA' + unitstomwuecica(18)='Pa' + unitstomwuecica(19)='NA' + unitstomwuecica(20)='molm-2s-1' + unitstomwuecica(21)='(kPa)^0.5' + unitstomwuecica(22)='Pa' + unitstomwuecica(23)='NA' + unitstomwuecica(24)='molm-2s-1' + unitstomwuecica(25)='NA' + unitstomwuecica(26)='Pa' + unitstomwuecica(27)='NA' + unitstomwuecica(28)='umolmmol-1' + unitstomwuecica(29)='umolmmol-1ppm-1' + unitstomwuecica(30)='NA' + unitstomwuecica(31)='NA' + unitstomwuecica(32)='NA' + unitstomwuecica(33)='NA' + unitstomwuecica(34)='NA' + unitstomwuecica(35)='NA' + unitstomwuecica(36)='umolmol-1ppm-1' + unitstomwuecica(37)='umolmol-1ppm-1' + unitstomwuecica(38)='NA' + unitstomwuecica(39)='NA' + unitstomwuecica(40)='NA' + unitstomwuecica(41)='NA' + unitstomwuecica(42)='NA' + unitstomwuecica(43)='NA' + unitstomwuecica(44)='NA' + unitstomwuecica(45)='ppm-1' + unitstomwuecica(46)='NA' + unitstomwuecica(47)='NA' + unitstomwuecica(48)='NA' + unitstomwuecica(49)='NA' + unitstomwuecica(50)='NA' + unitstomwuecica(51)='NA' + unitstomwuecica(52)='oC' + unitstomwuecica(53)='oC' + unitstomwuecica(54)='Pa' + unitstomwuecica(55)='umolm-2s-1' + unitstomwuecica(56)='NA' + unitstomwuecica(57)='ppm-1' + unitstomwuecica(58)='NA' + unitstomwuecica(59)='NA' + unitstomwuecica(60)='NA' + unitstomwuecica(61)='NA' + unitstomwuecica(62)='NA' + unitstomwuecica(63)='NA' + unitstomwuecica(64)='NA' + unitstomwuecica(65)='NA' + unitstomwuecica(66)='ppm-1' + unitstomwuecica(67)='NA' + unitstomwuecica(68)='NA' + unitstomwuecica(69)='NA' + unitstomwuecica(70)='NA' + unitstomwuecica(71)='NA' + unitstomwuecica(72)='NA' + unitstomwuecica(73)='NA' + unitstomwuecica(74)='NA' + unitstomwuecica(75)='ppm-1' + unitstomwuecica(76)='NA' + unitstomwuecica(77)='NA' + unitstomwuecica(78)='NA' + unitstomwuecica(79)='NA' + unitstomwuecica(80)='NA' + unitstomwuecica(81)='NA' + unitstomwuecica(82)='NA' + unitstomwuecica(83)='NA' + unitstomwuecica(84)='ppm-1' + unitstomwuecica(85)='NA' + unitstomwuecica(86)='NA' + unitstomwuecica(87)='NA' + unitstomwuecica(88)='NA' + unitstomwuecica(89)='NA' + unitstomwuecica(90)='NA' + unitstomwuecica(91)='NA' + unitstomwuecica(92)='NA' + unitstomwuecica(93)='NA' + unitstomwuecica(94)='NA' + unitstomwuecica(95)='NA' + unitstomwuecica(96)='NA' + unitstomwuecica(97)='NA' + unitstomwuecica(98)='NA' + unitstomwuecica(99)='NA' + unitstomwuecica(100)='NA' + unitstomwuecica(101)='NA' + unitstomwuecica(102)='NA' + unitstomwuecica(103)='NA' + unitstomwuecica(104)='NA' + unitstomwuecica(105)='NA' + unitstomwuecica(106)='NA' + unitstomwuecica(107)='NA' + unitstomwuecica(108)='NA' + unitstomwuecica(109)='NA' + unitstomwuecica(110)='NA' + unitstomwuecica(111)='NA' + unitstomwuecica(112)='NA' + unitstomwuecica(113)='NA' + unitstomwuecica(114)='NA' + unitstomwuecica(115)='NA' + unitstomwuecica(116)='NA' + unitstomwuecica(117)='NA' + unitstomwuecica(118)='NA' + unitstomwuecica(119)='NA' + unitstomwuecica(120)='NA' + unitstomwuecica(121)='NA' + unitstomwuecica(122)='NA' + unitstomwuecica(123)='NA' + unitstomwuecica(124)='NA' + unitstomwuecica(125)='NA' + unitstomwuecica(126)='NA' + unitstomwuecica(127)='NA' + unitstomwuecica(128)='NA' + unitstomwuecica(129)='NA' + unitstomwuecica(130)='NA' + unitstomwuecica(131)='NA' + unitstomwuecica(132)='NA' + unitstomwuecica(133)='NA' + unitstomwuecica(134)='NA' + unitstomwuecica(135)='NA' + unitstomwuecica(136)='NA' + unitstomwuecica(137)='NA' + unitstomwuecica(138)='NA' + unitstomwuecica(139)='NA' + if(isitmassbased.eq.1)then + unitstomwuecica(7)='molkg-1s-1' + unitstomwuecica(10)='molkg-1s-1' + unitstomwuecica(13)='molkg-1s-1' + unitstomwuecica(16)='molkg-1s-1' + unitstomwuecica(20)='molkg-1s-1' + unitstomwuecica(24)='molkg-1s-1' + unitstomwuecica(55)='umolkg-1s-1' + endif + + write(stomwuecicaoutunit,'(2000A)')((trim(stomwuecica(i)),','), + &i=1,139),((trim(sitevars(i)),','),i=1,22),trim(sitevars(23)) + write(stomwuecicaoutunit,'(2000A)')((trim(unitstomwuecica(i)), + &','),i=1,139),((trim(unitsitevars(i)),','),i=1,22), + &trim(unitsitevars(23)) + return + end diff --git a/leafres/testarea/SetUpLeafGasFit.f b/leafres/testarea/SetUpLeafGasFit.f new file mode 100644 index 0000000..9496446 --- /dev/null +++ b/leafres/testarea/SetUpLeafGasFit.f @@ -0,0 +1,1796 @@ + subroutine SetUpLeafGasFit(icurveno_usr,curvename,ntotsamples0, + &CurveTypeID,anet_obs0,pco2i0,templeaf0,PARi0,pres_air0,po2i0, + &chlflphips20,pco2ambient0,trmmol0,gswmeas0,vpdl0,tempair0, + &eambient0,fo_pam0,fm_pam0,fs_pam0,pam_measlight0,stargamma25_usr, + &fkc25_usr,fko25_usr,rdlight25_usr,alpha25_usr,resistwp25_usr, + &resistch25_usr,isitmassbased,indexunit, + &siteID,Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,species,avetimeresolution,avetimesampled, + &SampleHeight,Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,woodporosity,sapwooddensity,leafratio) + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' +!--------------------Inputs-------------------------------------------------------------- +!None of the inputs is changed by this subroutine +!icurveno_usr(int): the curve number +!curvename(char): the curve name +!ntotsamples0: the total number of data points +!CurveTypeID =1-3: Any measurements where limitation states are known: +! =1 limited by Rubisco +! =2 limited by RuBp regeneration +! =3 limited by TPU +! =11-25: ACi Curves. Each different CurveTypeID number represents a different A/Ci curve (i.e., different PAR levels). +! For example, five different PAR levels are used to measure five A/Ci curves with PAR = 200, 400, 600, 800, +! 1000.Use 11, 12, 13, 14, 15 to indentify points of each curve. Maxumum 15 A/Ci curves. +! The curves must be numbered consecutively. +! =31-45: ALight Curves. Each different CurveTypeID number represents a different A/Light curve (i.e., different ambient CO2 levels). +! For example, five different ambient levels are used to measure five A/Light curves with CO2a= 100, 200, 300, 400, 500. +! Use 31, 32, 33, 34, 35 to indentify points of each ALight curve. The curves must be ordered consecutively. +! =-9999: all other types of measurements. +!anet_obs0: Net photosynthetic rate (umol m-2 s-1) +!pco2i0: Intercellular CO2 concentration (Pa) +!templeaf0: leaf temperature (K) +!PARi0: The PAR level inside the chamber to which photosynthesis responds (umolm-2s-1) +!pres_air0: Atmospheric pressure (Pa) +!po2i0: Oxygen partial presssure (Pa) +!chlflphips20: Chlorophyll fluorescence (NA), that is, DeltaF/Fm, the fraction of +! absorbed PSII photons that are used in photochemistry +!pco2ambient0: Ambient CO2 partial pressure (Pa) +!trmmol0: Transpiration rate (mmolm-2s-1) +!gswmeas0: Stomatal conductance for water vapor (molm-2s-1) +!vpdl0: Water vapor pressure difference between the leaf and chamber air (Pa) +!tempair0: Air temperature inside the chamber (K) +!eambient0: Water vapor pressure inside the chamber (Pa). +!fo_pam0: fo (dark adapated) or fo' (actinic light turned off, far red light on to drain electrons from PSII) from pulse amplitude modulation (arbitrary unit). +!fm_pam0: fm (dark adapated with saturation pulse) or fm' (actinic light with saturation pulse) from pulse amplitude modulation (arbitrary unit). +!fs_pam0: steady state fluorescence from pulse amplitude modulation (arbitrary unit). +!pam_measlight0: the measuring light level (umolm-2s-1) +!stargamma25_usr: Chloroplastic CO2 compenstation point at 25oC provided by the user (Pa), set to -9999 if not available +!fkc25_usr: the Michaelis constant for CO2 at 25oC provided by the user (Pa), set to -9999 if not available +!fko25_usr: the Michaelis constant for O2 at 25oC provided by the user (Pa), set to -9999 if not available +!rdlight25_usr: Leaf dark respiration at 25oC provided by user (Pa), set to -9999 if not available +!alpha25_usr: The fraction of glycolate carbon not returned to the chloroplast at 25oC provided by user (NA), set to -9999 if not available +!resistwp25_usr: resistance to CO2 via cell walls and plasmalemma provided by user [umol-1msPa], set to -9999 if not available +!resistch25_usr: resistance to CO2 via chloroplastic envelope provided by user[umol-1msPa], set to -9999 if not available +!isitmassbased: = 0, area-based (typical) +! = 1. mass-based (atypical) +!paramunit: file unit number to write ouputs +!compareunit: file unit number to write ouputs +!stomwuecicaoutunit: file unit number to write ouputs +!wuecicacompunit: file unit number to write ouputs +!stomcompunit: file unit number to write ouputs +!fluorescenceunit: file unit number to write outputs for comparison from fluorescence fit +!fluoresparamunit: file unit number to write parameters from fluorescence fit +!General information,not used but recorded in the output files +! & siteID,Latitude,Longitude,Elevation,yearsampled, +! & sampledoy,GrowingSeasonStart,GrowingSeasonEnd, +! & standage,CanopyHeight,LeafAreaIndex,species, +! & avetimeresolution,avetimesampled,SampleHeight, +! & Needleage,specificLAI,nitrogencontent,carboncontent, +! & phoscontent,woodporosity,sapwooddensity,leafratio) + integer icurveno_usr,ntotsamples0,isitmassbased,indexunit(20) + character*100 curvename + character siteID*(*),species*(*),woodporosity*(*) + double precision CurveTypeID(ntotsamples0), + &anet_obs0(ntotsamples0),pco2i0(ntotsamples0), + &templeaf0(ntotsamples0),PARi0(ntotsamples0), + &pres_air0(ntotsamples0),po2i0(ntotsamples0), + &chlflphips20(ntotsamples0),pco2ambient0(ntotsamples0), + &trmmol0(ntotsamples0),gswmeas0(ntotsamples0),vpdl0(ntotsamples0), + &tempair0(ntotsamples0),eambient0(ntotsamples0), + &fo_pam0(ntotsamples0),fm_pam0(ntotsamples0), + &fs_pam0(ntotsamples0),pam_measlight0(ntotsamples0), + &stargamma25_usr,fkc25_usr,fko25_usr, + &rdlight25_usr,alpha25_usr,resistwp25_usr,resistch25_usr, +!General information,not used but recorded in the output files + &Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,avetimeresolution,avetimesampled,SampleHeight, + &Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,sapwooddensity,leafratio +!------------------------------------------------------------------------------------------ + character*30 modeltype,fourchars(20) + dimension modeltype(0:10) + + integer i,j,k,m,n,idorwp0,idorch0,irchoption1,irchoption2,i2ndary, + &numrubis,numrubp,numtpu,INFO,iderivative,idoalpha0, + &ioriorder(3*ntotsamples0),ibelong(3*ntotsamples0),ACiID(15), + &ALightID(15),paramunit,compareunit,stomwuecicaoutunit, + &stomcompunit,wuecicacompunit,fluorescenceunit, + &fluoresparamunit,aciempfitunit,alightempfitunit,idotempcoeff, + &idomeso,idohavjt + + double precision vcmax25_ini,fjmax25_ini,tpu25_ini,rdlight25_ini, + &stargamma25_ini,fkc25_ini,fko25_ini,alpha25_ini,resistwp25_ini, + &resistch25_ini,resiststomco20(ntotsamples0),term,term1,term2, + &aPPFDlf0(ntotsamples0),weitx(ntotsamples0),xmin(ntotsamples0), + &xmax(ntotsamples0),weity(ntotsamples0),beta(20),starco2i(15), + &der_starco2i(15),Amax_ACi(15),ACiinter(15),der_ACiinter(15), + &der_ACiend(15),starPAR(15),der_starPAR(15),Asat_ALight(15), + &ALightinter(15),der_ALightinter(15),der_ALightend(15), + &PhiPSIIzero_ACi(15),der_PhiPSIIzero_ACi(15),PhiPSIImax_ACi(15), + &PhiPSIIinter_ACi(15),der_PhiPSIIinter_ACi(15), + &der_PhiPSIIend_ACi(15),ExcessLightFactor(15), + &der_PhiPSII1000_ALight(15),PhiPSIIinter_ALight(15), + &der_PhiPSIIinter_ALight(15),amaxave,recycleratio(6,ntotsamples0), + &stargamma25fit(6),ACiavetempleaf(15),ACiaveaPPFDlf(15), + &ACiavepo2i(15),ALightavetempleaf(15),ALightaveCO2ambient(15), + &ALightavepo2i(15),co2c_Pa(4,ntotsamples0),co2imany(500), + &critdelPAR,critdelCi_Pa,rdlight,atp,resistwp,resistch,stargamma, + &ccc,ccj,cct,ac,aj,at,phifactor_ini,thetafactor_ini,betaPSII_ini, + &realizedfjelect,xvector(ntotsamples0),yvector(ntotsamples0), + &fvector(ntotsamples0),gvector(ntotsamples0),hvector(ntotsamples0), + &zvector(ntotsamples0),wvector(ntotsamples0),uvector(ntotsamples0), + &fo_dark,fm_dark,resp_dark,tempK_dark,ACimaxcurvature(15), + &ACimaxcurvpco2i(15),PhiPSIImaxcurvature_ACi(15), + &PhiPSIImaxcurv_ACi(15),ALightmaxcurvature(15), + &ALightmaxcurvPAR(15),PhiPSIImaxcurvature_ALight(15), + &PhiPSIImaxcurv_ALight(15),co2iRubismax25,co2iRuBpmax25, + &anetRubismax25,anetRuBpmax25,starco2a(15),der_starco2a(15), + &Amax_ACa(15),ACainter(15),der_ACainter(15),der_ACa400ppm(15), + &anet_ACa400ppm(15),PhiPSIImax_ACa(15),PhiPSIIinter_ACa(15), + &der_PhiPSIIinter_ACa(15),der_PhiPSIIend_ACa(15), + &ACamaxcurvature(15),ACamaxcurvpco2a(15), + &PhiPSIImaxcurvature_ACa(15),PhiPSIImaxcurv_ACa(15), + &PhiPSIIzero_ACa(15),der_PhiPSIIzero_ACa(15),ha_darkresp_ini, + &ha_stargamma_ini,ha_vcmax_ini,ha_jmax_ini,ha_tpu_ini,ha_gmeso_ini + parameter(critdelPAR=-2.0d0,critdelCi_Pa=-2.0d0) +!use positive critdelCi_Pa and critdelPAR to indicate absolute distance +!use negative critdelCi_Pa and critdelPAR to indicate relative distance (percentage value) +!End of declaration======================================================================= + paramunit=indexunit(1) + compareunit=indexunit(2) + stomwuecicaoutunit=indexunit(3) + stomcompunit=indexunit(4) + wuecicacompunit=indexunit(5) + fluorescenceunit=indexunit(6) + fluoresparamunit=indexunit(7) + aciempfitunit=indexunit(8) + alightempfitunit=indexunit(9) +!----------------------------------------------------------------------------------------- + call commonparameters(stargamma25_ini,fkc25_ini,fko25_ini, + &alpha25_ini,ha_vcmax_ini,hd_vcmax,sv_vcmax,ha_jmax_ini,hd_jmax, + &sv_jmax,ha_tpu_ini,hd_tpu,sv_tpu,ha_gmeso_ini,hd_gmeso,sv_gmeso, + &ha_darkresp_ini,ha_stargamma_ini,ha_kc,ha_ko,abspt_lf_par, + &gascon,phifactor_ini,thetafactor_ini,betaPSII_ini) + ha_darkresp=ha_darkresp_ini + ha_stargamma=ha_stargamma_ini + ha_vcmax=ha_vcmax_ini + ha_jmax=ha_jmax_ini + ha_tpu=ha_tpu_ini + ha_gmeso=ha_gmeso_ini + call pam_parameters(ntotsamples0,fo_pam0,fm_pam0,fs_pam0, + &pam_measlight0,anet_obs0,PARi0,templeaf0,yield_ps2,yield_npq, + &qlake,qpuddle,kps2_norm,knpq_norm,fo_dark,fm_dark,resp_dark, + &tempK_dark) + j=0 + do i=1,ntotsamples0 +!this is needed because the calling routine passes any data that have valid PAM measurements. + k=0 + if(dabs(anet_obs0(i)+9999.0d0).lt.0.01d0)k=1 + if(dabs(pco2i0(i)+9999.0d0).lt.0.01d0)k=1 + if(dabs(templeaf0(i)+9999.0d0).lt.0.01d0)k=1 + if(k.eq.0)then + j=j+1 + anet_obs0(j)=anet_obs0(i) + pco2i0(j)=pco2i0(i) + templeaf0(j)=templeaf0(i) + PARi0(j)=PARi0(i) + pres_air0(j)=pres_air0(i) + po2i0(j)=po2i0(i) + chlflphips20(j)=chlflphips20(i) + pco2ambient0(j)=pco2ambient0(i) + trmmol0(j)=trmmol0(i) + gswmeas0(j)=gswmeas0(i) + vpdl0(j)=vpdl0(i) + tempair0(j)=tempair0(i) + eambient0(j)=eambient0(i) +! + fo_pam0(j)=fo_pam0(i) + fm_pam0(j)=fm_pam0(i) + fs_pam0(j)=fs_pam0(i) + pam_measlight0(j)=pam_measlight0(i) + yield_ps2(j)=yield_ps2(i) + yield_npq(j)=yield_npq(i) + qlake(j)=qlake(i) + qpuddle(j)=qpuddle(i) + kps2_norm(j)=kps2_norm(i) + knpq_norm(j)=knpq_norm(i) + endif + enddo + ntotsamples0=j +! + vcmax25_ini=50.0d0 + fjmax25_ini=1.1d0*vcmax25_ini + tpu25_ini=0.07d0*fjmax25_ini + rdlight25_ini=0.015d0*vcmax25_ini + if(resp_dark.gt.0.0d0)then +!data contain dark-adapted rd + call resp_mitocho(tempK_dark,1.0d0,ha_darkresp,gascon,term) + rdlight25_ini=resp_dark/term + if(rdlight25_usr.le.0.0d0)rdlight25_usr=rdlight25_ini + endif + resistwp25_ini=0.1d0 + resistch25_ini=0.1d0 + resistwp25max=100.0d0 + resistwp25min=0.0d0 + resistch25max=100.0d0 + resistch25min=0.0d0 + rdlight25max=10.d0 + rdlight25min=1.0d-7 + stargamma25max=10.0d0 + stargamma25min=1.0d-7 + vcmax25max=700.0d0 + vcmax25min=0.0d0 + fkc25max=100.0d0 + fkc25min=5.0d0 + fko25max=20000.0d0 + fko25min=10000.0d0 + fjmax25max=800.0d0 + fjmax25min=0.0d0 + tpu25max=20.0d0 + tpu25min=0.0d0 + alpha25max=10.0d0 + alpha25min=0.0d0 + alpha25_ini=0.001d0 + phifactormin=1.0d-5 + phifactormax=2.0d0 + thetafactormin=1.0d-5 + thetafactormax=1.2d0 + betaPSIImin=0.0d0 + betaPSIImax=1.0d0 + if(ha_darkresp.gt.0.0d0)then + ha_darkrespmin=5.0d0 + ha_darkrespmax=200.0d0 + else +!-Q10 + ha_darkrespmin=-200.0d0 + ha_darkrespmax=0.0d0 + endif + ha_stargammamin=5.0d0 + ha_stargammamax=200.0d0 + ha_vcmaxmin=40.0d0 + ha_vcmaxmax=100.0d0 + ha_jmaxmin=20.0d0 + ha_jmaxmax=100.0d0 + ha_tpumin=20.0d0 + ha_tpumax=100.0d0 + ha_gmesomin=20.0d0 + ha_gmesomax=100.0d0 + if(isitmassbased.eq.1)then + vcmax25max=2000.0d0 + fjmax25max=2000.0d0 + tpu25max=100.0d0 + rdlight25max=30.d0 + endif + nFixedPoints=0 + numACicurves=0 + numALightcurves=0 + nFreePoints=0 + do i=1,ntotsamples0 + aPPFDlf0(i)=PARi0(i)*abspt_lf_par + if(gswmeas0(i).gt.0.0d0)then + resiststomco20(i)=1.6d0/gswmeas0(i) +!unit is 1/(mol/m2/s). Now we need to change it to 1.0d0/(umol/m2/s/Pa) + resiststomco20(i)=resiststomco20(i)*pres_air0(i)*1.0d-6 + else + resiststomco20(i)=-9999.0d0 + endif + j=idnint(CurveTypeID(i)+0.1d0) + if(j.eq.1.or.j.eq.2.or.j.eq.3)then +!points whose limitation states are known. + nFixedPoints=nFixedPoints+1 + Fixedanet_obs(nFixedPoints)=anet_obs0(i) + Fixedpco2i(nFixedPoints)=pco2i0(i) + Fixedtempleaf(nFixedPoints)=templeaf0(i) + FixedaPPFDlf(nFixedPoints)=aPPFDlf0(i) + Fixedpres_air(nFixedPoints)=pres_air0(i) + Fixedpo2i(nFixedPoints)=po2i0(i) + Fixedchlflphips2(nFixedPoints)=chlflphips20(i) + Fixedpco2ambient(nFixedPoints)=pco2ambient0(i) + Fixedtrmmol(nFixedPoints)=trmmol0(i) + Fixedgswmeas(nFixedPoints)=gswmeas0(i) + Fixedvpdl(nFixedPoints)=vpdl0(i) + Fixedtempair(nFixedPoints)=tempair0(i) + Fixedeambient(nFixedPoints)=eambient0(i) +! + Fixedfo_pam(nFixedPoints)=fo_pam0(i) + Fixedfm_pam(nFixedPoints)=fm_pam0(i) + Fixedfs_pam(nFixedPoints)=fs_pam0(i) + Fixedpam_measlight(nFixedPoints)=pam_measlight0(i) + Fixedyield_ps2(nFixedPoints)=yield_ps2(i) + Fixedyield_npq(nFixedPoints)=yield_npq(i) + Fixedqlake(nFixedPoints)=qlake(i) + Fixedqpuddle(nFixedPoints)=qpuddle(i) + Fixedkps2_norm(nFixedPoints)=kps2_norm(i) + Fixedknpq_norm(nFixedPoints)=knpq_norm(i) +! + Fixedresiststomco2(nFixedPoints)=resiststomco20(i) + Prioriphotolimit(nFixedPoints)=j + else + if(j.ge.11.and.j.le.25)then +!A/Ci curves without knowing limitation states of points. + m=0 + do k=1,numACicurves + if(j.eq.ACiID(k))then + nACiPoints(k)=nACiPoints(k)+1 + ACianet_obs0(nACiPoints(k),k)=anet_obs0(i) + ACipco2i0(nACiPoints(k),k)=pco2i0(i) + ACitempleaf0(nACiPoints(k),k)=templeaf0(i) + ACiaPPFDlf0(nACiPoints(k),k)=aPPFDlf0(i) + ACipres_air0(nACiPoints(k),k)=pres_air0(i) + ACipo2i0(nACiPoints(k),k)=po2i0(i) + ACichlflphips20(nACiPoints(k),k)=chlflphips20(i) + ACipco2ambient0(nACiPoints(k),k)=pco2ambient0(i) + ACitrmmol0(nACiPoints(k),k)=trmmol0(i) + ACigswmeas0(nACiPoints(k),k)=gswmeas0(i) + ACivpdl0(nACiPoints(k),k)=vpdl0(i) + ACitempair0(nACiPoints(k),k)=tempair0(i) + ACieambient0(nACiPoints(k),k)=eambient0(i) +! + ACifo_pam0(nACiPoints(k),k)=fo_pam0(i) + ACifm_pam0(nACiPoints(k),k)=fm_pam0(i) + ACifs_pam0(nACiPoints(k),k)=fs_pam0(i) + ACipam_measlight0(nACiPoints(k),k)=pam_measlight0(i) + ACiyield_ps20(nACiPoints(k),k)=yield_ps2(i) + ACiyield_npq0(nACiPoints(k),k)=yield_npq(i) + ACiqlake0(nACiPoints(k),k)=qlake(i) + ACiqpuddle0(nACiPoints(k),k)=qpuddle(i) + ACikps2_norm0(nACiPoints(k),k)=kps2_norm(i) + ACiknpq_norm0(nACiPoints(k),k)=knpq_norm(i) +! + ACiresiststomco20(nACiPoints(k),k)=resiststomco20(i) + m=1 + endif + enddo + if(m.eq.0)then +!A new ACi curve + numACicurves=numACicurves+1 + nACiPoints(numACicurves)=1 + ACiID(numACicurves)=j + ACianet_obs0(1,numACicurves)=anet_obs0(i) + ACipco2i0(1,numACicurves)=pco2i0(i) + ACitempleaf0(1,numACicurves)=templeaf0(i) + ACiaPPFDlf0(1,numACicurves)=aPPFDlf0(i) + ACipres_air0(1,numACicurves)=pres_air0(i) + ACipo2i0(1,numACicurves)=po2i0(i) + ACichlflphips20(1,numACicurves)=chlflphips20(i) + ACipco2ambient0(1,numACicurves)=pco2ambient0(i) + ACitrmmol0(1,numACicurves)=trmmol0(i) + ACigswmeas0(1,numACicurves)=gswmeas0(i) + ACivpdl0(1,numACicurves)=vpdl0(i) + ACitempair0(1,numACicurves)=tempair0(i) + ACieambient0(1,numACicurves)=eambient0(i) +! + ACifo_pam0(1,numACicurves)=fo_pam0(i) + ACifm_pam0(1,numACicurves)=fm_pam0(i) + ACifs_pam0(1,numACicurves)=fs_pam0(i) + ACipam_measlight0(1,numACicurves)=pam_measlight0(i) + ACiyield_ps20(1,numACicurves)=yield_ps2(i) + ACiyield_npq0(1,numACicurves)=yield_npq(i) + ACiqlake0(1,numACicurves)=qlake(i) + ACiqpuddle0(1,numACicurves)=qpuddle(i) + ACikps2_norm0(1,numACicurves)=kps2_norm(i) + ACiknpq_norm0(1,numACicurves)=knpq_norm(i) +! + ACiresiststomco20(1,numACicurves)=resiststomco20(i) + endif + else + if(j.ge.31.and.j.le.45)then +!A/Light curves without knowing limitation states of points. + m=0 + do k=1,numALightcurves + if(j.eq.ALightID(k))then + nALightPoints(k)=nALightPoints(k)+1 + ALightanet_obs0(nALightPoints(k),k)=anet_obs0(i) + ALightpco2i0(nALightPoints(k),k)=pco2i0(i) + ALighttempleaf0(nALightPoints(k),k)=templeaf0(i) + ALightaPPFDlf0(nALightPoints(k),k)=aPPFDlf0(i) + ALightpres_air0(nALightPoints(k),k)=pres_air0(i) + ALightpo2i0(nALightPoints(k),k)=po2i0(i) + ALightchlflphips20(nALightPoints(k),k)=chlflphips20(i) + ALightpco2ambient0(nALightPoints(k),k)=pco2ambient0(i) + ALighttrmmol0(nALightPoints(k),k)=trmmol0(i) + ALightgswmeas0(nALightPoints(k),k)=gswmeas0(i) + ALightvpdl0(nALightPoints(k),k)=vpdl0(i) + ALighttempair0(nALightPoints(k),k)=tempair0(i) + ALighteambient0(nALightPoints(k),k)=eambient0(i) +! + ALightfo_pam0(nALightPoints(k),k)=fo_pam0(i) + ALightfm_pam0(nALightPoints(k),k)=fm_pam0(i) + ALightfs_pam0(nALightPoints(k),k)=fs_pam0(i) + ALightpam_measlight0(nALightPoints(k),k)= + &pam_measlight0(i) + ALightyield_ps20(nALightPoints(k),k)=yield_ps2(i) + ALightyield_npq0(nALightPoints(k),k)=yield_npq(i) + ALightqlake0(nALightPoints(k),k)=qlake(i) + ALightqpuddle0(nALightPoints(k),k)=qpuddle(i) + ALightkps2_norm0(nALightPoints(k),k)=kps2_norm(i) + ALightknpq_norm0(nALightPoints(k),k)=knpq_norm(i) +! + ALightresiststomco20(nALightPoints(k),k)= + &resiststomco20(i) + m=1 + endif + enddo + if(m.eq.0)then +!A new A/Light curve + numALightcurves=numALightcurves+1 + nALightPoints(numALightcurves)=1 + ALightID(numALightcurves)=j + ALightanet_obs0(1,numALightcurves)=anet_obs0(i) + ALightpco2i0(1,numALightcurves)=pco2i0(i) + ALighttempleaf0(1,numALightcurves)=templeaf0(i) + ALightaPPFDlf0(1,numALightcurves)=aPPFDlf0(i) + ALightpres_air0(1,numALightcurves)=pres_air0(i) + ALightpo2i0(1,numALightcurves)=po2i0(i) + ALightchlflphips20(1,numALightcurves)=chlflphips20(i) + ALightpco2ambient0(1,numALightcurves)=pco2ambient0(i) + ALighttrmmol0(1,numALightcurves)=trmmol0(i) + ALightgswmeas0(1,numALightcurves)=gswmeas0(i) + ALightvpdl0(1,numALightcurves)=vpdl0(i) + ALighttempair0(1,numALightcurves)=tempair0(i) + ALighteambient0(1,numALightcurves)=eambient0(i) +! + ALightfo_pam0(1,numALightcurves)=fo_pam0(i) + ALightfm_pam0(1,numALightcurves)=fm_pam0(i) + ALightfs_pam0(1,numALightcurves)=fs_pam0(i) + ALightpam_measlight0(1,numALightcurves)= + &pam_measlight0(i) + ALightyield_ps20(1,numALightcurves)=yield_ps2(i) + ALightyield_npq0(1,numALightcurves)=yield_npq(i) + ALightqlake0(1,numALightcurves)=qlake(i) + ALightqpuddle0(1,numALightcurves)=qpuddle(i) + ALightkps2_norm0(1,numALightcurves)=kps2_norm(i) + ALightknpq_norm0(1,numALightcurves)=knpq_norm(i) +! + ALightresiststomco20(1,numALightcurves)= + &resiststomco20(i) + endif + else + nFreePoints=nFreePoints+1 + Freeanet_obs(nFreePoints)=anet_obs0(i) + Freepco2i(nFreePoints)=pco2i0(i) + Freetempleaf(nFreePoints)=templeaf0(i) + FreeaPPFDlf(nFreePoints)=aPPFDlf0(i) + Freepres_air(nFreePoints)=pres_air0(i) + Freepo2i(nFreePoints)=po2i0(i) + Freechlflphips2(nFreePoints)=chlflphips20(i) + Freepco2ambient(nFreePoints)=pco2ambient0(i) + Freetrmmol(nFreePoints)=trmmol0(i) + Freegswmeas(nFreePoints)=gswmeas0(i) + Freevpdl(nFreePoints)=vpdl0(i) + Freetempair(nFreePoints)=tempair0(i) + Freeeambient(nFreePoints)=eambient0(i) +! + Freefo_pam(nFreePoints)=fo_pam0(i) + Freefm_pam(nFreePoints)=fm_pam0(i) + Freefs_pam(nFreePoints)=fs_pam0(i) + Freepam_measlight(nFreePoints)=pam_measlight0(i) + Freeyield_ps2(nFreePoints)=yield_ps2(i) + Freeyield_npq(nFreePoints)=yield_npq(i) + Freeqlake(nFreePoints)=qlake(i) + Freeqpuddle(nFreePoints)=qpuddle(i) + Freekps2_norm(nFreePoints)=kps2_norm(i) + Freeknpq_norm(nFreePoints)=knpq_norm(i) +! + Freeresiststomco2(nFreePoints)=resiststomco20(i) + endif + endif + endif + enddo +!----------------------------------------------------------------------- +!Average clusters and then sort of ACi and ALight points. No need to cluster or sort fixed and free points + do i=1,numACicurves + call clustering(nACiPoints(i),1,ACipco2i0(1:nACiPoints(i),i:i), + &critdelCi_Pa,k,ibelong) + if(k.lt.nACipoints(i))then + call aftercluster(nACiPoints(i),1, + &ACipco2i0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACipco2ambient0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiaPPFDlf0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACitempleaf0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACipres_air0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACianet_obs0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACipo2i0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACitrmmol0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACigswmeas0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACivpdl0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACitempair0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACieambient0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACichlflphips20(1:nACiPoints(i),i:i),k,ibelong,fvector) +! + call aftercluster(nACiPoints(i),1, + &ACifo_pam0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACifm_pam0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACifs_pam0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACipam_measlight0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiyield_ps20(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiyield_npq0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiqlake0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiqpuddle0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACikps2_norm0(1:nACiPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nACiPoints(i),1, + &ACiknpq_norm0(1:nACiPoints(i),i:i),k,ibelong,fvector) +! + call aftercluster(nACiPoints(i),1, + &ACiresiststomco20(1:nACiPoints(i),i:i),k,ibelong,fvector) + nACiPoints(i)=k + endif +!sort CO2i from low to high + do j=1,nACiPoints(i) + ACipco2i(j,i)=ACipco2i0(j,i) + enddo + call sort_shell(nACiPoints(i),ACipco2i(1:nACiPoints(i),i:i), + &ioriorder) + do j=1,nACiPoints(i) + ACianet_obs(j,i)=ACianet_obs0(ioriorder(j),i) + ACitempleaf(j,i)=ACitempleaf0(ioriorder(j),i) + ACiaPPFDlf(j,i)=ACiaPPFDlf0(ioriorder(j),i) + ACipo2i(j,i)=ACipo2i0(ioriorder(j),i) + ACipres_air(j,i)=ACipres_air0(ioriorder(j),i) + ACipco2ambient(j,i)=ACipco2ambient0(ioriorder(j),i) + ACitrmmol(j,i)=ACitrmmol0(ioriorder(j),i) + ACigswmeas(j,i)=ACigswmeas0(ioriorder(j),i) + ACivpdl(j,i)=ACivpdl0(ioriorder(j),i) + ACitempair(j,i)=ACitempair0(ioriorder(j),i) + ACieambient(j,i)=ACieambient0(ioriorder(j),i) + ACichlflphips2(j,i)=ACichlflphips20(ioriorder(j),i) +! + ACifo_pam(j,i)=ACifo_pam0(ioriorder(j),i) + ACifm_pam(j,i)=ACifm_pam0(ioriorder(j),i) + ACifs_pam(j,i)=ACifs_pam0(ioriorder(j),i) + ACipam_measlight(j,i)=ACipam_measlight0(ioriorder(j),i) + ACiyield_ps2(j,i)=ACiyield_ps20(ioriorder(j),i) + ACiyield_npq(j,i)=ACiyield_npq0(ioriorder(j),i) + ACiqlake(j,i)=ACiqlake0(ioriorder(j),i) + ACiqpuddle(j,i)=ACiqpuddle0(ioriorder(j),i) + ACikps2_norm(j,i)=ACikps2_norm0(ioriorder(j),i) + ACiknpq_norm(j,i)=ACiknpq_norm0(ioriorder(j),i) +! + ACiresiststomco2(j,i)=ACiresiststomco20(ioriorder(j),i) + enddo + enddo + do i=1,numALightcurves + call clustering(nALightPoints(i),1, + &ALightaPPFDlf0(1:nALightPoints(i),i:i),critdelPAR,k,ibelong) + if(k.lt.nALightpoints(i))then + call aftercluster(nALightPoints(i),1, + &ALightpco2i0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightpco2ambient0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightaPPFDlf0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALighttempleaf0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightpres_air0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightanet_obs0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightpo2i0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALighttrmmol0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightgswmeas0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightvpdl0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALighttempair0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALighteambient0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightchlflphips20(1:nALightPoints(i),i:i),k,ibelong,fvector) +! + call aftercluster(nALightPoints(i),1, + &ALightfo_pam0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightfm_pam0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightfs_pam0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightpam_measlight0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightyield_ps20(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightyield_npq0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightqlake0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightqpuddle0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightkps2_norm0(1:nALightPoints(i),i:i),k,ibelong,fvector) + call aftercluster(nALightPoints(i),1, + &ALightknpq_norm0(1:nALightPoints(i),i:i),k,ibelong,fvector) +! + call aftercluster(nALightPoints(i),1, + &ALightresiststomco20(1:nALightPoints(i),i:i),k,ibelong,fvector) + nALightPoints(i)=k + endif +!sort PAR from low to high + do j=1,nALightPoints(i) + ALightaPPFDlf(j,i)=ALightaPPFDlf0(j,i) + enddo + call sort_shell(nALightPoints(i), + &ALightaPPFDlf(1:nALightPoints(i),i:i),ioriorder) + do j=1,nALightPoints(i) + ALightanet_obs(j,i)=ALightanet_obs0(ioriorder(j),i) + ALighttempleaf(j,i)=ALighttempleaf0(ioriorder(j),i) + ALightpco2i(j,i)=ALightpco2i0(ioriorder(j),i) + ALightpo2i(j,i)=ALightpo2i0(ioriorder(j),i) + ALightpres_air(j,i)=ALightpres_air0(ioriorder(j),i) + ALightpco2ambient(j,i)=ALightpco2ambient0(ioriorder(j),i) + ALighttrmmol(j,i)=ALighttrmmol0(ioriorder(j),i) + ALightgswmeas(j,i)=ALightgswmeas0(ioriorder(j),i) + ALightvpdl(j,i)=ALightvpdl0(ioriorder(j),i) + ALighttempair(j,i)=ALighttempair0(ioriorder(j),i) + ALighteambient(j,i)=ALighteambient0(ioriorder(j),i) + ALightchlflphips2(j,i)=ALightchlflphips20(ioriorder(j),i) +! + ALightfo_pam(j,i)=ALightfo_pam0(ioriorder(j),i) + ALightfm_pam(j,i)=ALightfm_pam0(ioriorder(j),i) + ALightfs_pam(j,i)=ALightfs_pam0(ioriorder(j),i) + ALightpam_measlight(j,i)=ALightpam_measlight0(ioriorder(j),i) + ALightyield_ps2(j,i)=ALightyield_ps20(ioriorder(j),i) + ALightyield_npq(j,i)=ALightyield_npq0(ioriorder(j),i) + ALightqlake(j,i)=ALightqlake0(ioriorder(j),i) + ALightqpuddle(j,i)=ALightqpuddle0(ioriorder(j),i) + ALightkps2_norm(j,i)=ALightkps2_norm0(ioriorder(j),i) + ALightknpq_norm(j,i)=ALightknpq_norm0(ioriorder(j),i) +! + ALightresiststomco2(j,i)=ALightresiststomco20(ioriorder(j),i) + enddo + enddo +!----------------------------------------------------------------------- + idoalpha0=1 + do i=1,numACicurves + amaxave=0.0d0 + n=3 + do j=nACiPoints(i)-n+1,nACiPoints(i) + amaxave=amaxave+ACianet_obs(j,i) + enddo + amaxave=amaxave/dble(n) +!the sigmoidal function has better asymptotic behaviour so +!it is used for estimating anetmaxs. + iderivative=1 + INFO=0 +!INFO =0, ordinary distance regression +!INFO =1, explicit orthogonal distance regression with shortest distance within iteration +!INFO =2, explicit orthogonal distance regression with x positions as parameters + beta(1)=dabs(amaxave) + if(amaxave.lt.0.0d0)then + betamin(1)=amaxave + else + betamin(1)=0.5d0*amaxave + endif + betamax(1)=200.0d0 + beta(2)=1.5d0 + betamin(2)=1.0d-5 + betamax(2)=1000.0d0 + beta(3)=0.1d0 + betamin(3)=0.0d0 + betamax(3)=100.0d0 + beta(4)=30.0d0 + betamin(4)=0.0d0 + betamax(4)=5000.0d0 + beta(5)=-10.0d0 + betamin(5)=-100.0d0 + betamax(5)=100.0d0 + k=0 + n=0 + do j=1,nACiPoints(i) + weitx(j)=1.0d0 + xmin(j)=dmax1(0.0d0,ACipco2i(j,i)-20.0d0) + xmax(j)=ACipco2i(j,i)+20.0d0 + weity(j)=1.0d0 + if(ACichlflphips2(j,i).gt.0.0d0)then + k=k+1 + yvector(k)=ACichlflphips2(j,i) + xvector(k)=ACipco2i(j,i) + uvector(k)=ACipco2ambient(j,i) + endif + if(ACipco2ambient(j,i).gt.0.0d0)then + n=n+1 + zvector(n)=ACianet_obs(j,i) + wvector(n)=ACipco2ambient(j,i) + endif + enddo + call GenericRegres(nACiPoints(i),1, + &ACianet_obs(1:nACiPoints(i),i:i),1,ACipco2i(1:nACiPoints(i),i:i), + &weity,weitx,5,beta,betamin,betamax,xmin,xmax,iderivative,INFO, + &fvector,gvector,sumsquare) + call properties_surffunc(5,beta,starco2i(i),der_starco2i(i), + &Amax_ACi(i),ACiinter(i),der_ACiinter(i), + &ACipco2i(nACiPoints(i):nACiPoints(i),i:i),der_ACiend(i),term, + &ACipco2i(1:1,i:i),ACipco2i(nACiPoints(i):nACiPoints(i),i:i), + &ACimaxcurvature(i),ACimaxcurvpco2i(i)) + call GenericRegres(n,1,zvector,1,wvector,weity,weitx,5,beta, + &betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, + &sumsquare) + call properties_surffunc(5,beta,starco2a(i),der_starco2a(i), + &Amax_ACa(i),ACainter(i),der_ACainter(i),40.0d0,der_ACa400ppm(i), + &anet_ACa400ppm(i),wvector(1),wvector(n),ACamaxcurvature(i), + &ACamaxcurvpco2a(i)) + if(Amax_ACi(i).lt.50.0d0)amaxave=Amax_ACi(i) + j=min0(5,nACiPoints(i)) + call y_aPLUSbx(j,ACipco2i(1:j,i:i),ACianet_obs(1:j,i:i),ac,at) +!fit for y=ac+at*x + if(ac.lt.0.0d0.and.dabs(ac).lt.rdlight25max)then + rdlight25_ini=dabs(ac) + if((-ac/at).lt.stargamma25max.and. + &(-ac/at).gt.stargamma25_ini)stargamma25max=-ac/at + endif + if(amaxave.gt.0.0d0)then + fjmax25_ini=(amaxave+rdlight25_ini)*4.0d0+10.0d0 + vcmax25_ini=fjmax25_ini/1.1d0 + tpu25_ini=(amaxave+rdlight25_ini)/3.0d0 + else + fjmax25_ini=10.0d0 + vcmax25_ini=fjmax25_ini/1.1d0 + tpu25_ini=1.0d0 + endif + if(k.ge.5)then +! beta(1)=0.50d0 +! betamin(1)=0.0d0 +! betamax(1)=1000.0d0 +! beta(2)=5.50d0 +! betamin(2)=0.0d0 +! betamax(2)=1000.0d0 +! beta(3)=1.50d0 +! betamin(3)=-10.0d0 +! betamax(3)=10.0d0 + + beta(1)=0.4d0 + betamin(1)=0.0d0 + betamax(1)=2.0d0 + beta(2)=1.5d0 + betamin(2)=1.0d-5 + betamax(2)=1000.0d0 + beta(3)=0.1d0 + betamin(3)=0.0d0 + betamax(3)=100.0d0 + beta(4)=30.0d0 + betamin(4)=0.0d0 + betamax(4)=5000.0d0 + beta(5)=0.1d0 + betamin(5)=-5.0d0 + betamax(5)=5.0d0 + do j=1,k + xmin(j)=dmax1(0.0d0,xvector(j)-20.0d0) + xmax(j)=xvector(j)+20.0d0 + enddo + call GenericRegres(k,1,yvector,1,xvector,weity,weitx,5, + &beta,betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, + &sumsquare) + call properties_surffunc(5,beta,PhiPSIIzero_ACi(i), + &der_PhiPSIIzero_ACi(i),PhiPSIImax_ACi(i), + &PhiPSIIinter_ACi(i),der_PhiPSIIinter_ACi(i),xvector(k), + &der_PhiPSIIend_ACi(i),term,xvector(1),xvector(k), + &PhiPSIImaxcurvature_ACi(i),PhiPSIImaxcurv_ACi(i)) + call GenericRegres(k,1,yvector,1,uvector,weity,weitx,5, + &beta,betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, + &sumsquare) + call properties_surffunc(5,beta,PhiPSIIzero_ACa(i), + &der_PhiPSIIzero_ACa(i),PhiPSIImax_ACa(i), + &PhiPSIIinter_ACa(i),der_PhiPSIIinter_ACa(i),uvector(k), + &der_PhiPSIIend_ACa(i),term,uvector(1),uvector(k), + &PhiPSIImaxcurvature_ACa(i),PhiPSIImaxcurv_ACa(i)) + else + PhiPSIIinter_ACi(i)=-9999.0d0 + der_PhiPSIIinter_ACi(i)=-9999.0d0 + PhiPSIIzero_ACi(i)=-9999.0d0 + der_PhiPSIIzero_ACi(i)=-9999.0d0 + PhiPSIImax_ACi(i)=-9999.0d0 + der_PhiPSIIend_ACi(i)=-9999.0d0 + PhiPSIImaxcurvature_ACi(i)=-9999.0d0 + PhiPSIImaxcurv_ACi(i)=-9999.0d0 + PhiPSIIinter_ACa(i)=-9999.0d0 + der_PhiPSIIinter_ACa(i)=-9999.0d0 + PhiPSIIzero_ACa(i)=-9999.0d0 + der_PhiPSIIzero_ACa(i)=-9999.0d0 + PhiPSIImax_ACa(i)=-9999.0d0 + der_PhiPSIIend_ACa(i)=-9999.0d0 + PhiPSIImaxcurvature_ACa(i)=-9999.0d0 + PhiPSIImaxcurv_ACa(i)=-9999.0d0 + endif +! + n=nACiPoints(i) + call y_aPLUSbxrsq(n,ACipco2i(1:n,i:i),ACianet_obs(1:n,i:i), + &ac,at,term) + resistwp25_ini=3.0d0*term**6 + resistch25_ini=term**6 + + if(term.lt.0.9d0)then + if(Amax_ACi(i).gt.0.0d0.and.Amax_ACi(i).lt.100.0d0)then + resistwp25_ini= + &resistwp25_ini*dmin1(20.0d0/Amax_ACi(i),3.0d0) + resistch25_ini= + &resistch25_ini*dmin1(20.0d0/Amax_ACi(i),2.0d0) + else + if(Amax_ACi(i).le.0.0d0)then + resistwp25_ini=6.0d0 + resistch25_ini=4.0d0 + endif + endif + endif +!almost a straightline +!determine the absolute last point of rubisco or rubp for an A/Ci curve + k=4 +10 if(n.le.k)goto 20 + if(ACianet_obs(n,i).gt.ACianet_obs(n-1,i).and. + &ACianet_obs(n-1,i).gt.ACianet_obs(n-2,i))goto 20 + do j=1,k + gvector(j)=ACipco2i(n-j+1,i) + fvector(j)=ACianet_obs(n-j+1,i) + enddo + call y_aPLUSbx(k,gvector,fvector,ac,at) +!fit for y=a+bx + if(at.gt.0.0d0)goto 20 + n=n-1 + goto 10 +20 nendaci(i)=n + if(ACianet_obs(n,i).le.ACianet_obs(n-1,i).and. + &ACianet_obs(n-1,i).le.ACianet_obs(n-2,i))nendaci(i)=nendaci(i)-1 + n=nACiPoints(i)-nendaci(i) + if(n.ge.3)then + do j=1,n + gvector(j)=ACipco2i(nendaci(i)+j,i) + fvector(j)=ACianet_obs(nendaci(i)+j,i) + enddo + call y_aPLUSbx(n,gvector,fvector,ac,at) +!fit for y=a+bx + if(dabs(at).le.1.0d-5)idoalpha0=0 + endif +!Beyond nendaci, the points can only be limited by TPU +! +!Determine the point before which all points are limited by Rubisco and/or RuBP regeneration and after which some points might be +!limited by Rubisco and/or RuBP regeneration and/or TPU until nendaci after which all points are limited by TPU. + n=1 + aj=-1.0d+20 +22 if(n.ge.(nendaci(i)-3))goto 24 + do j=1,k + gvector(j)=ACipco2i(n+j-1,i) + fvector(j)=ACianet_obs(n+j-1,i) + enddo + call y_aPLUSbx(k,gvector,fvector,ac,at) +!fit for y=a+bx + if(at.le.0.0d0)goto 24 + if(at.gt.aj)then + aj=at + else + if(at.lt.aj/5.0d0)goto 24 + endif + n=n+1 + goto 22 +24 nstartaci(i)=n-1 +! + n=nACiPoints(i) + if(n.ge.4)then + if(ACianet_obs(n,i).gt.ACianet_obs(n-1,i).and. + &ACianet_obs(n-1,i).gt.ACianet_obs(n-2,i).and. + &ACianet_obs(n-2,i).gt.ACianet_obs(n-3,i))then + nstartaci(i)=n-1 + nendaci(i)=n +!only the last point can be possibly tpu + endif + endif + if((nendaci(i)-nstartaci(i)).le.2)goto 29 +25 n=nstartaci(i) + if(ACianet_obs(n+1,i).gt.ACianet_obs(n,i))then +!if anet continues to increase, the point is not tpu limited + if((nendaci(i)-nstartaci(i)).gt.2)then + nstartaci(i)=n+1 + goto 25 + endif + else + nstartaci(i)=nstartaci(i)-1 + nstartaci(i)=max0(nstartaci(i),0) + endif +29 continue +!before nstartaci, no TPU points can occur + enddo +! + do i=1,numALightcurves + amaxave=0.0d0 + n=3 + do j=nALightPoints(i)-n+1,nALightPoints(i) + amaxave=amaxave+ALightanet_obs(j,i) + enddo + amaxave=amaxave/dble(n) +!the sigmoidal function has better asymptotic behaviour so +!it is used for estimating anetmaxs. + iderivative=1 + INFO=0 + beta(1)=dabs(amaxave) + if(amaxave.lt.0.0d0)then + betamin(1)=amaxave + else + betamin(1)=0.5d0*amaxave + endif + betamax(1)=200.0d0 + beta(2)=1.5d0 + betamin(2)=1.0d-5 + betamax(2)=1.0d+5 + beta(3)=0.1d0 + betamin(3)=0.0d0 + betamax(3)=5000.0d0 + beta(4)=30.0d0 + betamin(4)=-1000.0d0 + betamax(4)=1000.0d0 + beta(5)=-10.0d0 + betamin(5)=-100.0d0 + betamax(5)=100.0d0 + k=0 + do j=1,nALightPoints(i) + hvector(j)=ALightaPPFDlf(j,i)/abspt_lf_par + weitx(j)=1.0d0 + xmin(j)=dmax1(0.0d0,hvector(j)-20.0d0) + xmax(j)=hvector(j)+20.0d0 + weity(j)=1.0d0 + if(ALightchlflphips2(j,i).gt.0.0d0)then + k=k+1 + yvector(k)=ALightchlflphips2(j,i) + xvector(k)=hvector(j) + endif + enddo + call GenericRegres(nALightPoints(i),1, + &ALightanet_obs(1:nALightPoints(i),i:i),1,hvector(i),weity,weitx,5, + &beta,betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, + &sumsquare) + call properties_surffunc(5,beta,starPAR(i),der_starPAR(i), + &Asat_ALight(i),ALightinter(i),der_ALightinter(i), + &hvector(nALightPoints(i)),der_ALightend(i),term, + &hvector(1),hvector(nALightPoints(i)),ALightmaxcurvature(i), + &ALightmaxcurvPAR(i)) + if(Asat_ALight(i).lt.50.0d0)amaxave=Asat_ALight(i) + j=min0(5,nALightPoints(i)) + call y_aPLUSbx(j,hvector(1:j),ALightanet_obs(1:j,i:i),ac,at) +!fit for y=ac+at*x + if(ac.lt.0.0d0.and.dabs(ac).lt.rdlight25max) + &rdlight25_ini=dabs(ac) + if(amaxave.gt.0.0d0)then + fjmax25_ini=(amaxave+rdlight25_ini)*4.0d0+10.0d0 + vcmax25_ini=fjmax25_ini/1.1d0 + tpu25_ini=(amaxave+rdlight25_ini)/3.0d0 + else + fjmax25_ini=10.0d0 + vcmax25_ini=fjmax25_ini/1.1d0 + tpu25_ini=1.0d0 + endif + if(k.ge.5)then + beta(1)=0.50d0 + betamin(1)=-1000.0d0 + betamax(1)=0.0d0 + beta(2)=5.50d0 + betamin(2)=0.0d0 + betamax(2)=1000.0d0 + beta(3)=1.50d0 + betamin(3)=-10.0d0 + betamax(3)=10.0d0 + do j=1,k + xmin(j)=dmax1(0.0d0,xvector(j)-20.0d0) + xmax(j)=xvector(j)+20.0d0 + enddo + call GenericRegres(k,1,yvector,1,xvector,weity,weitx,3, + &beta,betamin,betamax,xmin,xmax,iderivative,INFO,fvector,gvector, + &sumsquare) + call properties_surffunc(3,beta,term,term1,term2, + &PhiPSIIinter_ALight(i),der_PhiPSIIinter_ALight(i), + &1000.0d0,der_PhiPSII1000_ALight(i),ExcessLightFactor(i), + &xvector(1),xvector(k),PhiPSIImaxcurvature_ALight(i), + &PhiPSIImaxcurv_ALight(i)) + der_PhiPSIIinter_ALight(i)=der_PhiPSIIinter_ALight(i)*1000.0d0 + der_PhiPSII1000_ALight(i)=der_PhiPSII1000_ALight(i)*1000.0d0 + ExcessLightFactor(i)=1.0d0-ExcessLightFactor(i)/0.83d0 + else + PhiPSIIinter_ALight(i)=-9999.0d0 + der_PhiPSIIinter_ALight(i)=-9999.0d0 + der_PhiPSII1000_ALight(i)=-9999.0d0 + ExcessLightFactor(i)=-9999.0d0 + PhiPSIImaxcurvature_ALight(i)=-9999.0d0 + PhiPSIImaxcurv_ALight(i)=-9999.0d0 + endif +!determine the absolute last point of rubp for an A/Light curve + k=4 + n=nALightPoints(i) +30 if(n.le.k)goto 40 + if(ALightanet_obs(n,i).gt.ALightanet_obs(n-1,i).and. + &ALightanet_obs(n-1,i).gt.ALightanet_obs(n-2,i))goto 40 + do j=1,k + gvector(j)=ALightaPPFDlf(n-j+1,i) + fvector(j)=ALightanet_obs(n-j+1,i) + enddo + call y_aPLUSbx(k,gvector,fvector,ac,at) +!fit for y=ac+at*x + if(at.gt.0.0d0)goto 40 + n=n-1 + goto 30 +40 nendalight(i)=n + if(ALightanet_obs(n,i).le.ALightanet_obs(n-1,i).and. + &ALightanet_obs(n-1,i).le.ALightanet_obs(n-2,i)) + &nendalight(i)=nendalight(i)-1 +!Beyond nendalight, the points can only be limited by Rubisco or TPU because they have constant or decreasing anet with inceased light +! +!Determine the point before which all points are limited by RuBP regeneration and after which some points might be limited by RuBP until +!nendalight. + n=1 + aj=-1.0d+20 +50 if(n.ge.(nendalight(i)-3))goto 55 + do j=1,k + gvector(j)=ALightaPPFDlf(n+j-1,i) + fvector(j)=ALightanet_obs(n+j-1,i) + enddo + call y_aPLUSbx(k,gvector,fvector,ac,at) +!fit for y=ac+at*x + if(at.lt.1.0d-4)goto 55 + if(at.gt.aj)then + aj=at + else + if(at.lt.aj/5.0d0)goto 55 + endif + n=n+1 + goto 50 +55 if(n.ge.(nendalight(i)-1))then + n=nendalight(i)-1 + goto 56 + endif + if(ALightanet_obs(n,i).lt.ALightanet_obs(n+1,i))then + n=n+1 + goto 55 + endif +56 nstartalight(i)=n-1 +!before nstartalight, no rubisco or tpu points can occur because anet increases with increased light, indicating RuBP regeneration +!limitation +! + n=nALightPoints(i) + if(n.ge.4)then + if(ALightanet_obs(n,i).gt.ALightanet_obs(n-1,i).and. + &ALightanet_obs(n-1,i).gt.ALightanet_obs(n-2,i).and. + &ALightanet_obs(n-2,i).gt.ALightanet_obs(n-3,i))then + if(ALightpco2i(n,i).le.ALightpco2i(n-1,i).and. + &ALightpco2i(n-1,i).le.ALightpco2i(n-2,i).and. + &ALightpco2i(n-2,i).le.ALightpco2i(n-3,i))then + nstartalight(i)=n-1 + nendalight(i)=n +!only the last point can be possibly Rubico or TPU because anet continues to rise while Ci is constant or decreasing + endif + endif + endif + if((nendalight(i)-nstartalight(i)).le.2)goto 64 +62 n=nstartalight(i) + if(ALightanet_obs(n+1,i).gt.ALightanet_obs(n,i).and. + &ALightpco2i(n+1,i).le.ALightpco2i(n,i))then +!continue until we reach the point when anet does not increase while pco2i does not decrease, i,e, if anet continues +!to increase while pco2i continues to decrease, we assumue this point is still limited by rubp regeneration. + if((nendalight(i)-nstartalight(i)).gt.2)then + nstartalight(i)=n+1 + goto 62 + endif + else + nstartalight(i)=nstartalight(i)-1 + nstartalight(i)=max0(nstartalight(i),0) + endif +64 continue +!we generally assume the points of an A/Light curve are lined up in a sequence of (RuBP, TPU and Rubisco), which is indicated by +!ialightorder=0. However, if Ci increases steadily from nstartalight to the end, we assume a sequence of (RuBP, Rubisco and TPU), +!which is indicated by ialightorder=2. + ialightorder(i)=2 + do j=nstartalight(i)+1,nALightPoints(i) + if(ALightpco2i(j,i).lt.ALightpco2i(j-1,i))ialightorder(i)=0 + enddo + enddo +!------------------------------------------------------------------------------------ +!Merge Fixed points, ACi points, ALight points, and Free points into single arrays. Do not change this order. + ntotsamples=0 + do i=1,nFixedPoints + ntotsamples=ntotsamples+1 + anet_obs(ntotsamples)=Fixedanet_obs(i) + pco2i(ntotsamples)=Fixedpco2i(i) + templeaf(ntotsamples)=Fixedtempleaf(i) + aPPFDlf(ntotsamples)=FixedaPPFDlf(i) + pres_air(ntotsamples)=Fixedpres_air(i) + po2i(ntotsamples)=Fixedpo2i(i) + chlflphips2(ntotsamples)=Fixedchlflphips2(i) + pco2ambient(ntotsamples)=Fixedpco2ambient(i) + trmmol(ntotsamples)=Fixedtrmmol(i) + gswmeas(ntotsamples)=Fixedgswmeas(i) + vpdl(ntotsamples)=Fixedvpdl(i) + tempair(ntotsamples)=Fixedtempair(i) + eambient(ntotsamples)=Fixedeambient(i) +! + fo_pam(ntotsamples)=Fixedfo_pam(i) + fm_pam(ntotsamples)=Fixedfm_pam(i) + fs_pam(ntotsamples)=Fixedfs_pam(i) + pam_measlight(ntotsamples)=Fixedpam_measlight(i) + yield_ps2(ntotsamples)=Fixedyield_ps2(i) + yield_npq(ntotsamples)=Fixedyield_npq(i) + qlake(ntotsamples)=Fixedqlake(i) + qpuddle(ntotsamples)=Fixedqpuddle(i) + kps2_norm(ntotsamples)=Fixedkps2_norm(i) + knpq_norm(ntotsamples)=Fixedknpq_norm(i) +! + resiststomco2(ntotsamples)=Fixedresiststomco2(i) + enddo + do i=1,numACicurves + ACiavetempleaf(i)=0.0d0 + ACiaveaPPFDlf(i)=0.0d0 + ACiavepo2i(i)=0.0d0 + do j=1,nACiPoints(i) + ntotsamples=ntotsamples+1 + anet_obs(ntotsamples)=ACianet_obs(j,i) + pco2i(ntotsamples)=ACipco2i(j,i) + templeaf(ntotsamples)=ACitempleaf(j,i) + aPPFDlf(ntotsamples)=ACiaPPFDlf(j,i) + pres_air(ntotsamples)=ACipres_air(j,i) + po2i(ntotsamples)=ACipo2i(j,i) + chlflphips2(ntotsamples)=ACichlflphips2(j,i) + pco2ambient(ntotsamples)=ACipco2ambient(j,i) + trmmol(ntotsamples)=ACitrmmol(j,i) + gswmeas(ntotsamples)=ACigswmeas(j,i) + vpdl(ntotsamples)=ACivpdl(j,i) + tempair(ntotsamples)=ACitempair(j,i) + eambient(ntotsamples)=ACieambient(j,i) +! + fo_pam(ntotsamples)=ACifo_pam(j,i) + fm_pam(ntotsamples)=ACifm_pam(j,i) + fs_pam(ntotsamples)=ACifs_pam(j,i) + pam_measlight(ntotsamples)=ACipam_measlight(j,i) + yield_ps2(ntotsamples)=ACiyield_ps2(j,i) + yield_npq(ntotsamples)=ACiyield_npq(j,i) + qlake(ntotsamples)=ACiqlake(j,i) + qpuddle(ntotsamples)=ACiqpuddle(j,i) + kps2_norm(ntotsamples)=ACikps2_norm(j,i) + knpq_norm(ntotsamples)=ACiknpq_norm(j,i) +! + resiststomco2(ntotsamples)=ACiresiststomco2(j,i) + ACiavetempleaf(i)=ACiavetempleaf(i)+ACitempleaf(j,i) + ACiaveaPPFDlf(i)=ACiaveaPPFDlf(i)+ACiaPPFDlf(j,i) + ACiavepo2i(i)=ACiavepo2i(i)+ACipo2i(j,i) + enddo + ACiavetempleaf(i)=ACiavetempleaf(i)/dble(nACiPoints(i)) + ACiaveaPPFDlf(i)=ACiaveaPPFDlf(i)/dble(nACiPoints(i)) + ACiavepo2i(i)=ACiavepo2i(i)/dble(nACiPoints(i)) + enddo + do i=1,numALightcurves + ALightavetempleaf(i)=0.0d0 + ALightaveCO2ambient(i)=0.0d0 + ALightavepo2i(i)=0.0d0 + do j=1,nALightPoints(i) + ntotsamples=ntotsamples+1 + anet_obs(ntotsamples)=ALightanet_obs(j,i) + pco2i(ntotsamples)=ALightpco2i(j,i) + templeaf(ntotsamples)=ALighttempleaf(j,i) + aPPFDlf(ntotsamples)=ALightaPPFDlf(j,i) + pres_air(ntotsamples)=ALightpres_air(j,i) + po2i(ntotsamples)=ALightpo2i(j,i) + chlflphips2(ntotsamples)=ALightchlflphips2(j,i) + pco2ambient(ntotsamples)=ALightpco2ambient(j,i) + trmmol(ntotsamples)=ALighttrmmol(j,i) + gswmeas(ntotsamples)=ALightgswmeas(j,i) + vpdl(ntotsamples)=ALightvpdl(j,i) + tempair(ntotsamples)=ALighttempair(j,i) + eambient(ntotsamples)=ALighteambient(j,i) +! + fo_pam(ntotsamples)=ALightfo_pam(j,i) + fm_pam(ntotsamples)=ALightfm_pam(j,i) + fs_pam(ntotsamples)=ALightfs_pam(j,i) + pam_measlight(ntotsamples)=ALightpam_measlight(j,i) + yield_ps2(ntotsamples)=ALightyield_ps2(j,i) + yield_npq(ntotsamples)=ALightyield_npq(j,i) + qlake(ntotsamples)=ALightqlake(j,i) + qpuddle(ntotsamples)=ALightqpuddle(j,i) + kps2_norm(ntotsamples)=ALightkps2_norm(j,i) + knpq_norm(ntotsamples)=ALightknpq_norm(j,i) +! + resiststomco2(ntotsamples)=ALightresiststomco2(j,i) + ALightavetempleaf(i)=ALightavetempleaf(i)+ALighttempleaf(j,i) + ALightaveCO2ambient(i)=ALightaveCO2ambient(i)+ + &ALightpco2ambient(j,i) + ALightavepo2i(i)=ALightavepo2i(i)+ALightpo2i(j,i) + enddo + ALightavetempleaf(i)=ALightavetempleaf(i)/dble(nALightPoints(i)) + ALightaveCO2ambient(i)=ALightaveCO2ambient(i)/ + &dble(nALightPoints(i)) + ALightavepo2i(i)=ALightavepo2i(i)/dble(nALightPoints(i)) + enddo + do i=1,nFreePoints + ntotsamples=ntotsamples+1 + anet_obs(ntotsamples)=Freeanet_obs(i) + pco2i(ntotsamples)=Freepco2i(i) + templeaf(ntotsamples)=Freetempleaf(i) + aPPFDlf(ntotsamples)=FreeaPPFDlf(i) + pres_air(ntotsamples)=Freepres_air(i) + po2i(ntotsamples)=Freepo2i(i) + chlflphips2(ntotsamples)=Freechlflphips2(i) + pco2ambient(ntotsamples)=Freepco2ambient(i) + trmmol(ntotsamples)=Freetrmmol(i) + gswmeas(ntotsamples)=Freegswmeas(i) + vpdl(ntotsamples)=Freevpdl(i) + tempair(ntotsamples)=Freetempair(i) + eambient(ntotsamples)=Freeeambient(i) +! + fo_pam(ntotsamples)=Freefo_pam(i) + fm_pam(ntotsamples)=Freefm_pam(i) + fs_pam(ntotsamples)=Freefs_pam(i) + pam_measlight(ntotsamples)=Freepam_measlight(i) + yield_ps2(ntotsamples)=Freeyield_ps2(i) + yield_npq(ntotsamples)=Freeyield_npq(i) + qlake(ntotsamples)=Freeqlake(i) + qpuddle(ntotsamples)=Freeqpuddle(i) + kps2_norm(ntotsamples)=Freekps2_norm(i) + knpq_norm(ntotsamples)=Freeknpq_norm(i) +! + resiststomco2(ntotsamples)=Freeresiststomco2(i) + enddo + ntotphips2=0 + term1=1.0d+99 + term2=-1.0d+99 + do i=1,ntotsamples + pco2i_ori(i)=pco2i(i) + templeaf_ori(i)=templeaf(i) + if(templeaf(i).lt.term1)term1=templeaf(i) + if(templeaf(i).gt.term2)term2=templeaf(i) + aPPFDlf_ori(i)=aPPFDlf(i) + pres_air_ori(i)=pres_air(i) + po2i_ori(i)=po2i(i) + chlflphips2_ori(i)=chlflphips2(i) + pco2ambient_ori(i)=pco2ambient(i) + trmmol_ori(i)=trmmol(i) + gswmeas_ori(i)=gswmeas(i) + vpdl_ori(i)=vpdl(i) + tempair_ori(i)=tempair(i) + eambient_ori(i)=eambient(i) + resiststomco2_ori(i)=resiststomco2(i) + if(chlflphips2_ori(i).gt.0.0d0)then + ntotphips2=ntotphips2+1 + endif + enddo + idotempcoeff=0 + if((term2-term1).gt.2.0d0)idotempcoeff=1 +!If temperature variation in the dataset is larger enough, try to estimate parameters in temperature response functions +!All variables are now in the right order. All ACi curves are ordered and All ALight curves are ordered. +!------------------------------------------------------------------------------------------------------- +! + do i=1,ntotsamples + anet_pred(i)=-9999.0d0 + pco2i_pred(i)=-9999.0d0 + pco2c(i)=-9999.0d0 + anet_pred_flu(i)=-9999.0d0 + pco2i_pred_flu(i)=-9999.0d0 + pco2c_anet_flu(i)=-9999.0d0 + pco2c_pco2i_flu(i)=-9999.0d0 + enddo + if(ntotphips2.gt.5)then + do idorch=1,1 +!we do a fluorescence only fit + Prioriknowlimit=-1 + ifitmode=1 +!ifitmode: =-2, ordinary fitting with pco2i calculated as a function of anet +!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i +!ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i +!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet + idorwp=1 + resistwp25_ori=resistwp25_ini + if(idorch.eq.1)then + resistch25_ori=resistch25_ini + else + resistch25_ori=0.0d0 + endif + if(rdlight25_usr.le.0.0d0)then + idord=1 + rdlight25_ori=rdlight25_ini + else + idord=0 + rdlight25_ori=rdlight25_usr + endif + idostargamma=1 + idobetaPSII=1 + idoha_darkresp=idotempcoeff + idoha_stargamma=idotempcoeff + idoha_gmeso=idotempcoeff + stargamma25_ori=stargamma25_ini + betaPSII_ori=betaPSII_ini + fjmax25_ori=fjmax25_ini + phifactor_ori=phifactor_ini + thetafactor_ori=thetafactor_ini + ha_darkresp_ori=ha_darkresp_ini + ha_stargamma_ori=ha_stargamma_ini + ha_gmeso_ori=ha_gmeso_ini + ha_jmax_ori=ha_jmax_ini + call HybridCombinatorial() + do j=1,ntotsamples + call gmesoontemp(templeaf(j),1.0d0,gascon,ha_gmeso, + &hd_gmeso,sv_gmeso,term) + resistwp=resistwp25/term + resistch=resistch25/term + call resp_mitocho(templeaf(j),rdlight25,ha_darkresp, + &gascon,rdlight) + call co2compens(templeaf(j),stargamma25, + &ha_stargamma,gascon,stargamma) + write(fluorescenceunit,370)trim(curvename),pco2i_ori(j), + &pco2i_pred(j),pco2c(j),anet_obs(j),anet_pred(j), + &pco2ambient_ori(j),po2i_ori(j)/1000.0d0,eambient_ori(j)/1000.0d0, + &pres_air_ori(j)/1000.0d0,vpdl_ori(j)/1000.0d0, + &aPPFDlf(j)/abspt_lf_par,templeaf_ori(j)-273.15d0, + &tempair_ori(j)-273.15d0,trmmol_ori(j),gswmeas_ori(j), + &chlflphips2_ori(j),rdlight25,resistwp25,resistch25, + &stargamma25,betaPSII,sumsquare,ha_darkresp,resistwp,resistch, + &ha_stargamma,fo_pam(j),fm_pam(j),fs_pam(j),pam_measlight(j), + &yield_ps2(j),yield_npq(j),qlake(j),qpuddle(j),kps2_norm(j), + &knpq_norm(j) + enddo + if(idorch.eq.0)then + fvector(1)=rdlight25 + fvector(2)=resistwp25 + fvector(3)=stargamma25 + fvector(4)=betaPSII + endif + enddo + if(ntotlights.gt.0)then +!Jmax estimation with fluorescence data. +!Only points before nstartalight are used because these points are apparently limited by RuBP regeneration and therefore +!the electron transport equation applies. ntotlights is the number of points that are clearly limited by RuBP regeneration. + modeltype(0)='PARi' + modeltype(1)='TempLeaf' + modeltype(2)='PhiPSII_obs' + modeltype(3)='PhiPSII_pred' + modeltype(4)='Jmax25' + modeltype(5)='phifactor' + modeltype(6)='thetafactor' + modeltype(7)='ha_jmax' + modeltype(8)='SumSquare' + write(fluorescenceunit,305)(trim(modeltype(j)),j=0,8) + do j=1,ntotlights + write(fluorescenceunit,306)aparlights(j)/abspt_lf_par, + &templflights(j)-273.15d0,flphips2lights(j),PhiPSIIlights_pred(j), + &fjmax25,phifactor,thetafactor,ha_jmax,flujmaxfval + enddo + else + fjmax25=-9999.0d0 + phifactor=-9999.0d0 + thetafactor=-9999.0d0 + flujmaxfval=-9999.0d0 + endif + term=tempK_dark-273.15d0 + if(term.lt.-10000.0d0)term=-9999.0d0 + write(fluoresparamunit,380)trim(curvename),fjmax25,rdlight25, + &fvector(1),resistwp25,fvector(2),resistch25,stargamma25, + &fvector(3),phifactor,thetafactor,betaPSII,fvector(4),fo_dark, + &fm_dark,resp_dark,term,sumsquare,flujmaxfval + endif +!---------------------------------------------------------------- + idophifactor=0 + idothetafactor=0 + idobetaPSII=0 + ifitmode=-1 +!ifitmode: =-2, ordinary fitting with pco2i calculated as a function of anet +!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i +!ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i +!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet + if(numALightcurves.ge.1)then + idophifactor=1 + idothetafactor=1 + endif + if(ntotphips2.ge.2)idobetaPSII=1 + modeltype(0)='NoSuitModel' + modeltype(1)='RubiscoRuBpTpu' + modeltype(2)='RubiscoRuBp' + modeltype(3)='RubiscoTpu' + modeltype(4)='RuBpTpu' + modeltype(5)='Rubisco' + modeltype(6)='RuBp' + modeltype(7)='Tpu' + fourchars(1)='CO2i' + fourchars(2)='CO2cc' + fourchars(3)='Ac' + fourchars(4)='CO2cj' + fourchars(5)='Aj' + fourchars(6)='CO2ct' + fourchars(7)='At' + do k=1,4 + do j=1,ntotsamples + co2c_Pa(k,j)=-9999.0d0 + recycleratio(k,j)=-9999.0d0 + recycleratio(5,j)=-9999.0d0 + recycleratio(6,j)=-9999.0d0 + enddo + enddo + do idorwp0=0,1 +!When resistwp is estimated, we either estimate or not estimate resistch. But when resistwp is not estimated, neither is resistch. + if(idorwp0.eq.1)then + irchoption1=0 + irchoption2=1 + else + irchoption1=0 + irchoption2=0 + endif + do idorch0=irchoption1,irchoption2 + do i2ndary=0,1 + if(i2ndary.eq.0)then + idostargamma=0 + idokc=0 + idoko=0 + idoalpha=0 + idoha_stargamma=0 + idoha_vcmax=0 + idoha_jmax=0 + idoha_tpu=0 + else + idostargamma=1 + idokc=1 +!when data are sufficient (e.g. when multiple levels of oxygen are used in the measurements, set idoko=1 + idoko=0 + idoalpha=idoalpha0 + idoha_stargamma=idotempcoeff + idoha_vcmax=idotempcoeff + idoha_jmax=idotempcoeff + idoha_tpu=idotempcoeff + endif + if(idorwp0.eq.0)then + idorwp=0 + resistwp25_ori=0.0d0 + idoha_gmeso=0 + else + idoha_gmeso=idotempcoeff + if(resistwp25_usr.ge.0.0d0)then +!User provides a valid estimate of resistwp25 so don't estimate it even when idorwp0=1 + idorwp=0 + resistwp25_ori=resistwp25_usr + else + idorwp=1 + resistwp25_ori=resistwp25_ini + endif + endif + if(idorch0.eq.0)then + idorch=0 + resistch25_ori=0.0d0 + idoha_gmeso=0 + else + idoha_gmeso=idotempcoeff + if(resistch25_usr.ge.0.0d0)then +!User provides a valid estimate of resistch25 so don't estimate it even when idorch0=1 + idorch=0 + resistch25_ori=resistch25_usr + else + idorch=1 + resistch25_ori=resistch25_ini + endif + endif +!rd has to be provided by user or to be estimated under any circumstances + idoha_darkresp=idotempcoeff + if(rdlight25_usr.gt.0.0d0)then + idord=0 + rdlight25_ori=rdlight25_usr + else + idord=1 + rdlight25_ori=rdlight25_ini + endif +!if kc25 is provided by the user, it is not estimated under any circumstances. Otherwise it is estimated or not estimated depending on i2ndary + if(fkc25_usr.gt.0.0d0)then + idokc=0 + fkc25_ori=fkc25_usr + else + fkc25_ori=fkc25_ini + endif +!as long as oxygen is constant, it is hard to estimate ko25 + if(fko25_usr.gt.0.0d0)then + idoko=0 + fko25_ori=fko25_usr + else + fko25_ori=fko25_ini + endif +!if stargamma25 is provided by the user, it is not changed under any circumstances. Otherwise it is estimated or not estimated depending on i2ndary + if(stargamma25_usr.gt.0.0d0)then + idostargamma=0 + stargamma25_ori=stargamma25_usr + else + stargamma25_ori=stargamma25_ini + endif +!if alpha25 is provided by the user, it is not changed under any circumstances. Otherwise it is to be estimated or not to be +!estimated depending on i2ndary; when it is not to be estimated, it is set to zero; when it is be to be estimated, it is initialized to a positive +!value because it is not good to initialize an unknown to be zero. + if(alpha25_usr.ge.0.0d0)then + idoalpha=0 + alpha25_ori=alpha25_usr + else + if(idoalpha.eq.0)then + alpha25_ori=0.0d0 + else + alpha25_ori=alpha25_ini + endif + endif + vcmax25_ori=vcmax25_ini + fjmax25_ori=fjmax25_ini + tpu25_ori=tpu25_ini + phifactor_ori=phifactor_ini + thetafactor_ori=thetafactor_ini + betaPSII_ori=betaPSII_ini + ha_darkresp_ori=ha_darkresp_ini + ha_stargamma_ori=ha_stargamma_ini + ha_vcmax_ori=ha_vcmax_ini + ha_jmax_ori=ha_jmax_ini + ha_tpu_ori=ha_tpu_ini + ha_gmeso_ori=ha_gmeso_ini + Prioriknowlimit=-9999 + if((nFixedPoints+numACicurves+nFreePoints).eq.0)then +!If only light response curves are available, we don't estimate Kc and Ko because variations in Ci in light response curves are limited. + idokc=0 + idoko=0 + endif +!------------------------------------------------------------------- + call HybridCombinatorial() +!------------------------------------------------------------------- + if(bestnumtpu.eq.0)then +!use the asymptote of the A/Ci curve whose PAR is the highest to estimate tpu25 + j=1 + do i=2,numACicurves + if(ACiaveaPPFDlf(i).gt.ACiaveaPPFDlf(j))j=i + enddo + call resp_mitocho(ACiavetempleaf(j),rdlight25, + &ha_darkresp,gascon,rdlight) + tpu25=(Amax_ACi(j)+rdlight)/3.0d0 + call tpuontemp(ACiavetempleaf(j),gascon,1.0d0,ha_tpu, + &hd_tpu,sv_tpu,term) + tpu25=tpu25/term + alpha25=0.0d0 + idoalpha=0 + endif + if(bestnumrubis.eq.0)then + idokc=0 + idoko=0 + endif +!Calculation of CO2 recycling ratio + if(idorwp0.eq.1)then + if(idorch0.eq.0.and.i2ndary.eq.0)k=1 + if(idorch0.eq.0.and.i2ndary.eq.1)k=2 + if(idorch0.eq.1.and.i2ndary.eq.0)k=3 + if(idorch0.eq.1.and.i2ndary.eq.1)k=4 + else + if(i2ndary.eq.0)k=5 + if(i2ndary.eq.1)k=6 + endif + stargamma25fit(k)=stargamma25 + idomeso=(idorwp+1)*100+(idorch+1)*10+idoha_gmeso+1 + j=0 + if(bestilimittype.le.3.or.bestilimittype.eq.5)j=idoha_vcmax + idohavjt=(j+1)*100 + j=0 + if(bestilimittype.le.2.or.bestilimittype.eq.4.or. + &bestilimittype.eq.6)j=idoha_jmax + idohavjt=idohavjt+(j+1)*10 + j=0 + if(bestilimittype.eq.1.or.bestilimittype.eq.3.or. + &bestilimittype.eq.4.or.bestilimittype.eq.7)j=idoha_tpu + idohavjt=idohavjt+j+1 +! = 1, Rubisco+RuBP+TPU +! = 2, Rubisco+RuBP +! = 3, Rubisco+TPU +! = 4, RuBP+TPU +! = 5, Rubisco Only +! = 6, RuBP Only +! = 7, TPU Only + idostargamma=(idostargamma+1)*10+idoha_stargamma+1 + idokc=(idokc+1)*10+1 + idoko=(idoko+1)*10+1 + idord=(idord+1)*10+(idoha_darkresp+1) + idoalpha=(idoalpha+1) + do j=1,ntotsamples + if(k.le.4)co2c_Pa(k,j)=pco2c(j) + if(resiststomco2(j).ge.0.0d0)then + call gmesoontemp(templeaf(j),1.0d0,gascon,ha_gmeso, + &hd_gmeso,sv_gmeso,term) + resistwp=resistwp25/term + resistch=resistch25/term + call resp_mitocho(templeaf(j),rdlight25,ha_darkresp, + &gascon,rdlight) + call co2compens(templeaf(j),stargamma25, + &ha_stargamma,gascon,stargamma) + call co2recyclingratio(resistwp,resistch, +! &resiststomco2(j),stargamma,rdlight,pco2c(j),anet_obs(j), + &resiststomco2(j),stargamma,rdlight,pco2c(j),anet_pred(j), + &recycleratio(k:k,j:j)) + else + recycleratio(k,j)=-9999.0d0 + endif + write(compareunit,300)trim(curvename),idomeso,idohavjt, + &idostargamma,idokc,idoko,idord,idoalpha,idobetaPSII+1, + &pco2i_ori(j),pco2i_pred(j),pco2c(j),anet_obs(j),anet_pred(j), + &bestiphotolimit(j),recycleratio(k,j)*100.0d0,pco2ambient_ori(j), + &po2i_ori(j)/1000.0d0,eambient_ori(j)/1000.0d0, + &pres_air_ori(j)/1000.0d0,vpdl_ori(j)/1000.0d0, + &aPPFDlf(j)/abspt_lf_par,templeaf_ori(j)-273.15d0, + &tempair_ori(j)-273.15d0,trmmol_ori(j),gswmeas_ori(j), + &chlflphips2_ori(j),PhiPSII_pred(j),pco2i_pred_flu(j), + &anet_pred_flu(j),pco2c_pco2i_flu(j),pco2c_anet_flu(j) + enddo +!Generate mono-limiting curves + k=nFixedPoints + do i=1,numACicurves + n=k+nACiPoints(i) + j=n-k + call ilimittypestats(j,bestiphotolimit(k+1:n), + &Currentilimittype,numrubis,numrubp,numtpu) + write(compareunit,310)(trim(fourchars(j)),j=1,7) + co2imany(1)=1.0d0 + co2imany(2)=2.0d0 + co2imany(3)=3.0d0 + co2imany(4)=4.0d0 + co2imany(5)=5.0d0 + m=5 + term=ACipco2i(nACiPoints(i),i)+10.0d0 + do ccc=6.0d0,term,2.5d0 + m=m+1 + co2imany(m)=ccc + enddo + do j=1,m + ccc=co2imany(j) + ccj=co2imany(j) + cct=co2imany(j) + if(numrubis.gt.0)then + Currentilimittype=5 + call leafanetmodel(Currentilimittype,ACiaveaPPFDlf(i), + &ACiavetempleaf(i),co2imany(j),ACiavepo2i(i),-9999.0d0,gascon, + &resistwp25,resistch25,ha_gmeso,hd_gmeso,sv_gmeso, + &vcmax25,ha_vcmax,hd_vcmax,sv_vcmax,fjmax25,ha_jmax, + &hd_jmax,sv_jmax,tpu25,ha_tpu,hd_tpu,sv_tpu,alpha25, + &rdlight25,ha_darkresp,stargamma25,ha_stargamma,fkc25, + &ha_kc,fko25,ha_ko,phifactor,thetafactor,betaPSII, + &ac,rdlight,m,atp,resistwp,resistch,stargamma,ccc,realizedfjelect, + &term1,term2) + else + ac=-9999.0d0 + ccc=-9999.0d0 + endif + if(numrubp.gt.0)then + Currentilimittype=6 + call leafanetmodel(Currentilimittype,ACiaveaPPFDlf(i), + &ACiavetempleaf(i),co2imany(j),ACiavepo2i(i),-9999.0d0,gascon, + &resistwp25,resistch25,ha_gmeso,hd_gmeso,sv_gmeso, + &vcmax25,ha_vcmax,hd_vcmax,sv_vcmax,fjmax25,ha_jmax, + &hd_jmax,sv_jmax,tpu25,ha_tpu,hd_tpu,sv_tpu,alpha25, + &rdlight25,ha_darkresp,stargamma25,ha_stargamma,fkc25, + &ha_kc,fko25,ha_ko,phifactor,thetafactor,betaPSII, + &aj,rdlight,m,atp,resistwp,resistch,stargamma,ccj,realizedfjelect, + &term1,term2) + else + aj=-9999.0d0 + ccj=-9999.0d0 + endif + Currentilimittype=7 + call leafanetmodel(Currentilimittype,ACiaveaPPFDlf(i), + &ACiavetempleaf(i),co2imany(j),ACiavepo2i(i),-9999.0d0,gascon, + &resistwp25,resistch25,ha_gmeso,hd_gmeso,sv_gmeso, + &vcmax25,ha_vcmax,hd_vcmax,sv_vcmax,fjmax25,ha_jmax, + &hd_jmax,sv_jmax,tpu25,ha_tpu,hd_tpu,sv_tpu,alpha25, + &rdlight25,ha_darkresp,stargamma25,ha_stargamma, + &fkc25,ha_kc,fko25,ha_ko,phifactor,thetafactor, + &betaPSII,at,rdlight,m,atp,resistwp,resistch,stargamma,cct, + &realizedfjelect,term1,term2) + if(cct.le.((1.0d0+3.0d0*alpha25)*stargamma))then + cct=-9999.0d0 + at=-9999.0d0 + endif + write(compareunit,320)co2imany(j),ccc,ac,ccj,aj,cct,at + k=n + enddo + enddo + write(compareunit,*) +!------------------------------------------------------------------------------- +!Compute Rubisco-RuBP-TPU transitional points at 25oC and PAR = 1000 umolm-2s-1 + j=bestilimittype +!tpu and alpha are always available + if(bestilimittype.eq.2)j=1 + if(bestilimittype.eq.5)j=3 + if(bestilimittype.eq.6)j=4 + if(fjmax25.gt.0.0d0)then + call jontemp(1000.0d0*abspt_lf_par,298.15d0,term,fjmax25, + &ha_jmax,hd_jmax,sv_jmax,gascon,phifactor,thetafactor,betaPSII) + endif + call EqualPoints(vcmax25,term,tpu25,resistwp25,resistch25, + &stargamma25,fkc25,fko25,21000.0d0,alpha25,rdlight25,j, + &co2iRubismax25,co2iRuBpmax25,anetRubismax25,anetRuBpmax25) +!------------------------------------------------------------------------------ + write(paramunit,330)trim(curvename),idomeso,idohavjt, + &idostargamma,idokc,idoko,idord,idoalpha,idobetaPSII+1, + &trim(modeltype(bestilimittype)),vcmax25,fjmax25, + &rdlight25,resistwp25,resistch25,tpu25, + &stargamma25,fkc25,fko25,alpha25,ha_vcmax, + &hd_vcmax,sv_vcmax,ha_jmax,hd_jmax,sv_jmax,ha_tpu,hd_tpu, + &sv_tpu,ha_gmeso,hd_gmeso,sv_gmeso,ha_darkresp,ha_stargamma, + &ha_kc,ha_ko,phifactor,thetafactor,betaPSII, + &bestnumrubis,bestnumrubp,bestnumtpu,ntotsamples,bestsumsquare, + &co2iRubismax25,co2iRuBpmax25,anetRubismax25,anetRuBpmax25, + &trim(siteID),Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,trim(species),avetimeresolution,avetimesampled, + &SampleHeight,Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,trim(woodporosity),sapwooddensity,leafratio + enddo + enddo + enddo + if(numACicurves.gt.0)then + do i=1,numACicurves + write(aciempfitunit,390)trim(curvename),i,starco2i(i), + &der_starco2i(i),Amax_ACi(i),ACiinter(i),der_ACiinter(i), + &der_ACiend(i),PhiPSIImax_ACi(i),PhiPSIIinter_ACi(i), + &der_PhiPSIIinter_ACi(i),der_PhiPSIIend_ACi(i), + &ACimaxcurvature(i),ACimaxcurvpco2i(i), + &PhiPSIImaxcurvature_ACi(i),PhiPSIImaxcurv_ACi(i), + &starco2a(i),der_starco2a(i),Amax_ACa(i),ACainter(i), + &der_ACainter(i),der_ACa400ppm(i),anet_ACa400ppm(i), + &PhiPSIImax_ACa(i),PhiPSIIinter_ACa(i),der_PhiPSIIinter_ACa(i), + &der_PhiPSIIend_ACa(i),ACamaxcurvature(i),ACamaxcurvpco2a(i), + &PhiPSIImaxcurvature_ACa(i),PhiPSIImaxcurv_ACa(i),ACiavetempleaf(i) + &-273.15d0,ACiaveaPPFDlf(i)/abspt_lf_par,ACiavepo2i(i), + &trim(siteID),Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,trim(species),avetimeresolution,avetimesampled, + &SampleHeight,Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,trim(woodporosity),sapwooddensity,leafratio + enddo + endif + if(numALightcurves.gt.0)then + do i=1,numALightcurves + write(alightempfitunit,360)trim(curvename),i,starPAR(i), + &der_starPAR(i),Asat_ALight(i),ALightinter(i),der_ALightinter(i), + &der_ALightend(i),PhiPSIIinter_ALight(i), + &der_PhiPSIIinter_ALight(i),ExcessLightFactor(i), + &der_PhiPSII1000_ALight(i),ALightmaxcurvature(i), + &ALightmaxcurvPAR(i),PhiPSIImaxcurvature_ALight(i), + &PhiPSIImaxcurv_ALight(i),ALightavetempleaf(i)-273.15d0, + &ALightaveCO2ambient(i),ALightavepo2i(i), + &trim(siteID),Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,trim(species),avetimeresolution,avetimesampled, + &SampleHeight,Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,trim(woodporosity),sapwooddensity,leafratio + enddo + endif + call LeafGasFit_Stom(stomwuecicaoutunit,wuecicacompunit, + &stomcompunit,icurveno_usr,curvename,ntotsamples,aPPFDlf,templeaf, + &tempair,pco2i,pco2ambient,pres_air,anet_obs,gswmeas,vpdl,trmmol, + &abspt_lf_par,co2c_Pa(1:4,1:ntotsamples), + &recycleratio(1:6,1:ntotsamples),stargamma25fit,ha_stargamma, + &siteID,Latitude,Longitude,Elevation,yearsampled,sampledoy, + &GrowingSeasonStart,GrowingSeasonEnd,standage,CanopyHeight, + &LeafAreaIndex,species,avetimeresolution,avetimesampled, + &SampleHeight,Needleage,specificLAI,nitrogencontent,carboncontent, + &phoscontent,woodporosity,sapwooddensity,leafratio) + return +300 format(a,',',8(i0,','),5(f0.6,','),i0,',',16(f0.6,','),f0.6) +305 format(8(a,','),a) +306 format(8(f0.6,','),f0.6) +310 format(6(a,','),a) +320 format(6(f0.6,','),f0.6) +330 format(a,',',8(i0,','),a,',',29(f0.6,','),4(i0,','), + &5(f0.6,','),a,',',10(f0.6,','),a,',',8(f0.6,','),a,',',f0.6, + &',',f0.6) +360 format(a,',',i0,',',17(f0.6,','),a,',',10(f0.6,','),a,',', + &8(f0.6,','),a,',',f0.6,',',f0.6) +370 format(a,',',35(f0.6,','),f0.6) +380 format(a,',',17(f0.6,','),f0.6) +390 format(a,',',i0,',',32(f0.6,','),a,',', + &10(f0.6,','),a,',',8(f0.6,','),a,',',f0.6,',',f0.6) + end subroutine SetUpLeafGasFit diff --git a/leafres/testarea/StomatalConductance.f b/leafres/testarea/StomatalConductance.f new file mode 100644 index 0000000..ce481f6 --- /dev/null +++ b/leafres/testarea/StomatalConductance.f @@ -0,0 +1,118 @@ + subroutine StomatalConductance(pco2s,rehulfsurf,gammas, + & pvapordef_s,rayDzero,assim_net,istommodel, + & stomintercept,stomslope,gswmod) + implicit none + +!=====================Inputs=================================== +! pvapordef_s: water vapor partial pressure deficit at the leaf surface [Pa] +! istommodel: which stomatal conductance model to use +! 1 = Ball - Berry Model +! 2 = Ray Leuning model using leaf surface CO2 concentration +! 3 = Belinda E. Medlyn model +! 4 = Dewar model +! stomintercept: Interception in the Ball - Berry model or the Leuning version [mol H2O m-2 s-1] +! stomslope: Slope in the Ball - Berry model or the leuning version [--] +! rayDzero: D0 in the Ray Leuning modified Ball - Berry Model [Pa] +! +! assim_net: net rate of CO2 uptake per unit leaf area +! calculated from the biochemical model[umol m-2 s-1] +! gammas: CO2 compensation point (ppm) +! pco2s: CO2 concentration at the leaf surface or internal CO2 (ppm) +! rehulfsurf: relative humidity at the leaf surface [0-1] + + integer istommodel + double precision pco2s,rehulfsurf,gammas, + & pvapordef_s,rayDzero,stomintercept, + & stomslope,assim_net + +!=====================Outputs================================= +! gswmod: stomatal conductance for water vapor calculated +! from stomatal conductance model [mol m-2 s-1] + double precision gswmod + + if(istommodel.eq.1)then +! Ball - Berry model + gswmod=stomintercept+stomslope*assim_net* + & rehulfsurf/pco2s + gswmod=dmax1(gswmod,stomintercept) + endif + if(istommodel.eq.2)then +! Ray Leuning model using leaf surface CO2 or internal CO2 + gswmod=stomintercept+stomslope*assim_net/ + & ((pco2s-gammas)*(1.0d0+pvapordef_s/rayDzero)) + gswmod=dmax1(gswmod,stomintercept) + endif + if(istommodel.eq.3)then +!Belinda Medlyn model + gswmod=stomintercept+(1.0d0+stomslope/dsqrt(1.0d-3*pvapordef_s)) + &*assim_net/pco2s + gswmod=dmax1(gswmod,stomintercept) + endif + if(istommodel.eq.4)then +! Dewar model + gswmod=(stomintercept+stomslope*assim_net)/ + & (pco2s*(1.0d0+pvapordef_s/rayDzero)) + gswmod=dmax1(gswmod,stomintercept) + endif + + return + end subroutine StomatalConductance + + subroutine Der_StomatalConductance(pco2s,rehulfsurf, + & gammas,pvapordef_s,rayDzero,assim_net,istommodel, + & stomintercept,stomslope,derivb,derivslope,derivd0) + implicit none + +!=====================Inputs=================================== +! pvapordef_s: water vapor partial pressure deficit at the leaf surface [Pa] +! istommodel: which stomatal conductance model to use +! 1 = Ball - Berry Model +! 2 = Ray Leuning model using leaf surface CO2 concentration +! 3 = Belinda Medlyn model +! 4 = Dewar model +! stomintercept: Interception in the Ball - Berry model or the Leuning version [mol H2O m-2 s-1] +! stomslope: Slope in the Ball - Berry model or the leuning version [--] +! rayDzero: D0 in the Ray Leuning modified Ball - Berry Model [Pa] +! +! assim_net: net rate of CO2 uptake per unit leaf area +! calculated from the biochemical model[umol m-2 s-1] +! gammas: CO2 compensation point (ppm) +! pco2s: CO2 concentration at the leaf surface or internal CO2 (ppm) +! rehulfsurf: relative humidity at the leaf surface [0-1] + + integer istommodel + double precision pco2s,rehulfsurf,gammas, + & pvapordef_s,rayDzero,stomintercept, + & stomslope,assim_net + +!=====================Outputs================================= +! gswmod: stomatal conductance for water vapor calculated +! from stomatal conductance model [mol m-2 s-1] + double precision derivb,derivslope,derivd0 + + derivb=1.0d0 + if(istommodel.eq.1)then +! Ball - Berry model + derivslope=assim_net*rehulfsurf/pco2s + endif + if(istommodel.eq.2)then +! Ray Leuning model using leaf surface CO2 + derivslope=assim_net/ + & ((pco2s-gammas)*(1.0d0+pvapordef_s/rayDzero)) + derivd0=(stomslope*assim_net/(pco2s-gammas))* + & pvapordef_s/((rayDzero+pvapordef_s)**2.0d0) + endif + if(istommodel.eq.3)then +! Belinda E. Medlyn model + derivslope=assim_net/(pco2s*dsqrt(1.0d-3*pvapordef_s)) + endif + if(istommodel.eq.4)then +! Ray Leuning model using leaf surface partial pressure + derivb=1.0d0/(pco2s*(1.0d0+pvapordef_s/rayDzero)) + derivslope=assim_net/ + & (pco2s*(1.0d0+pvapordef_s/rayDzero)) + derivd0=((stomintercept+stomslope*assim_net)/pco2s)* + & pvapordef_s/((rayDzero+pvapordef_s)**2.0d0) + endif + return + end subroutine Der_StomatalConductance diff --git a/leafres/testarea/ToLeafGasOptimization.f b/leafres/testarea/ToLeafGasOptimization.f new file mode 100644 index 0000000..7d2d147 --- /dev/null +++ b/leafres/testarea/ToLeafGasOptimization.f @@ -0,0 +1,577 @@ + subroutine ToLeafGasOptimization(ntotfiles,ACidata,dataunit, + &spareunit,datapath,indexunit,ierr) + implicit none +!--------------All inputs except for ierr. Outputs are written to files---------------- + integer ntotfiles,dataunit,spareunit,ierr(2),indexunit(20) +!ierr(1)=0, ok, >1 input data out of range +!ierr(2) specifies in which input file, the data is out of range + character*100 datapath,ACidata(ntotfiles) +!------------------------------------------------------------------------------- + integer ntotpoints,npoints(ntotfiles),i,j,k,n,curveno(ntotfiles), + &iobs,maxobs,nmax,iwarning,warningunit,isitmassbased(ntotfiles), + &iprintheader(ntotfiles),ivector(1000),startline + parameter(maxobs=2000,nmax=100) + character*100 sample(ntotfiles) + character*50 chartime,siteID(ntotfiles),species(ntotfiles),ftime, + &longchar1*50000,longchar*5000,charvars(500), + &woodporosity(ntotfiles) + double precision esat,Latitude(ntotfiles),Longitude(ntotfiles), + &Elevation(ntotfiles),yearsampled(ntotfiles),sampledoy(ntotfiles), + &GrowingSeasonStart(ntotfiles),GrowingSeasonEnd(ntotfiles), + &standage(ntotfiles),CanopyHeight(ntotfiles), + &LeafAreaIndex(ntotfiles),MeanTimeBtwnSteadyReadings(ntotfiles), + &SampleHeight(ntotfiles),Needleage(ntotfiles), + &specificLAI(ntotfiles),nitrogencontent(ntotfiles), + &carboncontent(ntotfiles),avetimeresolution(ntotfiles), + &avetimesampled(ntotfiles),phoscontent(ntotfiles), + &sapwooddensity(ntotfiles),leafratio(ntotfiles), + &stom_COND_mol,CO2i_ppm,transp_mmol,vpdl_KPa,BLCond,Tair_oC, + &Tleaf_oC,CO2chamber_ppm,H2OS_mmol,RH_S100,PARi_umol,Press_KPa, + &oxygeni_KPa,PNcor_umol,uncorphoto,chamberarea,stmrad,tblk,co2r, + &h2or,rh_r,flow,paro,csmch,hsmch,stablef,listatus,phips2, + &ambientvaporpres,pari(ntotfiles,maxobs), + &templeaf(ntotfiles,maxobs),pres_air(ntotfiles,maxobs), + &yAnet(ntotfiles,maxobs),po2i(ntotfiles,maxobs), + &trmmol(ntotfiles,maxobs),gswmeas(ntotfiles,maxobs), + &vpdl(ntotfiles,maxobs),tempair(ntotfiles,maxobs), + &eambient(ntotfiles,maxobs),xpco2i_ppm(ntotfiles,maxobs), + &xpco2i(ntotfiles,maxobs),co2a_ppm(ntotfiles,maxobs), + &pco2ambient(ntotfiles,maxobs),sampletime(ntotfiles,maxobs), + &chlflphips2(ntotfiles,maxobs),CurveTypeID(ntotfiles,maxobs), + &fo_pam(ntotfiles,maxobs),fm_pam(ntotfiles,maxobs), + &fs_pam(ntotfiles,maxobs),pam_measlight(ntotfiles,maxobs), + &vectorhorse(maxobs),stargamma25_usr(ntotfiles), + &fkc25_usr(ntotfiles),fko25_usr(ntotfiles),tissuearea,tissuemass, + &rdlight25_usr(ntotfiles),alpha25_usr(ntotfiles),datumlimit, + &resistwp25_usr(ntotfiles),resistch25_usr(ntotfiles),gtc,gtw, + &term,term1,H2OLeaf_mmol,fo_fluoresce,fm_fluoresce,fs_fluoresce, + &f_measlight,stdpar,fmeanpar,xminpar,xmaxpar, + &stdco2,fmeanco2,xminco2,xmaxco2 +! + warningunit=indexunit(10) + ierr(1)=0 + +! open(unit=121,file='sphagnumdata.csv') +! write(121,'(200A)')'name,','hhmmss,','no,','time,','datumlimit,', +! &'stom_COND_mol,','CO2chamber_ppm,','CO2i_ppm,','PARi_umol,', +! &'Tleaf_oC,','Tair_oC,','transp_mmol,','PNcor_umol,','H2OS_mmol,', +! &'RH_S100' + +!We read all files at once + do 10 i=1,ntotfiles + isitmassbased(i)=0 + iwarning=0 + ierr(2)=i + npoints(i)=0 + sample(i)=trim(ACidata(i)) +!fill any blank spaces in sample(i) with '_' +1 j=index(trim(sample(i)),' ') + if(j.gt.0)then + sample(i)(j:j)='_' + goto 1 + endif + curveno(i)=i +! +!======================================================================================================================== +!In early 2015, the following section of code is added to allow flexibity for the starting rows to be used for metadata. +!There is no need for a strict number of rows for metadata because the main data section is now determined automatically. +!Locate the rows for the actual data + open(unit=dataunit,file= + &trim(datapath)//trim(ACidata(i))//'middle') + open(unit=spareunit,file=trim(datapath)//trim(ACidata(i))) + read(spareunit,fmt=300,err=40,end=40)longchar1 + rewind(spareunit) +2 read(spareunit,fmt=300,err=40,end=5)longchar1 +3 k=index(longchar1,char(13)) + if(k.gt.0)then +!DOS text format, convert it to unix format + longchar1(k:k+len(char(10))-1)=char(10) + goto 3 + endif + write(dataunit,340)trim(longchar1) + goto 2 +5 close(spareunit) + rewind(dataunit) + + open(unit=spareunit,file= + &trim(datapath)//trim(ACidata(i))//'clean') +7 read(dataunit,fmt=310,err=40,end=9)longchar + if(longchar.eq.''.or.longchar.eq.' ')goto 7 + call charlineparser(longchar,nmax,charvars,n) + if(n.eq.0)goto 7 + write(spareunit,340)trim(longchar) + goto 7 +9 rewind(spareunit) + close(dataunit,status='delete') + + j=0 +500 read(spareunit,fmt=310,err=40,end=600)longchar + call charlineparser(longchar,nmax,charvars,n) + j=j+1 + ivector(j)=n + goto 500 +600 if(j.lt.12)then + close(spareunit,status='delete') + goto 630 + else + rewind(spareunit) + endif + startline=0 +610 startline=startline+1 + if(startline.gt.j-11)goto 40 + n=0 + if(ivector(startline).ne.ivector(startline+1))n=1 + if(ivector(startline).ne.ivector(startline+2))n=1 + if(ivector(startline+2).lt.15.or.ivector(startline+2).gt.25)n=1 + + if(ivector(startline+3).ne.ivector(startline+4))n=1 + if(ivector(startline+3).ne.ivector(startline+5))n=1 + if(ivector(startline+5).lt.5.or.ivector(startline+5).gt.10)n=1 + + if(ivector(startline+6).ne.ivector(startline+7))n=1 + if(ivector(startline+6).ne.ivector(startline+8))n=1 + if(ivector(startline+8).ne.ivector(startline+9))n=1 + if(ivector(startline+8).ne.ivector(startline+10))n=1 + if(ivector(startline+8).ne.ivector(startline+11))n=1 + if(ivector(startline+8).lt.25)n=1 + if(n.eq.1)goto 610 + +!startline is the line 'Elevation,SampleYear,SampleDayOfYear.....' +!In general +!Line 1-10 describe the general information about the data +!Line 11-12 are the header lines for line 13 +!Line 13 gives the site information and the data about the leaf sampled +!Line 14-15 are the header lines for lines 16 +!Line 16 user-supplied parameter values +!Line 17-18 are the header lines for lines 19 and higer +!Line 19 and higher: actual gas exchange data + do j=1,startline+1 + read(spareunit,*) + enddo +!========================================================================================================================= + read(spareunit,fmt=310,err=13)longchar + call charlineparser(longchar,nmax,charvars,n) + do j=n+1,nmax + charvars(j)='-9999' + enddo + siteID(i)=trim(charvars(1)) + species(i)=trim(charvars(12)) + woodporosity(i)=trim(charvars(20)) + n=len(trim(charvars(2))) + call extCharToFloatNum(n,charvars(2),Latitude(i),j) + n=len(trim(charvars(3))) + call extCharToFloatNum(n,charvars(3),Longitude(i),j) + n=len(trim(charvars(4))) + call extCharToFloatNum(n,charvars(4),Elevation(i),j) + n=len(trim(charvars(5))) + call extCharToFloatNum(n,charvars(5),yearsampled(i),j) + n=len(trim(charvars(6))) + call extCharToFloatNum(n,charvars(6),sampledoy(i),j) + n=len(trim(charvars(7))) + call extCharToFloatNum(n,charvars(7),GrowingSeasonStart(i),j) + n=len(trim(charvars(8))) + call extCharToFloatNum(n,charvars(8),GrowingSeasonEnd(i),j) + n=len(trim(charvars(9))) + call extCharToFloatNum(n,charvars(9),standage(i),j) + n=len(trim(charvars(10))) + call extCharToFloatNum(n,charvars(10),CanopyHeight(i),j) + n=len(trim(charvars(11))) + call extCharToFloatNum(n,charvars(11),LeafAreaIndex(i),j) + n=len(trim(charvars(13))) + call extCharToFloatNum(n,charvars(13), + &MeanTimeBtwnSteadyReadings(i),j) + n=len(trim(charvars(14))) + call extCharToFloatNum(n,charvars(14),SampleHeight(i),j) + n=len(trim(charvars(15))) + call extCharToFloatNum(n,charvars(15),Needleage(i),j) + n=len(trim(charvars(16))) + call extCharToFloatNum(n,charvars(16),specificLAI(i),j) + n=len(trim(charvars(17))) + call extCharToFloatNum(n,charvars(17),nitrogencontent(i),j) + n=len(trim(charvars(18))) + call extCharToFloatNum(n,charvars(18),carboncontent(i),j) + n=len(trim(charvars(19))) + call extCharToFloatNum(n,charvars(19),phoscontent(i),j) + n=len(trim(charvars(21))) + call extCharToFloatNum(n,charvars(21),sapwooddensity(i),j) + n=len(trim(charvars(22))) + call extCharToFloatNum(n,charvars(22),leafratio(i),j) + do j=1,2 + read(spareunit,*) + enddo + read(spareunit,fmt=310,err=36)longchar + call charlineparser(longchar,nmax,charvars,n) + do j=n+1,nmax + charvars(j)='-9999' + enddo + n=len(trim(charvars(1))) + call extCharToFloatNum(n,charvars(1),stargamma25_usr(i),j) + n=len(trim(charvars(2))) + call extCharToFloatNum(n,charvars(2),fkc25_usr(i),j) + n=len(trim(charvars(3))) + call extCharToFloatNum(n,charvars(3),fko25_usr(i),j) + n=len(trim(charvars(4))) + call extCharToFloatNum(n,charvars(4),alpha25_usr(i),j) + n=len(trim(charvars(5))) + call extCharToFloatNum(n,charvars(5),rdlight25_usr(i),j) + n=len(trim(charvars(6))) + call extCharToFloatNum(n,charvars(6),resistwp25_usr(i),j) + n=len(trim(charvars(7))) + call extCharToFloatNum(n,charvars(7),resistch25_usr(i),j) + if(stargamma25_usr(i).lt.0.0d0.or. + &stargamma25_usr(i).gt.500.0d0)stargamma25_usr(i)=-9999.0d0 + if(fkc25_usr(i).lt.0.0d0.or.fkc25_usr(i).gt.5000.0d0) + &fkc25_usr(i)=-9999.0d0 + if(fko25_usr(i).lt.0.0d0.or.fko25_usr(i).gt.90000.0d0) + &fko25_usr(i)=-9999.0d0 + if(alpha25_usr(i).lt.0.0d0.or.alpha25_usr(i).gt.1.0d0) + &alpha25_usr(i)=-9999.0d0 + if(rdlight25_usr(i).lt.0.0d0.or.rdlight25_usr(i).gt.100.0d0) + &rdlight25_usr(i)=-9999.0d0 + if(resistwp25_usr(i).lt.0.0d0.or.resistwp25_usr(i).gt.10000.0d0) + &resistwp25_usr(i)=-9999.0d0 + if(resistwp25_usr(i).lt.0.0d0.or.resistwp25_usr(i).gt.10000.0d0) + &resistch25_usr(i)=-9999.0d0 + do j=1,2 + read(spareunit,*) + enddo +20 read(spareunit,fmt=310,err=39,end=100)longchar + call charlineparser(longchar,nmax,charvars,n) + if(n.le.25)goto 20 + do j=n+1,nmax + charvars(j)='-9999' + enddo + chartime=trim(charvars(2)) + ftime=trim(charvars(3)) + n=len(trim(charvars(1))) + call extCharToFloatNum(n,charvars(1),term,j) + iObs=idnint(term) + n=len(trim(charvars(4))) + call extCharToFloatNum(n,charvars(4),uncorphoto,j) + n=len(trim(charvars(5))) + call extCharToFloatNum(n,charvars(5),PNcor_umol,j) + if(dabs(PNcor_umol+9999.0d0).lt.1.0d-4)PNcor_umol=uncorphoto + n=len(trim(charvars(6))) + call extCharToFloatNum(n,charvars(6),stom_COND_mol,j) + n=len(trim(charvars(7))) + call extCharToFloatNum(n,charvars(7),CO2i_ppm,j) + n=len(trim(charvars(8))) + call extCharToFloatNum(n,charvars(8),transp_mmol,j) + n=len(trim(charvars(9))) + call extCharToFloatNum(n,charvars(9),vpdl_KPa,j) + n=len(trim(charvars(10))) + call extCharToFloatNum(n,charvars(10),chamberarea,j) + n=len(trim(charvars(11))) + call extCharToFloatNum(n,charvars(11),stmrad,j) + n=len(trim(charvars(12))) + call extCharToFloatNum(n,charvars(12),BLCond,j) + n=len(trim(charvars(13))) + call extCharToFloatNum(n,charvars(13),Tair_oC,j) + n=len(trim(charvars(14))) + call extCharToFloatNum(n,charvars(14),Tleaf_oC,j) + n=len(trim(charvars(15))) + call extCharToFloatNum(n,charvars(15),tblk,j) + n=len(trim(charvars(16))) + call extCharToFloatNum(n,charvars(16),co2r,j) + n=len(trim(charvars(17))) + call extCharToFloatNum(n,charvars(17),CO2chamber_ppm,j) + n=len(trim(charvars(18))) + call extCharToFloatNum(n,charvars(18),h2or,j) + n=len(trim(charvars(19))) + call extCharToFloatNum(n,charvars(19),H2OS_mmol,j) + n=len(trim(charvars(20))) + call extCharToFloatNum(n,charvars(20),rh_r,j) + n=len(trim(charvars(21))) + call extCharToFloatNum(n,charvars(21),RH_S100,j) + n=len(trim(charvars(22))) + call extCharToFloatNum(n,charvars(22),flow,j) + n=len(trim(charvars(23))) + call extCharToFloatNum(n,charvars(23),PARi_umol,j) + n=len(trim(charvars(24))) + call extCharToFloatNum(n,charvars(24),paro,j) + n=len(trim(charvars(25))) + call extCharToFloatNum(n,charvars(25),Press_KPa,j) + n=len(trim(charvars(26))) + call extCharToFloatNum(n,charvars(26),csmch,j) + n=len(trim(charvars(27))) + call extCharToFloatNum(n,charvars(27),hsmch,j) + n=len(trim(charvars(28))) + call extCharToFloatNum(n,charvars(28),stablef,j) + n=len(trim(charvars(29))) + call extCharToFloatNum(n,charvars(29),listatus,j) + n=len(trim(charvars(30))) + call extCharToFloatNum(n,charvars(30),phips2,j) + n=len(trim(charvars(31))) + call extCharToFloatNum(n,charvars(31),oxygeni_KPa,j) + n=len(trim(charvars(32))) + call extCharToFloatNum(n,charvars(32),datumlimit,j) + n=len(trim(charvars(33))) + call extCharToFloatNum(n,charvars(33),tissuearea,j) + n=len(trim(charvars(34))) + call extCharToFloatNum(n,charvars(34),tissuemass,j) +! + n=len(trim(charvars(35))) + call extCharToFloatNum(n,charvars(35),fo_fluoresce,j) + n=len(trim(charvars(36))) + call extCharToFloatNum(n,charvars(36),fm_fluoresce,j) + n=len(trim(charvars(37))) + call extCharToFloatNum(n,charvars(37),fs_fluoresce,j) + n=len(trim(charvars(38))) + call extCharToFloatNum(n,charvars(38),f_measlight,j) + + if(tissuearea.gt.0.0d0.and.tissuemass.gt.0.0d0)then +!We assume the user requires mass-based calculations. We convert net photosynthesis, +!transpiration, conductance and PAR from area basis to mass basis. All fitted parameters +!are mass-based. However, mixing area- and mass- based calculations is not allowed. + if(npoints(i).gt.0.and.isitmassbased(i).eq.0)goto 34 + isitmassbased(i)=1 +!Convert PAR from umol/m2/s to umol/kg/s. tissuearea is in cm2 and tissuemass in in g + PARi_umol=PARi_umol*tissuearea/(tissuemass*10.0d0) + term=(H2OS_mmol-h2or)/(1000.0d0-H2OS_mmol) + transp_mmol=(flow/tissuemass)*term + term=co2r-CO2chamber_ppm*(1000.0d0-h2or)/(1000.0d0-H2OS_mmol) + PNcor_umol=(1.0d-3*flow/tissuemass)*term + H2OLeaf_mmol=esat(Tleaf_oC+273.15d0,Press_KPa*1000.0d0)/ + &Press_KPa +!gtw is the conductance for water vapor between the water film and free air + gtw=transp_mmol*1.0d-3*(1.0d+3-(H2OLeaf_mmol+H2OS_mmol)/2.0d0) + &/(H2OLeaf_mmol-H2OS_mmol) +!we assume no stomatal conductance. We use the ratio of diffusivities of CO2 and water vapor in air (1.6), +!rather than the ratio of diffusivities of CO2 and water vapor in the boundary layer (1.37) as the latter applies +!to Pohlhausen analysis of mass transfer from a plate in laminar parallel flows which is probably not true +!for Sphagnum tissues. + gtc=gtw/1.6d0 +!we set treat gtw as if it is stomatal conductance. + stom_COND_mol=gtw + CO2i_ppm=((gtc-1.0d-3*transp_mmol/2.0d0)*CO2chamber_ppm- + &PNcor_umol)/(gtc-1.0d-3*transp_mmol/2.0d0) + else + if(isitmassbased(i).ne.0)goto 34 + endif + if(isitmassbased(i).eq.0)then + term=-100.0d0 + term1=200.0d0 + else + term=-9998.0d0 + term1=1.0d+10 + endif + if(PNcor_umol.lt.term.or.PNcor_umol.gt.term1)then + ierr(1)=1 + if(fm_fluoresce.le.0.0d0)return + else + if(transp_mmol.gt.0.0d0.and.stom_COND_mol.gt.0.0d0 + &.and.BLCond.gt.0.0d0)then +!use the corrected PN to calculate the Ci +!we assume BLCond already takes into account the stomatal ratio. +!for Missouri MOFLUX data, only 2004-2008 data need this correction + gtc=1.0d0/(1.6d0/stom_COND_mol+1.37d0/BLCond) + term=((gtc-transp_mmol*0.001d0/2.0d0)*CO2chamber_ppm + &-PNcor_umol)/(gtc+transp_mmol*0.001d0/2.0d0) + if(dabs(term-CO2i_ppm).gt.5.0d0)then + if(iwarning.eq.0)then + write(warningunit,*)'In file ',trim(sample(i)) + write(warningunit,*)'Provided CO2i values do not agree with other + &input variables. Make sure input data are ok' + write(warningunit,*)'Original CO2i',',','Calculated CO2i' + iwarning=1 + endif + write(warningunit,*)CO2i_ppm,',',term + endif +! CO2i_ppm=term + endif + endif + if(CO2i_ppm.le.0.0d0.or.CO2i_ppm.gt.10000.0d0)then +! ierr(1)=2 +! return + if(fm_fluoresce.le.0.0d0)goto 20 + endif + if(Tleaf_oC.lt.-50.0d0.or.Tleaf_oC.gt.100.0d0)then + ierr(1)=3 + if(fm_fluoresce.le.0.0d0)return + endif + if(isitmassbased(i).eq.0)then + term1=1.0d+5 + else + term1=1.0d+10 + endif + if(PARi_umol.lt.-10.01d0.or.PARi_umol.gt.term1)then + ierr(1)=4 + return + else + PARi_umol=dmax1(0.0d0,PARi_umol) + endif + if(Press_KPa.lt.50.0d0.or.Press_KPa.gt.150.0d0)then + Press_KPa=98.9d0 +! ierr(1)=5 +! return + endif + if(Tair_oC.lt.-50.0d0.or.Tair_oC.gt.100.0d0)then + Tair_oC=Tleaf_oC + endif + if(vpdl_KPa.lt.0.0d0.or.vpdl_KPa.gt.1000.0d0)then + if(H2OS_mmol.gt.0.0d0)then + term=H2OS_mmol*0.001d0/(1.0d0+H2OS_mmol*0.001d0) + term=term*Press_KPa + vpdl_KPa=esat((Tleaf_oC+273.15d0),(Press_KPa*1000.0d0)) + vpdl_KPa=vpdl_KPa*0.001d0-term + else + if(RH_S100.ge.0.0d0.and.RH_S100.le.100.0d0)then + term=0.01d0*RH_S100* + & esat((Tair_oC+273.15d0),(Press_KPa*1000.0d0)) + vpdl_KPa=0.001d0*( + & esat((Tleaf_oC+273.15d0),(Press_KPa*1000.0d0))-term) + else + vpdl_KPa=1.6d0 + endif + endif + endif + if(H2OS_mmol.lt.0.0d0)then + if(RH_S100.lt.0.0d0.or.RH_S100.gt.100.0d0)then + ambientvaporpres=esat((Tair_oC+273.15d0), + & (Press_KPa*1000.0d0))-vpdl_KPa*1000.0d0 + ambientvaporpres=dmax1(0.0d0,ambientvaporpres) + else + ambientvaporpres=0.01d0*RH_S100*esat((Tair_oC+273.15d0), + & (Press_KPa*1000.0d0)) + endif + else + ambientvaporpres=H2OS_mmol*0.001d0/(1.0d0+H2OS_mmol*0.001d0) + ambientvaporpres=ambientvaporpres*Press_KPa*1000.0d0 + endif + npoints(i)=npoints(i)+1 + pari(i,npoints(i))=PARi_umol + if(Tleaf_oC.gt.-50.0d0.and.Tleaf_oC.lt.100.0d0)then + templeaf(i,npoints(i))=Tleaf_oC+273.15d0 + else + templeaf(i,npoints(i))=-9999.0d0 + endif + pres_air(i,npoints(i))=Press_KPa*1000.0d0 + yAnet(i,npoints(i))=PNcor_umol + if(oxygeni_KPa.le.0.0d0.or.oxygeni_KPa.ge.Press_KPa)then + po2i(i,npoints(i))=0.2095d0*pres_air(i,npoints(i)) + else + po2i(i,npoints(i))=oxygeni_KPa*1000.0d0 + endif + trmmol(i,npoints(i))=transp_mmol + gswmeas(i,npoints(i))=stom_COND_mol + vpdl(i,npoints(i))=vpdl_KPa*1000.0d0 + if(Tair_oC.gt.-50.0d0.and.Tair_oC.lt.100.0d0)then + tempair(i,npoints(i))=Tair_oC+273.15d0 + else + tempair(i,npoints(i))=-9999.0d0 + endif + eambient(i,npoints(i))=ambientvaporpres + chlflphips2(i,npoints(i))=phips2 + fo_pam(i,npoints(i))=fo_fluoresce + fm_pam(i,npoints(i))=fm_fluoresce + fs_pam(i,npoints(i))=fs_fluoresce + pam_measlight(i,npoints(i))=f_measlight +!the unit of CO2 is in umol/mol. We use both umol/mol and Pa. Li-Cor 6400 +!measures CO2 on a moist air basis. + xpco2i_ppm(i,npoints(i))=CO2i_ppm + xpco2i(i,npoints(i))=CO2i_ppm* + & pres_air(i,npoints(i))*1.0d-6 + if(CO2chamber_ppm.gt.0.0d0)then + co2a_ppm(i,npoints(i))=CO2chamber_ppm + pco2ambient(i,npoints(i))=CO2chamber_ppm* + & pres_air(i,npoints(i))*1.0d-6 + else + pco2ambient(i,npoints(i))=-9999.0d0 + co2a_ppm(i,npoints(i))=-9999.0d0 + endif + CurveTypeID(i,npoints(i))=datumlimit + call CharToNumeric(chartime,term) + sampletime(i,npoints(i))=term + goto 20 +100 close(spareunit,status='delete') + do j=1,npoints(i) + vectorhorse(j)=sampletime(i,j) + call time_resolution(npoints(i),vectorhorse, + & avetimeresolution(i),avetimesampled(i)) + enddo +630 continue +10 enddo + iprintheader(1)=1 + do i=2,ntotfiles + if(isitmassbased(i).eq.isitmassbased(i-1))then + iprintheader(i)=0 + else + iprintheader(i)=1 + endif + enddo + k=1 + do i=1,ntotfiles + if(k.eq.1.or.iprintheader(i).eq.1)then + call LeafGasPrintToFiles(isitmassbased(i:i),indexunit) + k=0 + endif + if(npoints(i).lt.3)goto 1112 +!----------------------------------------------------- +!detect A/Ci or light response curves with many points but no curve types are given + if(npoints(i).ge.7)then + j=0 + do n=1,npoints(i) + if(CurveTypeID(i,n).gt.0)j=1 + enddo + if(j.eq.0)then + call stdmaxmeanmin(npoints(i),pari(i:i,1:npoints(i)), + &stdpar,fmeanpar,xminpar,xmaxpar) + stdpar=100.0d0*(xmaxpar-xminpar)/fmeanpar + call stdmaxmeanmin(npoints(i),pco2ambient(i:i,1:npoints(i)), + &stdco2,fmeanco2,xminco2,xmaxco2) + stdco2=100.0d0*(xmaxco2-xminco2)/fmeanco2 + if(stdpar.lt.5.0d0.and.stdco2.gt.5.0d0)then +!ACi curve + do n=1,npoints(i) + CurveTypeID(i,n)=11 + enddo + else + if(stdpar.gt.5.0d0.and.stdco2.lt.5.0d0)then +!light response curve + do n=1,npoints(i) + CurveTypeID(i,n)=31 + enddo + endif + endif + endif + endif +!------------------------------------------------------ + call SetUpLeafGasFit(curveno(i:i),sample(i:i),npoints(i:i), + &CurveTypeID(i:i,1:npoints(i)),yAnet(i:i,1:npoints(i)), + &xpco2i(i:i,1:npoints(i)),templeaf(i:i,1:npoints(i)), + &pari(i:i,1:npoints(i)),pres_air(i:i,1:npoints(i)), + &po2i(i:i,1:npoints(i)),chlflphips2(i:i,1:npoints(i)), + &pco2ambient(i:i,1:npoints(i)),trmmol(i:i,1:npoints(i)), + &gswmeas(i:i,1:npoints(i)),vpdl(i:i,1:npoints(i)), + &tempair(i:i,1:npoints(i)),eambient(i:i,1:npoints(i)), + &fo_pam(i:i,1:npoints(i)),fm_pam(i:i,1:npoints(i)), + &fs_pam(i:i,1:npoints(i)),pam_measlight(i:i,1:npoints(i)), + &stargamma25_usr(i:i),fkc25_usr(i:i),fko25_usr(i:i), + &rdlight25_usr(i:i),alpha25_usr(i:i),resistwp25_usr(i:i), + &resistch25_usr(i:i),isitmassbased(i:i),indexunit, + &siteID(i:i),Latitude(i:i),Longitude(i:i),Elevation(i:i), + &yearsampled(i:i),sampledoy(i:i),GrowingSeasonStart(i:i), + &GrowingSeasonEnd(i:i),standage(i:i),CanopyHeight(i:i), + &LeafAreaIndex(i:i),species(i:i),avetimeresolution(i:i), + &avetimesampled(i:i),SampleHeight(i:i),Needleage(i:i), + &specificLAI(i:i),nitrogencontent(i:i),carboncontent(i:i), + &phoscontent(i:i),woodporosity(i:i),sapwooddensity(i:i), + &leafratio(i:i)) +1112 continue + enddo + return +13 ierr(1)=13 + return +34 ierr(1)=34 + return +36 ierr(1)=36 + return +39 ierr(1)=39 + return +40 ierr(1)=40 + return +300 format(a50000) +310 format(a5000) +340 format(a) + end subroutine ToLeafGasOptimization +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& diff --git a/leafres/testarea/UnivParamsAlloc.f b/leafres/testarea/UnivParamsAlloc.f new file mode 100644 index 0000000..f5ea8ad --- /dev/null +++ b/leafres/testarea/UnivParamsAlloc.f @@ -0,0 +1,87 @@ + subroutine UnivParamsAlloc(iswitch) + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' + integer iswitch,i +!ilimittype=1: Rubisco,RuBp and TPU limitations +!ilimittype=2: Rubisco and RuBp limitations only +!ilimittype=3: Rubisco and TPU limitations only +!ilimittype=4: RuBp and TPU limitations only +!ilimittype=5: Rubisco limitation only +!ilimittype=6: RuBp limitation only +!ilimittype=7: TPU limitation only +!iswitch=1: initilize the array of univparams +!iswitch=2: allcoate the array of univparams to corresponding parameters + if(iswitch.eq.2)then + resistwp25=univparams(1) + resistch25=univparams(2) + rdlight25=univparams(3) + stargamma25=univparams(4) + vcmax25=univparams(5) + fkc25=univparams(6) + fko25=univparams(7) + fjmax25=univparams(8) + tpu25=univparams(9) + alpha25=univparams(10) + phifactor=univparams(11) + thetafactor=univparams(12) + betaPSII=univparams(13) + ha_darkresp=univparams(14) + ha_stargamma=univparams(15) + ha_vcmax=univparams(16) + ha_jmax=univparams(17) + ha_tpu=univparams(18) + ha_gmeso=univparams(19) + return + else + do i=1,ntotunivparams +!Initialize ifixunivparams to keep all parameters unchanged + ifixunivparams(i)=0 + enddo +! + if(Currentiknowlimit.eq.-1)then +!Fluorescence only fit + if(idorwp.eq.1)ifixunivparams(1)=1 + if(idorch.eq.1)ifixunivparams(2)=1 + if(idord.eq.1)ifixunivparams(3)=1 + if(idostargamma.eq.1)ifixunivparams(4)=1 + if(idobetaPSII.eq.1)ifixunivparams(13)=1 + if(idoha_darkresp.eq.1)ifixunivparams(14)=1 + if(idoha_stargamma.eq.1)ifixunivparams(15)=1 + if(idoha_gmeso.eq.1)ifixunivparams(19)=1 + return + endif +! + if(idorwp.eq.1)ifixunivparams(1)=1 + if(idorch.eq.1)ifixunivparams(2)=1 + if(idord.eq.1)ifixunivparams(3)=1 + if(idostargamma.eq.1)ifixunivparams(4)=1 + if(Currentilimittype.le.3.or.Currentilimittype.eq.5)then +!Rubisco limit involved + ifixunivparams(5)=1 + if(idokc.eq.1)ifixunivparams(6)=1 + if(idoko.eq.1)ifixunivparams(7)=1 + if(idoha_vcmax)ifixunivparams(16)=1 + endif + if(Currentilimittype.le.2.or.Currentilimittype.eq.4.or. + &Currentilimittype.eq.6)then +!RuBp limit involved + ifixunivparams(8)=1 + if(idoha_jmax.eq.1)ifixunivparams(17)=1 + if(idophifactor.eq.1)ifixunivparams(11)=1 + if(idothetafactor.eq.1)ifixunivparams(12)=1 + if(idobetaPSII.eq.1)ifixunivparams(13)=1 + endif + if(Currentilimittype.eq.1.or.Currentilimittype.eq.3.or. + &Currentilimittype.eq.4.or.Currentilimittype.eq.7)then +!tpu limit involved + ifixunivparams(9)=1 + if(idoalpha.eq.1)ifixunivparams(10)=1 + if(idoha_tpu.eq.1)ifixunivparams(18)=1 + endif + if(idoha_darkresp.eq.1)ifixunivparams(14)=1 + if(idoha_stargamma.eq.1)ifixunivparams(15)=1 + if(idoha_gmeso.eq.1)ifixunivparams(19)=1 + return + endif + end subroutine UnivParamsAlloc diff --git a/leafres/testarea/UnivPhotoFit.f b/leafres/testarea/UnivPhotoFit.f new file mode 100644 index 0000000..390fbbb --- /dev/null +++ b/leafres/testarea/UnivPhotoFit.f @@ -0,0 +1,409 @@ + subroutine UnivPhotoFit() + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' + integer i,j,k,Priornumrubis,Priornumrubp,Priornumtpu, + &Currentnumrubis,Currentnumrubp,Currentnumtpu,Postnumrubis, + &Postnumrubp,Postnumtpu,Postilimittype + double precision term,term1,term2,term3,term4,term5,term6, + &term7,term8,term9 +! + if(Prioriknowlimit.eq.1.or.Prioriknowlimit.eq.2)then + ntotsamples=0 + do i=1,nFixedPoints + ntotsamples=ntotsamples+1 + Prioriphotolimit(ntotsamples)=Fixediphotolimit(i) + enddo + do j=1,numACicurves + do i=1,nACiPoints(j) + ntotsamples=ntotsamples+1 + Prioriphotolimit(ntotsamples)=ACiiphotolimit(i,j) + enddo + enddo + do j=1,numALightcurves + do i=1,nALightPoints(j) + ntotsamples=ntotsamples+1 + Prioriphotolimit(ntotsamples)=ALightiphotolimit(i,j) + enddo + enddo + do i=1,nFreePoints + ntotsamples=ntotsamples+1 + Prioriphotolimit(ntotsamples)=Freeiphotolimit(i) + enddo + call ilimittypestats(ntotsamples,Prioriphotolimit, + &Priorilimittype,Priornumrubis,Priornumrubp,Priornumtpu) + if(bestilimittype.gt.0.and.Priorilimittype.ne.bestilimittype) + &return +!if bestilimittype is specified, we assume the fitting is constained to the limit type specified by bestilimittype + if(Priorilimittype.ge.3)return +!5, 6, 7 are done with Prioriknowlimit=0. We don't consider cases with only rubp and tpu limitations but no rubisco limitations + if(Priornumrubis.gt.0.and.Priornumrubis.lt.minimumrubis)return + if(Priornumrubp.gt.0.and.Priornumrubp.lt.minimumfj)return + if(Priornumtpu.gt.0.and.Priornumtpu.lt.minimumvt)return + do i=1,ntotsamples + Currentiphotolimit(i)=Prioriphotolimit(i) + enddo + endif + Currentilimittype=Priorilimittype + Currentiknowlimit=Prioriknowlimit +! +!-------------Test Area--------------------------------------------- +! Currentilimittype=1 +! Currentiknowlimit=1 +! do i=1,ntotsamples +! if(i.le.6)then +! Currentiphotolimit(i)=1 +! else +! if(i.ge.16.and.i.le.26)then +! Currentiphotolimit(i)=2 +! else +! Currentiphotolimit(i)=3 +! endif +! endif +! enddo +!------------------------------------------------------------------- + call DoUnivPhotoFit() + if(Prioriknowlimit.ne.1.or.Priorilimittype.ge.5)goto 1000 +!--------------------------------------------------------- +!Enforce the admissibility rule. +!first get the post-fit limit type of each point. (pco2i,anet_obs) should be replaced +!by (pco2i_pred, anet_pred) + do i=1,ntotsamples + call leafunivphotosyn(Currentiknowlimit,Currentilimittype, + &0,aPPFDlf(i),templeaf(i),pco2i_pred(i),po2i(i),chlflphips2(i), + &term,weitresponses(i:i,1:1),weitresponses(i:i,1:1), + &weitresponses(i:i,2:2),weitresponses(i:i,1:1),term1,term2, + &Postiphotolimit(i),term3,term4,term5,term6,term7,term8,term9) + enddo + j=0 + do i=1,ntotsamples + if(Postiphotolimit(i).ne.Currentiphotolimit(i))j=j+1 + enddo +!if j = 0, the fitting is admissible so go to the wrapup + if(j.eq.0)goto 1000 + call ilimittypestats(ntotsamples,Postiphotolimit, + &Postilimittype,Postnumrubis,Postnumrubp,Postnumtpu) +!if minimum number of points is not satisfied, go to penality fit directly. + if(Postnumrubis.gt.0.and.Postnumrubis.lt.minimumrubis)goto 500 + if(Postnumrubp.gt.0.and.Postnumrubp.lt.minimumfj)goto 500 + if(Postnumtpu.gt.0.and.Postnumtpu.lt.minimumvt)goto 500 +!check to see if the fit oscillates. + Currentilimittype=Postilimittype + do i=1,ntotsamples + Currentiphotolimit(i)=Postiphotolimit(i) + enddo + call DoUnivPhotoFit() + do i=1,ntotsamples + call leafunivphotosyn(Currentiknowlimit,Currentilimittype, + &0,aPPFDlf(i),templeaf(i),pco2i_pred(i),po2i(i),chlflphips2(i), + &term,weitresponses(i:i,1:1),weitresponses(i:i,1:1), + &weitresponses(i:i,2:2),weitresponses(i:i,1:1),term1,term2, + &Postiphotolimit(i),term3,term4,term5,term6,term7,term8,term9) + enddo + j=0 + do i=1,ntotsamples + if(Postiphotolimit(i).ne.Prioriphotolimit(i))j=j+1 + enddo + if(j.eq.0)then +!Osicillation. Treat osicillating points as co-limited + k=ntotsamples + do i=1,ntotsamples + if(Currentiphotolimit(i).ne.Prioriphotolimit(i))then + k=k+1 + Currentiphotolimit(k)=Currentiphotolimit(i) + aPPFDlf(k)=aPPFDlf(i) + templeaf(k)=templeaf(i) + po2i(k)=po2i(i) + pco2i(k)=pco2i(i) + anet_obs(k)=anet_obs(i) + chlflphips2(k)=chlflphips2(i) + Currentiphotolimit(i)=Prioriphotolimit(i) + endif + enddo + call ilimittypestats(k,Currentiphotolimit, + &Currentilimittype,Currentnumrubis,Currentnumrubp,Currentnumtpu) + i=ntotsamples + ntotsamples=k + call DoUnivPhotoFit() + sumsquare=sumsquare*dble(i)/dble(k) + ntotsamples=i + goto 1000 + else +!no osicillation + Currentilimittype=Priorilimittype + do i=1,ntotsamples + Currentiphotolimit(i)=Prioriphotolimit(i) + enddo + endif +!-------------Penalty function fit------------------------------------------- +500 Currentiknowlimit=2 + call DoUnivPhotoFit() +!-------------Wrap up-------------------------------------------------------- +1000 if(Prioriknowlimit.eq.0.and.Priorilimittype.le.4)then + call ilimittypestats(ntotsamples,Postiphotolimit, + &Postilimittype,Postnumrubis,Postnumrubp,Postnumtpu) + if(Postnumrubis.gt.0.and.Postnumrubis.lt.minimumrubis-1) + &sumsquare=1.0d+10 + if(Postnumrubp.gt.0.and.Postnumrubp.lt.minimumfj-1) + &sumsquare=1.0d+10 + if(Postnumtpu.gt.0.and.Postnumtpu.lt.minimumvt-1) + &sumsquare=1.0d+10 + endif + term=1.0d0+(subbestsumsquare(Priorilimittype)-sumsquare) + if(term.gt.1.0d0)then + subbestsumsquare(Priorilimittype)=sumsquare + do i=1,ntotunivparams + subbestunivparams(i,Priorilimittype)=univparams(i) + enddo + do i=1,ntotsamples + if(Prioriknowlimit.eq.0)then + subbestiphotolimit(i,Priorilimittype)=Postiphotolimit(i) + else + subbestiphotolimit(i,Priorilimittype)=Prioriphotolimit(i) + endif + enddo + endif + return + end subroutine UnivPhotoFit +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine DoUnivPhotoFit() + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' + integer i,ndim,k,j,iderivative,iwrong,jnon + double precision beta(20),sumsquare0,beta0(20),sumsquarecp, + &betacp(20),ftol,xtol,shortx(maxobs,4),shorty(maxobs,2),ran2, + &ftol_relax + parameter(ftol=1.0d-7,xtol=1.0d-7) + external funkmin_UnivPhotoFit,f1dim_UnivPhotoFit, + &FCN_UnivPhotoFit,ff_pikaia +!find out which parameters to optimize + call UnivParamsAlloc(1) + ndim=0 + do i=1,ntotunivparams + univparams(i)=subbestunivparams(i,Currentilimittype) + if(ifixunivparams(i).eq.1)then + ndim=ndim+1 + beta(ndim)=univparams(i) + betamin(ndim)=univparamsmin(i) + betamax(ndim)=univparamsmax(i) + endif + enddo + isitbounded=1 + call funkmin_UnivPhotoFit(ndim,beta,sumsquare) + do i=1,ndim + beta0(i)=beta(i) + enddo + sumsquare0=sumsquare + ftol_relax=ftol + k=0 + if(subbestsumsquare(Currentilimittype).gt.1.0d+9)then + jnon=0 + ftol_relax=ftol*100.0d0 + endif +30 call nongradopt(ndim,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit, + &beta,betamin,betamax,ftol_relax,sumsquare) + call funkmin_UnivPhotoFit(ndim,beta,sumsquare) + if((sumsquare+1.0d0).eq.sumsquare.or.sumsquare.gt.sumsquare0)then + do i=1,ndim + beta(i)=beta0(i) + enddo + sumsquare=sumsquare0 + else + if((sumsquare0-sumsquare).gt.ftol_relax)then +!reset the counter for arriving at a better minimum + k=0 + else +!if the same minimum is found, increment the counter + k=k+1 + endif + do i=1,ndim + beta0(i)=beta(i) + enddo + sumsquare0=sumsquare + endif + if(subbestsumsquare(Currentilimittype).gt.1.0d+9)then + jnon=jnon+1 +!for the first run, try different initial guesses + if(jnon.lt.100.and.k.lt.5)then + if(ran2().gt.0.7d0)then + do i=1,ndim + beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i)) + enddo + else + do i=1,ndim + if(ran2().gt.0.5d0)then + beta(i)=beta(i)+(ran2()**(3.0d0/dble(k+1)))* + &(betamax(i)-beta(i)) + else + beta(i)=beta(i)-(ran2()**(3.0d0/dble(k+1)))* + &(beta(i)-betamin(i)) + endif + enddo + endif + call funkmin_UnivPhotoFit(ndim,beta,sumsquare) + goto 30 + else + if((ftol_relax-ftol).gt.ftol)then + ftol_relax=ftol + goto 30 + endif + endif + call RepeatCompassSearch(ndim,beta,sumsquare,betamin, + &betamax,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,xtol) + call funkmin_UnivPhotoFit(ndim,beta,sumsquare) + if((sumsquare+1.0d0).eq.sumsquare.or.sumsquare.gt.sumsquare0) + &then + do i=1,ndim + beta(i)=beta0(i) + enddo + sumsquare=sumsquare0 + endif + do i=1,ndim + betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + enddo + sumsquarecp=sumsquare + isitbounded=0 + call pikaia(ff_pikaia,ndim,gacontrol,betacp,sumsquarecp,i) + isitbounded=1 + if(i.eq.0)then + do i=1,ndim + betacp(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i)) + enddo + call funkmin_UnivPhotoFit(ndim,betacp,sumsquarecp) + else + do i=1,ndim + betacp(i)=beta(i) + enddo + sumsquarecp=sumsquare + endif + if((sumsquarecp+1.0d0).ne.sumsquarecp.and. + &sumsquare.gt.sumsquarecp)then + do i=1,ndim + beta(i)=betacp(i) + enddo + sumsquare=sumsquarecp + endif + do i=1,ndim + beta0(i)=beta(i) + enddo + sumsquare0=sumsquare + else + return + endif + iderivative=0 + if(ifitmode.lt.0)then + iwrong=0 + else + iwrong=1 + endif + isitbounded=1 + k=ifitmode + ifitmode=-1 +!ifitmode: =-2, ordinary fitting with pco2i calculated as a function of anet +!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i +!ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i +!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet +!for odr_leastsquare, only the predicted value of the response variable is needed, i.e., the cost function value is not needed. +!also, only anet as a function of CO2i is considered (not the other way around) because odr_leastsquare cannot handle the situation +!co2i as a function of anet for tpu limitation when alpha=0 + i=1 + if(ntotphips2.ge.1)i=2 + j=4 + if(Currentiknowlimit.eq.-1)then +!fluorescence only fit. chlflphisi2 becomes a forcing variable + i=1 + j=5 + endif + call odr_leastsquare(ndim,FCN_UnivPhotoFit,beta,ntotsamples, + &forcings(1:ntotsamples,1:j),j,responses(1:ntotsamples,1:i),i, + &weitforcings(1:ntotsamples,1:j),weitresponses(1:ntotsamples,1:i), + &iderivative,shortx(1:ntotsamples,1:j),shorty(1:ntotsamples,1:i), + &sumsquare,iwrong) + isitbounded=1 + ifitmode=k +!after odr_leastsquare, forcing variables are destroyed. restore to the origninals + do i=1,ntotsamples + pco2i(i)=pco2i_ori(i) + aPPFDlf(i)=aPPFDlf_ori(i) + templeaf(i)=templeaf_ori(i) + po2i(i)=po2i_ori(i) + chlflphips2(i)=chlflphips2_ori(i) + enddo + call funkmin_UnivPhotoFit(ndim,beta,sumsquare) + if((sumsquare+1.0d0).eq.sumsquare.or.sumsquare.gt.sumsquare0)then + do i=1,ndim + beta(i)=beta0(i) + enddo + sumsquare=sumsquare0 + endif + k=0 + do i=1,ndim + if(beta(i).lt.betamin(i))k=1 + if(beta(i).gt.betamax(i))k=1 + enddo + if(k.eq.1)then + do i=1,ndim + betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + enddo + isitbounded=0 + call pikaia(ff_pikaia,ndim,gacontrol,betacp,sumsquare,i) + do i=1,ndim + beta(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i)) + enddo + isitbounded=1 + call funkmin_UnivPhotoFit(ndim,beta,sumsquare) + endif + j=0 +100 jnon=0 +105 sumsquare0=sumsquare + do i=1,ndim + beta0(i)=beta(i) + enddo + call nongradopt(ndim,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit, + &beta,betamin,betamax,ftol,sumsquare) + call funkmin_UnivPhotoFit(ndim,beta,sumsquare) + if(jnon.le.2.and.(sumsquare0-sumsquare).gt.ftol)then + jnon=jnon+1 + goto 105 + endif + if(sumsquare.eq.sumsquare0)goto 110 + if(dabs(sumsquare).le.dabs(sumsquare0))then + else + if(dabs(sumsquare).gt.1.0d+20)then +!in case of infinity (division by zero) + do i=1,ndim + beta(i)=beta0(i) + enddo + sumsquare=sumsquare0 + else +!designed this way to avoid sumsquare='NAN' + do i=1,ndim + beta(i)=beta0(i) + enddo + sumsquare=sumsquare0 + endif + endif + sumsquarecp=sumsquare + do i=1,ndim + betacp(i)=beta(i) + enddo + call RepeatCompassSearch(ndim,betacp,sumsquarecp,betamin, + &betamax,funkmin_UnivPhotoFit,f1dim_UnivPhotoFit,xtol) + call funkmin_UnivPhotoFit(ndim,betacp,sumsquarecp) + if(sumsquare.eq.sumsquarecp)goto 110 + if(dabs(sumsquarecp).lt.dabs(sumsquare))then + do i=1,ndim + beta(i)=betacp(i) + enddo + sumsquare=sumsquarecp + endif + j=j+1 + if(j.le.2.and.dabs(sumsquare-sumsquare0).gt.ftol)goto 100 +! +!------------------------------------------------------ +110 call funkmin_UnivPhotoFit(ndim,beta,sumsquare) + return + END subroutine DoUnivPhotoFit diff --git a/leafres/testarea/cica.h b/leafres/testarea/cica.h new file mode 100644 index 0000000..46e15e4 --- /dev/null +++ b/leafres/testarea/cica.h @@ -0,0 +1,7 @@ + double precision bmin(10),bmax(10),cicameas(1000), + & pco2ambient(1000) + common /cicadble/bmin,bmax,cicameas, + & pco2ambient + + integer nobs,imodel + common /cicaint/nobs,imodel diff --git a/leafres/testarea/cica5.f b/leafres/testarea/cica5.f new file mode 100644 index 0000000..8c5a2b6 --- /dev/null +++ b/leafres/testarea/cica5.f @@ -0,0 +1,138 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine cicaoptimization5(npoints,cicameas0, + &pco2ambient0,beta,ndim,imodel0,bmin0,bmax0) + implicit none + + include '../testarea/cica.h' +c + integer npoints + double precision pco2ambient0(npoints),cicameas0(npoints), + & acica,bcica,ccica,dcica,ecica + + integer i,ndim,imodel0 + double precision beta(ndim),fatbeta,ftol,bmin0(ndim), + & bmax0(ndim) + parameter(ftol=1.0d-7) + external funkmin_cica,f1dim_cica + + nobs = npoints + imodel=imodel0 + do i=1,npoints + pco2ambient(i)=pco2ambient0(i) + cicameas(i)=cicameas0(i) + enddo + + do i=1,ndim + bmin(i)=bmin0(i) + bmax(i)=bmax0(i) + enddo +! +! Initialize the cost function evaluation counter in the subroutine funkmin. +! The counter counts and memorizes points where the cost function is evaluated. + + call funkmin_cica(ndim,beta,fatbeta) + call nongradopt(ndim,funkmin_cica,f1dim_cica,beta, + & bmin,bmax,ftol,fatbeta) + if(imodel.eq.3)then + call RepeatCompassSearch(ndim,beta,fatbeta,bmin, + &bmax,funkmin_cica,f1dim_cica,ftol) + else + call nongradopt(ndim,funkmin_cica,f1dim_cica,beta, + &bmin,bmax,ftol,fatbeta) + endif + return + END +c +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + subroutine cica_ca5(imodel,ndim,beta,ambco2_in_Pa,cica,der_cica, + &der_beta) + implicit none + integer imodel,ndim +! calculate Ci/Ca ratio for a given ambient CO2 partial pressure in Pa. +! +!Ci/Ca=a*exp(-b*Ca)+c/(1+exp(-(Ca-d)/e)) +! + double precision a,b,c,d,e,f,ambco2_in_Pa,cica,der_cica, + &term1,term2,term0,crit,grad(10),twoexpfunc,beta(ndim), + &der_beta(ndim) + parameter(crit=300.0d0) + + a=beta(1) + b=beta(2) + c=beta(3) + d=beta(4) + e=beta(5) + f=beta(ndim) + if(ndim.le.5)f=0.0d0 + if(imodel.eq.1)then +! cica=twoexpfunc(y0,a1,b1,c1,x01, +! & a2,b2,c2,x02,x) + cica=twoexpfunc(e,a,b,1.d0,0.0d0, + & c,d,1.0d0,0.0d0,ambco2_in_Pa) +! call gradtwoexp(y0,a1,b1,c1,x01, +! & a2,b2,c2,x02,x,grad) + call gradtwoexp(e,a,b,1.d0,0.0d0, + & c,d,1.0d0,0.0d0,ambco2_in_Pa,grad) +! a1<->grad(1)<->a +! b1<->grad(2)<->b +! c1<->grad(3) +! x01<->grad(4) +! y0<->grad(5)<->e +! x<->grad(6) +! a2<->grad(7) +! b2<->grad(8) +! c2<->grad(9) +! x02<->grad(10) + der_cica=grad(6) + der_beta(5)=grad(5) + der_beta(1)=grad(1) + der_beta(2)=grad(2) + der_beta(3)=grad(7) + der_beta(4)=grad(8) + return + endif + if(imodel.eq.2)then + term0=-(ambco2_in_Pa-d)/e + term1=dexp(-b*ambco2_in_Pa) + if(term0.lt.crit)then + term2=dexp(term0) + cica=a*term1+c/(1.0d0+term2) + der_cica=-a*b*term1+(c*term2)/(e*(1.0d0+term2)**2) + der_beta(1)=term1 + der_beta(2)=-a*ambco2_in_Pa*term1 + der_beta(3)=1.0d0/(1.0d0+term2) + der_beta(4)=-c*term2/(e*(1.0d0+term2)**2) + der_beta(5)=c*term2*(-ambco2_in_Pa+d)/((e*(1.0d0+term2))**2) + else + term2=dexp(-term0) + cica=a*term1+c*term2/(1.0d0+term2) + der_cica=-a*b*term1+(c*term2)/(e*(1.0d0+term2)**2) + der_beta(1)=term1 + der_beta(2)=-a*ambco2_in_Pa*term1 + der_beta(3)=term2/(1.0d0+term2) + der_beta(4)=-c*term2/(e*(1.0d0+term2)**2) + der_beta(5)=c*term2*(-ambco2_in_Pa+d)/((e*(1.0d0+term2))**2) + endif + if(ndim.eq.6)then + cica=cica+beta(ndim) + der_beta(ndim)=1.0d0 + endif + endif + if(imodel.eq.3)then + term1=dexp(-b*ambco2_in_Pa) + cica=a*term1+c+d*dlog(ambco2_in_Pa)+e*dlog(ambco2_in_Pa)* + &dlog(ambco2_in_Pa)+f*dlog(ambco2_in_Pa)*dlog(ambco2_in_Pa)* + &dlog(ambco2_in_Pa) + der_cica=-a*b*term1+d/ambco2_in_Pa+2.0d0*e*dlog(ambco2_in_Pa)/ + &ambco2_in_Pa+3.0d0*f*dlog(ambco2_in_Pa)*dlog(ambco2_in_Pa)/ + &ambco2_in_Pa + der_beta(1)=term1 + der_beta(2)=-a*ambco2_in_Pa*term1 + der_beta(3)=1.0d0 + der_beta(4)=dlog(ambco2_in_Pa) + der_beta(5)=dlog(ambco2_in_Pa)*dlog(ambco2_in_Pa) + if(ndim.eq.6)der_beta(ndim)=dlog(ambco2_in_Pa)* + &dlog(ambco2_in_Pa)*dlog(ambco2_in_Pa) + endif + return + end diff --git a/leafres/testarea/cica_Regression5.f b/leafres/testarea/cica_Regression5.f new file mode 100644 index 0000000..9a5db62 --- /dev/null +++ b/leafres/testarea/cica_Regression5.f @@ -0,0 +1,230 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +! + subroutine cica_Regression5(N,cicameas0,pco2ambient0,BETA,NP, + &imodel0,bmin0,bmax0) + implicit none + include '../testarea/cica.h' +c +C ODRPACK ARGUMENT DEFINITIONS +C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE +C ==> N NUMBER OF OBSERVATIONS +C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C <==> BETA FUNCTION PARAMETERS +C ==> Y RESPONSE VARIABLE +C ==> LDY LEADING DIMENSION OF ARRAY Y +C ==> X EXPLANATORY VARIABLE +C ==> LDX LEADING DIMENSION OF ARRAY X +C ==> WE "EPSILON" WEIGHTS +C ==> LDWE LEADING DIMENSION OF ARRAY WE +C ==> LD2WE SECOND DIMENSION OF ARRAY WE +C ==> WD "DELTA" WEIGHTS +C ==> LDWD LEADING DIMENSION OF ARRAY WD +C ==> LD2WD SECOND DIMENSION OF ARRAY WD +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> JOB TASK TO BE PERFORMED +C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS +C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR +C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION +C ==> PARTOL PARAMETER CONVERGENCE CRITERION +C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS +C ==> IPRINT PRINT CONTROL +C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS +C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS +C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA +C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA +C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD +C ==> SCLB SCALE VALUES FOR PARAMETERS BETA +C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE +C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD +C <==> WORK DOUBLE PRECISION WORK VECTOR +C ==> LWORK DIMENSION OF VECTOR WORK +C <== IWORK INTEGER WORK VECTOR +C ==> LIWORK DIMENSION OF VECTOR IWORK +C <== INFO STOPPING CONDITION + +C PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER +C MAXN MAXIMUM NUMBER OF OBSERVATIONS +C MAXM MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C MAXNP MAXIMUM NUMBER OF FUNCTION PARAMETERS +C MAXNQ MAXIMUM NUMBER OF RESPONSES PER OBSERVATION + +C PARAMETER DECLARATIONS AND SPECIFICATIONS + INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ + PARAMETER (MAXM=25,MAXN=10000,MAXNP=30,MAXNQ=1, + + LDY=MAXN,LDX=MAXN, + + LDWE=1,LD2WE=1,LDWD=1,LD2WD=1, + + LDIFX=MAXN,LDSTPD=1,LDSCLD=1, + + LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + + + 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP + + + 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + + + 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ, + + LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM)) +C VARIABLE DECLARATIONS + INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N, + + NDIGIT,NP,NQ + INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK) + DOUBLE PRECISION PARTOL,SSTOL,TAUFAC + DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM), + + STPB(MAXNP),STPD(LDSTPD,MAXM), + + WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ), + + WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ) +c + integer i1,i2,i3,i4,i5,imodel0 + double precision cicameas0(N),pco2ambient0(N), + &bmin0(NP),bmax0(NP) + + EXTERNAL CICAFCN5 +c +C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS + WE(1,1,1) = -1.0D0 + WD(1,1,1) = -1.0D0 + IFIXB(1) = -1 +! IFIXX(1,1) = -1 +! JOB = 00023 + JOB=23 + NDIGIT = -1 + TAUFAC = -1.0D0 + SSTOL = -1.0D0 + PARTOL = -1.0D0 + MAXIT = -1 +! IPRINT = -1 + IPRINT=0 + LUNERR = -1 + LUNRPT = -1 + STPB(1) = -1.0D0 + STPD(1,1) = -1.0D0 + SCLB(1) = -1.0D0 + SCLD(1,1) = -1.0D0 + + MAXIT = 200000 +C SET UP ODRPACK REPORT FILES + LUNERR = 9 + LUNRPT = 9 +c + imodel=imodel0 + nobs=N + do I=1,NP + bmin(I)=bmin0(I) + bmax(I)=bmax0(I) + enddo + do I=1,N + pco2ambient(I)=pco2ambient0(I) + cicameas(I)=cicameas0(I) + X(I,1)=pco2ambient(I) + Y(I,1)=cicameas(I) + enddo + M=1 + NQ=1 + +C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX + DO 10 I=1,N + DO 15 J=1, M + IFIXX(I,J) = 1 +15 CONTINUE +10 CONTINUE +60 CALL DODRC(CICAFCN5, + + N,M,NP,NQ, + + BETA, + + Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, + + SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, + + SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + i1=mod(INFO,10) + i2=(mod(INFO,100)-i1)/10 + i3=(mod(INFO,1000)-mod(INFO,100))/100 + i4=(mod(INFO,10000)-mod(INFO,1000))/1000 + i5=(INFO-mod(INFO,10000))/10000 + return + END + + SUBROUTINE CICAFCN5(N,M,NP,NQ, + + LDN,LDM,LDNP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,F,FJACB,FJACD, + + ISTOP) + implicit none + + include '../src/cica.h' + +C SUBROUTINE ARGUMENTS +C ==> N NUMBER OF OBSERVATIONS +C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N +C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M +C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP +C ==> BETA CURRENT VALUES OF PARAMETERS +C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED +C <== F PREDICTED FUNCTION VALUES +C <== FJACB JACOBIAN WITH RESPECT TO BETA +C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA +C <== ISTOP STOPPING CONDITION, WHERE +C 0 MEANS CURRENT BETA AND X+DELTA WERE +C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY +C 1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES +C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE +C -1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD STOP + +C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE: + INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ + DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M) + INTEGER IFIXB(NP),IFIXX(LDIFX,M),k +C OUTPUT ARGUMENTS: + DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) + + double precision pco2a,cica,der_cica,der_BETA(NP) + +C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM +c + + do I=1,NP + if(BETA(I).lt.bmin(I).or.BETA(I).gt.bmax(I))then + ISTOP = 1 + RETURN + endif + enddo +! + IF (MOD(IDEVAL,10).GE.1) THEN + DO 110 L = 1,NQ + DO 100 I = 1,N + pco2a=XPLUSD(I,1) + call cica_ca5(imodel,NP,BETA,pco2a,cica,der_cica,der_BETA) + F(I,L)=cica + 100 CONTINUE + 110 CONTINUE + END IF +C COMPUTE DERIVATIVES WITH RESPECT TO BETA + IF (MOD(IDEVAL/10,10).GE.1) THEN + DO 210 L = 1,NQ + DO 200 I = 1,N + pco2a=XPLUSD(I,1) + call cica_ca5(imodel,NP,BETA,pco2a,cica,der_cica,der_BETA) + do k=1,NP + FJACB(I,k,L)=der_BETA(k) + enddo + 200 CONTINUE + 210 CONTINUE + END IF + RETURN + END +! +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/leafres/testarea/commonparameters.f b/leafres/testarea/commonparameters.f new file mode 100644 index 0000000..00177b2 --- /dev/null +++ b/leafres/testarea/commonparameters.f @@ -0,0 +1,205 @@ +!This subroutine initializes the parameters to be optimized as well as those to be used and not changed +! + subroutine commonparameters(stargamma25,fkc25,fko25,alpha25, + &ha_vcmax,hd_vcmax,sv_vcmax,ha_jmax,hd_jmax,sv_jmax,ha_tpu, + &hd_tpu,sv_tpu,ha_gmeso,hd_gmeso,sv_gmeso,ha_darkresp,ha_stargamma, + &ha_kc,ha_ko,abspt_lf_par,gascon,phifactor,thetafactor,betaPSII) + implicit none +!-------Secondary parameters in A/Ci curve analysis---------------------- +! stargamma25: the chloroplastic CO2 compensation point at 25oC +! fkc25: the Michaelis constant for CO2 at 25oC when gmeso is not include [Pa] +! fko25: the Michaelis constant for O2 at 25oC when gmeso is not include [Pa] +! alpha25: The fraction of glycolate carbon not returned to the chloroplat [0-1] + double precision stargamma25,fkc25,fko25,alpha25 +!-------Parameters that define temperature responses--------------------- +! ha_vcmax: The activation energy (Ha) in Vcmax temperature response function [kJmol-1] +! hd_vcmax: The deactivation energy (Hd) in Vcmax temperature response function [kJmol-1] +! sv_vcmax: The entropy term (Sv) in Vcmax temperature response function [kJmol-1K-1] +! ha_jmax: The activation energy (Ha) in jmax temperature response function [kJmol-1] +! hd_jmax: The deactivation energy (Hd) in jmax temperature response function [kJmol-1] +! sv_jmax: The entropy term (Sv) in jmax temperature response function [kJmol-1K-1] +! ha_tpu: The activation energy (Ha) in tpu temperature response function [kJmol-1] +! hd_tpu: The deactivation energy (Hd) in tpu temperature response function [kJmol-1] +! sv_tpu: The entropy term (Sv) in tpu temperature response function [kJmol-1K-1] +! ha_gmeso: The activation energy (Ha) in gmeso temperature response function [kJmol-1] +! hd_gmeso: The deactivation energy (Hd) in gmeso temperature response function [kJmol-1] +! sv_gmeso: The entropy term (Sv) in gmeso temperature response function [kJmol-1K-1] +! +! ha_darkresp: parameter in the temperature response function of dark respiration [kJmol-1] +! ha_stargamma: parameter in the temperature response function of the co2 compensation point [kJmol-1] +! ha_kc: a CO2 Michaelis temp coefficient [kJmol-1] +! ha_ko: a O2 Michaelis temp coefficient [kJmol-1] +! gascon: Universal gas constant J K-1 mol-1 +! phifactor: modifies Bernacchi phiPSIImax +! thetafactor: modifies Bernacchi thetaPSII +! betaPSII: the fraction of absorbed light that reaches photosystem II (0.5) + double precision ha_vcmax,hd_vcmax,sv_vcmax,ha_jmax, + &hd_jmax,sv_jmax,ha_tpu,hd_tpu,sv_tpu,ha_gmeso,hd_gmeso,sv_gmeso, + &ha_darkresp,ha_stargamma,ha_kc,ha_ko,phifactor,thetafactor, + &betaPSII + +!--------------Other parameters------------------------------------------- +! abspt_lf_par: leaf absorptance in PAR + double precision abspt_lf_par,gascon + + gascon=8.314472d0 +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +!Parameters below this line will be used as inputs if not optimized from curve fitting +!but as initial values if optimized. So they are not arbitrary values and should not be +!changed unless there is a good reason. +! +!-------Secondary parameters--------------------------- +!Considered universal but uncertain, also depend on whether mesophyll conductance is involked +!The subscript 1 is for fitting without mesophyll conductance; 2 is for fitting with mesophyll conductance +!Bernacchi et al. (2003) values +! stargamma25=4.3d0 +! stargamma25=4.3d0 +! fkc25=41.0d0 +! fkc25=41.0d0 +! fko25=27710.0d0 +! fko25=27710.0d0 +! +!S. von Caemmerer (2000) values +! stargamma25=3.7d0 +! stargamma25=3.86d0 +! fkc25=40.4d0 +! fkc25=26.0d0 +! fko25=24800.0d0 +! fko25=17900.0d0 + +!Values used in Sharkey et al. (2007) + stargamma25=3.743d0 + fkc25=27.238d0 + fko25=16582.0d0 + +!Jordan and Ogren (1984) values +! stargamma25=4.5146d0 +! stargamma25=4.5146d0 +! fkc25=27.422d0 +! fkc25=27.422d0 +! fko25=41829.0d0 +! fko25=41829.0d0 + + alpha25=0.0d0 +!most models have alpha=0 +!----------------------------------------------------- +!Parameters in the generic Vcmax temperature response function. +!Leuning, Harley and Bernacchi can all be expressed in the same generic form +!Bernacchi et al. (2003) function +! ha_vcmax=65.33d0 +! hd_vcmax=0.0d0 +! sv_vcmax=0.0d0 + +!S. von Caemmerer (2000) values +! ha_vcmax=58.52d0 +! hd_vcmax=0.0d0 +! sv_vcmax=0.0d0 + +!Leuning (2002) function +! ha_vcmax=73.637d0 +! hd_vcmax=149.252d0 +! sv_vcmax=0.486d0 + +!Harley et al. (1992) function +! ha_vcmax=116.3d0 +! hd_vcmax=202.9d0 +! sv_vcmax=0.65d0 + +!Values used in Sharkey et al. (2007) + ha_vcmax=65.33d0 + hd_vcmax=0.0d0 + sv_vcmax=0.0d0 +! +!------------------------------------------------------- +!Parameters in Jmax temperature response functions. All in unit of kJmol-1 +!Leuning, Harley and Bernacchi can all be expressed in the same generic form +!Bernacchi et al. (2003) function +! ha_jmax=43.54d0 +! hd_jmax=0.0d0 +! sv_jmax=0.0d0 + +!S. von Caemmerer (2000) values +! ha_jmax=37.0d0 +! hd_jmax=0.0d0 +! sv_jmax=0.0d0 + +!Leuning function +! ha_jmax=50.3d0 +! hd_jmax=152.044d0 +! sv_jmax=0.495d0 + +!Harley functions +! ha_jmax=79.5d0 +! hd_jmax=201.0d0 +! sv_jmax=0.65d0 + +!values used in Sharkey et al. (2007) + ha_jmax=43.54d0 + hd_jmax=0.0d0 + sv_jmax=0.0d0 + +!June et al. function. The June et al function cannot be expressed in the generic form. Need to go to the +!Jmax temperature response function subroutine to change the form if this function is used +! ha_jmax=30.0d0+273.15d0 +! hd_jmax=11.6d0 +! sv_jmax=0.18d0 + +!--------------------------------------------------------- +!Parameters in TPU temperature response function in kJmol-1 +!Harley function + ha_tpu=53.1d0 + hd_tpu=201.8d0 + sv_tpu=0.65d0 + +!Parameters in gmeso temperature response function +!Values from the functions in Bernacchi, et al. (2002), Plant Physiology, 130, 1992-1998. + ha_gmeso=49.6d0 + hd_gmeso=437.4d0 + sv_gmeso=1.4d0 +!Values from the function in Scafaro et al. (2011), PCE 34: 1999-2008 +! ha_gmeso=(45.22d0+29.17d0+48.26d0)/3.0d0 +! hd_gmeso=-9999.0d0 +! sv_gmeso=-9999.0d0 +!--------------------------------------------------------- +!Parameters in the temperature response function for leaf mitochondrial (dark) respiration (kJmol-1) +!Parameters in the temp function for the choloraplastic CO2 compensation point (kJmol-1) +!Parameters in the temp function of Kc +!Parameters in the temp function of Ko +!Bernacchi et al. (2003) parameters +! ha_darkresp=46.39d0 +! ha_stargamma=37.83d0 +! ha_kc=79.43d0 +! ha_ko=36.38d0 + +!S. von Caemmerer (2000) values +! ha_darkresp=66.4d0 +! ha_stargamma=23.4d0 +! ha_kc=59.36d0 +! ha_ko=35.94d0 + +!Jordan and Ogren (1984) parameters +! ha_darkresp=66.4d0 +! ha_stargamma=29.213d0 +! ha_kc=70.372d0 +! ha_ko=14.351d0 + +!Values used in Sharkey et al. (2007) + ha_darkresp=46.39d0 + ha_stargamma=24.46d0 + ha_kc=80.99d0 + ha_ko=23.72d0 + +!---------------------------------------------------------- +!Leaf absorptance parameter in PAR + abspt_lf_par=0.85d0 +! +!!3/29/2014. Bernacchi method cannot fit A/PAR curves well. phifactor and thetafactor are +!estimated and used to modify his method when A/PAR curves are present. +! phifactor: modifies Bernacchi phiPSIImax +! thetafactor: modifies Bernacchi thetaPSII + phifactor=1.0d0 + thetafactor=1.0d0 + betaPSII=0.5d0 + return + end diff --git a/leafres/testarea/fluorescencejmax.f b/leafres/testarea/fluorescencejmax.f new file mode 100644 index 0000000..67e0fe4 --- /dev/null +++ b/leafres/testarea/fluorescencejmax.f @@ -0,0 +1,209 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine fluorescencejmax() + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' + integer i,ndim,k,j,iderivative,iwrong + double precision beta(4),sumsquare0,beta0(4),sumsquarecp, + &betacp(4),ftol,xtol,shortx(maxobs,2),shorty(maxobs), + &xvar(maxobs,2),weitx(maxobs,2),weity(maxobs),ran2, + &templflights0(maxobs),aparlights0(maxobs),termmin,termmax + parameter(ftol=1.0d-7,xtol=1.0d-7) + external funkmin_flujmax,f1dim_flujmax,FCN_flujmax,flujmax_pikaia +!beta(1)=fjmax25 + beta(1)=univparams(8) + betamin(1)=univparamsmin(8) + betamax(1)=univparamsmax(8) +!beta(2)=phifactor + beta(2)=univparams(11) + betamin(2)=univparamsmin(11) + betamax(2)=univparamsmax(11) +!beta(3)=thetafactor + beta(3)=univparams(12) + betamin(3)=univparamsmin(12) + betamax(3)=univparamsmax(12) + ndim=3 + ntotlights=0 + termmax=-1.0d+9 + termmin=1.0d+9 + do i=1,numALightcurves + do j=1,nALightPoints(i) + if(ALightchlflphips2(j,i).gt.0.0d0.and. + &j.le.nstartalight(i))then +!Only points before nstartalight are used because these points are apparently limited by RuBP regeneration and therefore +!the electron transport equation applies. + ntotlights=ntotlights+1 + templflights(ntotlights)=ALighttempleaf(j,i) + if(templflights(ntotlights).lt.termmin) + &termmin=templflights(ntotlights) + if(templflights(ntotlights).gt.termmax) + &termmax=templflights(ntotlights) + aparlights(ntotlights)=ALightaPPFDlf(j,i) + flphips2lights(ntotlights)=ALightchlflphips2(j,i) + xvar(ntotlights,1)=aparlights(ntotlights) + xvar(ntotlights,2)=templflights(ntotlights) + weitx(ntotlights,1)=1.0d0 + weitx(ntotlights,2)=1.0d0 + weity(ntotlights)=1.0d0 + templflights0(ntotlights)=templflights(ntotlights) + aparlights0(ntotlights)=aparlights(ntotlights) + endif + enddo + enddo + if((termmax-termmin).gt.2.0d0)then + ndim=4 +!beta(4)=ha_jmax + beta(4)=univparams(17) + betamin(4)=univparamsmin(17) + betamax(4)=univparamsmax(17) + endif + if(ntotlights.lt.ndim)then + ntotlights=0 + return + endif + isitbounded=1 + call funkmin_flujmax(ndim,beta,flujmaxfval) + do i=1,ndim + beta0(i)=beta(i) + enddo + sumsquare0=flujmaxfval + j=0 + k=0 +30 call nongradopt(ndim,funkmin_flujmax, + &f1dim_flujmax,beta,betamin,betamax,ftol,flujmaxfval) + call funkmin_flujmax(ndim,beta,flujmaxfval) + if((flujmaxfval+1.0d0).eq.flujmaxfval)then + do i=1,ndim + beta(i)=beta0(i) + enddo + flujmaxfval=sumsquare0 + else + if(dabs(flujmaxfval-sumsquare0).lt.ftol)k=k+1 + if(flujmaxfval.gt.sumsquare0)then + do i=1,ndim + beta(i)=beta0(i) + enddo + flujmaxfval=sumsquare0 + else + if((sumsquare0-flujmaxfval).gt.ftol)k=0 +!reset the counter of revisiting a minimum if a new minimum is found + endif + endif + j=j+1 +!try different initial guesses + if(j.lt.200.and.k.lt.50)then + do i=1,ndim + beta0(i)=beta(i) + beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i)) + enddo + sumsquare0=flujmaxfval + call funkmin_flujmax(ndim,beta,flujmaxfval) + goto 30 + endif + call RepeatCompassSearch(ndim,beta,flujmaxfval,betamin, + &betamax,funkmin_flujmax,f1dim_flujmax,xtol) + do i=1,ndim + betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + enddo + isitbounded=0 + call pikaia(flujmax_pikaia,ndim,gacontrol,betacp,flujmaxfval,i) + do i=1,ndim + beta(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i)) + enddo + isitbounded=1 + call funkmin_flujmax(ndim,beta,flujmaxfval) + call RepeatCompassSearch(ndim,beta,flujmaxfval,betamin, + &betamax,funkmin_flujmax,f1dim_flujmax,xtol) + isitbounded=1 + call funkmin_flujmax(ndim,beta,flujmaxfval) + do i=1,ndim + beta0(i)=beta(i) + enddo + sumsquare0=flujmaxfval + iderivative=0 + iwrong=0 + call odr_leastsquare(ndim,FCN_flujmax,beta,ntotlights, + &xvar(1:ntotlights,1:2),2,flphips2lights,1,weitx(1:ntotlights,1:2), + &weity,iderivative,shortx(1:ntotlights,1:2),shorty(1:ntotlights), + &flujmaxfval,iwrong) + isitbounded=1 +!after odr_leastsquare, forcing variables are destroyed. restore to the origninals + do i=1,ntotlights + templflights(i)=templflights0(i) + aparlights(i)=aparlights0(i) + enddo + call funkmin_flujmax(ndim,beta,flujmaxfval) + if(dabs(flujmaxfval).le.dabs(sumsquare0))then + else + if(dabs(flujmaxfval).gt.1.0d+20)then +!in case of infinity (division by zero) + do i=1,ndim + beta(i)=beta0(i) + enddo + flujmaxfval=sumsquare0 + else +!designed this way to avoid flujmaxfval='NAN' + do i=1,ndim + beta(i)=beta0(i) + enddo + flujmaxfval=sumsquare0 + endif + endif + j=0 +100 if(j.ge.10)then + do i=1,ndim + betacp(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + enddo + isitbounded=0 + call pikaia(flujmax_pikaia,ndim,gacontrol,betacp,flujmaxfval,i) + do i=1,ndim + beta(i)=betamin(i)+betacp(i)*(betamax(i)-betamin(i)) + enddo + isitbounded=1 + call funkmin_flujmax(ndim,beta,flujmaxfval) + endif + sumsquare0=flujmaxfval + do i=1,ndim + beta0(i)=beta(i) + enddo + call nongradopt(ndim,funkmin_flujmax,f1dim_flujmax, + &beta,betamin,betamax,ftol,flujmaxfval) + call funkmin_flujmax(ndim,beta,flujmaxfval) + if(flujmaxfval.eq.sumsquare0)return + if(dabs(flujmaxfval).le.dabs(sumsquare0))then + else + if(dabs(flujmaxfval).gt.1.0d+20)then +!in case of infinity (division by zero) + do i=1,ndim + beta(i)=beta0(i) + enddo + flujmaxfval=sumsquare0 + else +!designed this way to avoid flujmaxfval='NAN' + do i=1,ndim + beta(i)=beta0(i) + enddo + flujmaxfval=sumsquare0 + endif + endif + sumsquarecp=flujmaxfval + do i=1,ndim + betacp(i)=beta(i) + enddo + call RepeatCompassSearch(ndim,betacp,sumsquarecp,betamin, + &betamax,funkmin_flujmax,f1dim_flujmax,xtol) + call funkmin_flujmax(ndim,betacp,sumsquarecp) + if(flujmaxfval.eq.sumsquarecp)return + if(dabs(sumsquarecp).lt.dabs(flujmaxfval))then + do i=1,ndim + beta(i)=betacp(i) + enddo + flujmaxfval=sumsquarecp + endif + j=j+1 + if(j.le.2.and.dabs(flujmaxfval-sumsquare0).gt.ftol)goto 100 +! +!------------------------------------------------------ +110 call funkmin_flujmax(ndim,beta,flujmaxfval) + return + END subroutine fluorescencejmax diff --git a/leafres/testarea/funkmin_UnivPhotoFit.f b/leafres/testarea/funkmin_UnivPhotoFit.f new file mode 100644 index 0000000..aa69821 --- /dev/null +++ b/leafres/testarea/funkmin_UnivPhotoFit.f @@ -0,0 +1,177 @@ + subroutine funkmin_UnivPhotoFit(ndim,beta,fvalue) + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' + integer ndim + double precision beta(1:ndim),fvalue +!(in) ndim: the dimension of the parameter vector +!(in) beta: the parameters +!(out) fvalue: the value of the cost function at beta +! +!---------Local variables-------------------------------------------------- + integer i,n,ilimit0,nummismatch + double precision pointfvalue +!----------- End of variables declaration --------------------------------- +!check to see if parameters are out of bounds. + if(isitbounded.eq.1)then + do i=1,ndim + if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then +! parameter out of bound + fvalue=1.0d+100 + return + endif + enddo + endif + n=0 + do i=1,ntotunivparams +!replace the values in univparams with those optimized + if(ifixunivparams(i).eq.1)then + n=n+1 + univparams(i)=beta(n) + endif + enddo + call UnivParamsAlloc(2) + ilimit0=Currentilimittype + fvalue=0.0d0 + nummismatch=0 + do i=1,ntotsamples + if(Currentilimittype.le.4.and.Currentiknowlimit.eq.1) + &ilimit0=Currentiphotolimit(i)+4 + call leafunivphotosyn(Currentiknowlimit,ilimit0,ifitmode, + &aPPFDlf(i),templeaf(i),pco2i(i),po2i(i),chlflphips2(i), + &anet_obs(i),weitresponses(i:i,1:1),weitresponses(i:i,1:1), + &weitresponses(i:i,2:2),weitresponses(i:i,1:1), + &pco2i_pred(i),anet_pred(i),Postiphotolimit(i),pco2c(i), + &PhiPSII_pred(i),anet_pred_flu(i),pco2i_pred_flu(i), + &pco2c_anet_flu(i),pco2c_pco2i_flu(i),pointfvalue) + if(pco2c(i).lt.0.0d0.and.Currentiknowlimit.ne.-1)then + fvalue=1.0d+101 + return + endif + fvalue=fvalue+pointfvalue + if(Currentiknowlimit.eq.2.and.Currentiphotolimit(i).ne. + &Postiphotolimit(i))nummismatch=nummismatch+1 + enddo + if(nummismatch.ne.0)then +!penalize inadmissible fit + fvalue=fvalue*(dble(nummismatch)*1000.0d0)**2+ + &dble(nummismatch)*1000.0d0 + endif + return + end subroutine funkmin_UnivPhotoFit +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function f1dim_UnivPhotoFit(x) + implicit none + double precision x +CU USES funkmin_UnivPhotoFit + INTEGER j +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /f1com/ pcom,xicom,ncom + save /f1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + double precision xt(NMAX) + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call funkmin_UnivPhotoFit(ncom,xt,f1dim_UnivPhotoFit) + return + END +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + SUBROUTINE FCN_UnivPhotoFit(N,M,NP,NQ, + + LDN,LDM,LDNP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,F,FJACB,FJACD, + + ISTOP) + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' +C SUBROUTINE ARGUMENTS +C ==> N NUMBER OF OBSERVATIONS +C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N +C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M +C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP +C ==> BETA CURRENT VALUES OF PARAMETERS +C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED +C <== F PREDICTED FUNCTION VALUES +C <== FJACB JACOBIAN WITH RESPECT TO BETA +C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA +C <== ISTOP STOPPING CONDITION, WHERE +C 0 MEANS CURRENT BETA AND X+DELTA WERE +C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY +C 1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES +C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE +C -1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD STOP + +C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE: + INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ + DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M) + INTEGER IFIXB(NP),IFIXX(LDIFX,M) +C OUTPUT ARGUMENTS: + DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) + integer k + double precision fvalue +c + ISTOP=0 + do I=1,NP + if(BETA(I).lt.betamin(I).or. + &BETA(I).gt.betamax(I))then + ISTOP=1 + return + endif + enddo + do I=1,N + pco2i(I)=XPLUSD(I,1) + aPPFDlf(I)=XPLUSD(I,2) + templeaf(I)=XPLUSD(I,3) + po2i(I)=XPLUSD(I,4) + if(Currentiknowlimit.eq.-1)chlflphips2(I)=XPLUSD(I,M) + enddo + IF (MOD(IDEVAL,10).GE.1) THEN + call funkmin_UnivPhotoFit(NP,BETA,fvalue) + if(fvalue.gt.1.0d+20)then + ISTOP=1 + return + endif + DO 100 I = 1,N + if(Currentiknowlimit.eq.-1)then + F(I,1)=anet_pred_flu(I) + else + F(I,1)=anet_pred(I) + endif + 100 CONTINUE + if(NQ.eq.2)then + DO 110 I = 1,N + F(I,NQ)=PhiPSII_pred(I) + 110 CONTINUE + endif + END IF + RETURN + END +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function ff_pikaia(ndim,beta01) + implicit none + include '../testarea/LeafGasParams.h' + integer ndim,i + double precision beta01(ndim),beta(ndim),fvalue + + do i=1,ndim +! beta01(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + beta(i)=betamin(i)+beta01(i)*(betamax(i)-betamin(i)) + enddo + call funkmin_UnivPhotoFit(ndim,beta,fvalue) + ff_pikaia=1.0d0/(fvalue+0.00001d0) + return + end diff --git a/leafres/testarea/funkmin_cica5.f b/leafres/testarea/funkmin_cica5.f new file mode 100644 index 0000000..6f151f7 --- /dev/null +++ b/leafres/testarea/funkmin_cica5.f @@ -0,0 +1,50 @@ + subroutine funkmin_cica(ndim,beta,fvalue) + implicit none + + include '../testarea/cica.h' + + integer ndim + double precision beta(1:ndim),fvalue +!(in) ndim: the dimension of the parameter vector +!(in) beta: the parameters +!(out) fvalue: the value of the cost function at beta +! + integer i + double precision cica,der_cica,term,der_beta(ndim) + +!----------- End of variables declaration --------------------------------- +! +! check to see if parameters are out of bounds + + do i=1,ndim + if(beta(i).lt.bmin(i).or.beta(i).gt.bmax(i))then +! parameter out of bound + fvalue=1.0d+100 + return + endif + enddo + fvalue=0.0d0 + do i=1,nobs + term=pco2ambient(i) + call cica_ca5(imodel,ndim,beta,term,cica,der_cica,der_beta) + fvalue=fvalue+(cicameas(i)-cica)**2 + enddo + return + end subroutine funkmin_cica + +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function f1dim_cica(x) + INTEGER NMAX + double precision x + PARAMETER (NMAX=1000) +CU USES funkmin_stom + INTEGER j,ncom + double precision pcom(NMAX),xicom(NMAX),xt(NMAX) + COMMON /f1com/ pcom,xicom,ncom + + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call funkmin_cica(ncom,xt,f1dim_cica) + return + END diff --git a/leafres/testarea/funkmin_flujmax.f b/leafres/testarea/funkmin_flujmax.f new file mode 100644 index 0000000..3e6e160 --- /dev/null +++ b/leafres/testarea/funkmin_flujmax.f @@ -0,0 +1,149 @@ + subroutine funkmin_flujmax(ndim,beta,fvalue) + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' + integer ndim + double precision beta(1:ndim),fvalue +!(in) ndim: the dimension of the parameter vector +!(in) beta: the parameters +!(out) fvalue: the value of the cost function at beta +! +!---------Local variables-------------------------------------------------- + integer i + double precision fjelect,thetaPSII +!----------- End of variables declaration --------------------------------- +!check to see if parameters are out of bounds. + if(isitbounded.eq.1)then + do i=1,ndim + if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then +! parameter out of bound + fvalue=1.0d+100 + return + endif + enddo + endif + fjmax25=beta(1) + phifactor=beta(2) + thetafactor=beta(3) + if(ndim.gt.3)ha_jmax=beta(4) + fvalue=0.0d0 + do i=1,ntotlights + call jontemp(aparlights(i),templflights(i),fjelect,fjmax25, + &ha_jmax,hd_jmax,sv_jmax,gascon,phifactor,thetafactor,betaPSII) + if(aparlights(i).gt.0.0d0)then + PhiPSIIlights_pred(i)=fjelect/(betaPSII*aparlights(i)) + else + call thetaphipsii(templflights(i),PhiPSIIlights_pred(i), + &thetaPSII) + PhiPSIIlights_pred(i)=PhiPSIIlights_pred(i)*phifactor + endif + fvalue=fvalue+ +! &(fjelect-betaPSII*flphips2lights(i)*aparlights(i))**2.0d0+ + &(100.0d0*(PhiPSIIlights_pred(i)-flphips2lights(i)))**2.0d0 + enddo + return + end subroutine funkmin_flujmax +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function f1dim_flujmax(x) + implicit none + double precision x +CU USES funkmin_flujmax + INTEGER j +!(((((((((((((((((((((((((((((((((((((((((((((((((((( + integer NMAX,ncom + parameter(NMAX=1000) + double precision pcom(NMAX),xicom(NMAX) + COMMON /f1com/ pcom,xicom,ncom + save /f1com/ +!)))))))))))))))))))))))))))))))))))))))))))))))))))) + double precision xt(NMAX) + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call funkmin_flujmax(ncom,xt,f1dim_flujmax) + return + END +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + SUBROUTINE FCN_flujmax(N,M,NP,NQ, + + LDN,LDM,LDNP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,F,FJACB,FJACD, + + ISTOP) + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' +C SUBROUTINE ARGUMENTS +C ==> N NUMBER OF OBSERVATIONS +C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N +C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M +C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP +C ==> BETA CURRENT VALUES OF PARAMETERS +C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED +C <== F PREDICTED FUNCTION VALUES +C <== FJACB JACOBIAN WITH RESPECT TO BETA +C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA +C <== ISTOP STOPPING CONDITION, WHERE +C 0 MEANS CURRENT BETA AND X+DELTA WERE +C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY +C 1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES +C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE +C -1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD STOP + +C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE: + INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ + DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M) + INTEGER IFIXB(NP),IFIXX(LDIFX,M) +C OUTPUT ARGUMENTS: + DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) + integer k + double precision fvalue +c + ISTOP=0 +! do I=1,NP +! if(BETA(I).lt.betamin(I).or. +! &BETA(I).gt.betamax(I))then +! ISTOP=1 +! return +! endif +! enddo + do I=1,N + aparlights(I)=XPLUSD(I,1) + templflights(I)=XPLUSD(I,2) + enddo + IF (MOD(IDEVAL,10).GE.1) THEN + call funkmin_flujmax(NP,BETA,fvalue) + if(fvalue.gt.1.0d+20)then + ISTOP=1 + return + endif + DO 100 I = 1,N + F(I,1)=PhiPSIIlights_pred(I) + 100 CONTINUE + END IF + RETURN + END +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function flujmax_pikaia(ndim,beta01) + implicit none + include '../testarea/LeafGasParams.h' + integer ndim,i + double precision beta01(ndim),beta(ndim),fvalue + + do i=1,ndim +! beta01(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i)) + beta(i)=betamin(i)+beta01(i)*(betamax(i)-betamin(i)) + enddo + call funkmin_flujmax(ndim,beta,fvalue) + flujmax_pikaia=1.0d0/(fvalue+0.00001d0) + return + end diff --git a/leafres/testarea/funkmin_stom.f b/leafres/testarea/funkmin_stom.f new file mode 100644 index 0000000..02cf5dc --- /dev/null +++ b/leafres/testarea/funkmin_stom.f @@ -0,0 +1,51 @@ + subroutine funkmin_stom(ndim,beta,fvalue) + implicit none + + include '../testarea/stomoptim.h' + + integer ndim + double precision beta(ndim+1),fvalue +!(in) ndim: the dimension of the parameter vector +!(in) beta: the parameters +!(out) fvalue: the value of the cost function at beta +! + integer i,j + double precision stomintercept,stomslope,gswmod,rayDzero + +!----------- End of variables declaration --------------------------------- +! +! check to see if parameters are out of bounds + do i=1,ndim + if(beta(i).lt.bmin(i).or.beta(i).gt.bmax(i))then +! parameter out of bound + fvalue=1.0d+100 + return + endif + enddo + stomintercept=beta(1) + stomslope=beta(2) + if(istommodel.eq.2.or.istommodel.eq.4)rayDzero=beta(3) + fvalue=0.0d0 + do j=1,nobs + call StomatalConductance(pco2s(j),rehulfsurf(j), + & gammas(j),pvapordef_s(j),rayDzero,assim_net(j), + & istommodel,stomintercept,stomslope,gswmod) + fvalue=fvalue+(gswmeas(j)-gswmod)**2.0d0 + enddo + return + end subroutine funkmin_stom +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + double precision function f1dim_stom(x) + INTEGER NMAX + double precision x + PARAMETER (NMAX=1000) +CU USES funkmin_stom + INTEGER j,ncom + double precision pcom(NMAX),xicom(NMAX),xt(NMAX) + COMMON /f1com/ pcom,xicom,ncom + do 11 j=1,ncom + xt(j)=pcom(j)+x*xicom(j) +11 continue + call funkmin_stom(ncom,xt,f1dim_stom) + return + END diff --git a/leafres/testarea/ilimittypestats.f b/leafres/testarea/ilimittypestats.f new file mode 100644 index 0000000..fbeaf68 --- /dev/null +++ b/leafres/testarea/ilimittypestats.f @@ -0,0 +1,45 @@ + subroutine ilimittypestats(ntotpoints,iphotolimit,ilimittype, + &numrubis,numrubp,numtpu) + implicit none + integer ntotpoints,iphotolimit(ntotpoints),ilimittype, + &numrubis,numrubp,numtpu,i + + numrubis=0 + numrubp=0 + numtpu=0 + do i=1,ntotpoints + if(iphotolimit(i).eq.1)numrubis=numrubis+1 + if(iphotolimit(i).eq.2)numrubp=numrubp+1 + if(iphotolimit(i).eq.3)numtpu=numtpu+1 + enddo + if(numrubis.eq.0.and.numrubp.eq.0.and.numtpu.eq.0)then + ilimittype=0 + return + endif + if(numrubis.eq.0)then + if(numrubp.eq.0)then + ilimittype=7 + else + if(numtpu.eq.0)then + ilimittype=6 + else + ilimittype=4 + endif + endif + else + if(numrubp.eq.0)then + if(numtpu.eq.0)then + ilimittype=5 + else + ilimittype=3 + endif + else + if(numtpu.eq.0)then + ilimittype=2 + else + ilimittype=1 + endif + endif + endif + return + end diff --git a/leafres/testarea/leafanetmodel.f b/leafres/testarea/leafanetmodel.f new file mode 100644 index 0000000..ce96081 --- /dev/null +++ b/leafres/testarea/leafanetmodel.f @@ -0,0 +1,1041 @@ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine leafanetmodel(ilimittype,aPPFDlf,templeaf,pco2i,po2i, + &chlflphips2,gascon,resistwp25,resistch25,ha_gmeso,hd_gmeso, + &sv_gmeso,vcmax25,ha_vcmax,hd_vcmax,sv_vcmax,fjmax25,ha_jmax, + &hd_jmax,sv_jmax,tpu25,ha_tpu,hd_tpu,sv_tpu,alpha,rdlight25, + &ha_darkresp,stargamma25,ha_stargamma,fkc25,ha_kc,fko25,ha_ko, + &phifactor,thetafactor,betaPSII,assim_net,rdlight,iphotolimit,atp, + &resistwp,resistch,stargamma,pco2c,realizedfjelect,assim_net_flu, + &pco2c_flu) + implicit none +! +!------------ Inputs ------------------- +!ilimittype=1: Rubisco,RuBp and TPU limitations +!ilimittype=2: Rubisco and RuBp limitations only +!ilimittype=3: Rubisco and TPU limitations only +!ilimittype=4: RuBp and TPU limitations only +!ilimittype=5: Rubisco limitation only +!ilimittype=6: RuBp limitation only +!ilimittype=7: TPU limitation only +! aPPFDlf: absorbed photosynthetic photon flux density by leaf (umol m-2 s-1) +! templeaf: leaf temperature [K] +! resistwp25: resistance to CO2 via cell walls and plasmalemma [umol-1m2sPa] +! resistch25: resistance to CO2 via chloroplastic envelope [umol-1m2sPa] +! vcmax25: maximum RuBP saturated rate of carboxylation at 25oC +! of leaf temperature [umol m-2 s-1] +! fjmax25: maximum rate of electron transport at 25oC +! of leaf temperature [umol m-2 s-1] +! rdlight25: Mitochondrial respiration rate in the light at 25oC +! tpu25: tpu at 25oC, [umol m-2 s-1] +! alpha: The fraction of glycolate carbon not returned to the chloroplat +! pco2i: intercellular CO2 partial pressure (Pa). +! po2i: intercellular O2 partial pressure (Pa, often taking the ambient value). +! chlflphips2: Photochemical efficiency of photosystem II measured with fluorescence, if provided (NA) +! gascon: universal gas constant [JK-1 mol-1]. +! ha_vcmax: Ha in Vcmax temperature response function ~73637.0d0/1000.0d0 +! hd_vcmax: Hd in Vcmax temperature response function ~149252.0d0/1000.0d0 +! sv_vcmax: Sv in Vcmax temperature response function ~486.0d0/1000.0d0 +! ha_jmax: Ha in Jmax temperature response function ~50300.0d0/1000.0d0 +! hd_jmax: Hd in Jmax temperature response function ~152044.0d0/1000.0d0 +! sv_jmax: Sv in Jmax temperature response function ~495.0d0/1000.0d0 +! ha_tpu: ha in tpu temperature response function ~53100/1000 +! hd_tpu: hd in tpu temperature response function ~201800/1000 +! sv_tpu: Sv in tpu temperature response function ~650/1000 +! ha_darkresp: Mitochondrial respiation parameter deltaha = 46.39d0 +! stargamma25: the compensation point at 25oC [Pa] +! ha_stargamma: parameter in the temperature response function, typically around +! 37.83 kJmol-1 +! fkc25: the Michaelis constant for CO2 at 25oC +! ha_kc: a CO2 Michaelis temp coefficient (~79.43 KJmol-1) +! fko25: the Michaelis constant for O2 at 25oC +! ha_ko: a O2 Michaelis temp coefficient (~36.38 KJmol-1) +! ha_gmeso: The activation energy (Ha) in gmeso temperature response function ~49.6d0[kJmol-1] +! hd_gmeso: The deactivation energy (Hd) in gmeso temperature response function ~437.4d0[kJmol-1] +! sv_gmeso: The entropy term (Sv) in gmeso temperature response function ~1.4d0 [kJmol-1K-1] +! phifactor: modifies Bernacchi phiPSIImax +! thetafactor: modifies Bernacchi thetaPSII +! betaPSII: fraction of absorbed light that reaches photosystem II (~0.5) +!!3/29/2014. Bernacchi method cannot fit A/PAR curves well. phifactor and thetafactor are +!used to modify his method when A/PAR curves are present. + integer ilimittype + double precision aPPFDlf,templeaf,vcmax25,fjmax25,rdlight25, + &tpu25,alpha,pco2i,po2i,chlflphips2,gascon,ha_vcmax,hd_vcmax, + &sv_vcmax,ha_jmax,hd_jmax,sv_jmax,ha_tpu,hd_tpu,sv_tpu, + &ha_darkresp,stargamma25,ha_stargamma,fkc25,ha_kc,fko25,ha_ko, + &resistwp25,resistch25,ha_gmeso,hd_gmeso,sv_gmeso,phifactor, + &thetafactor,betaPSII +!------------ Outputs ------------------- +! assim_net: net rate of CO2 uptake per unit leaf area +! [umol m-2 s-1] +! rdlight: Mitochondrial respiration rate in the light +! [umol m-2 s-1] +! iphotolimit: index of photosynthesis limiting process +! 1 = Rubisco-limited photosynthesis +! 2 = RuBP-Limited photosynthesis +! 3 = TPU-limited photosynthesis +! stargamma: CO2 compensation point (Pa) + +! atp: the concentration of ATP (mmol ATP m-2) +! resistwp: resistance to CO2 via cell walls and plasmalemma [umol-1m2sPa] +! resistch: resistance to CO2 via chloroplastic envelope [umol-1m2sPa] +! realizedfjelect: the realized electron transport rate, <=fjelect from light equation (=when +! RuBP regeneration limits photosynthesis) (umolm-2s-1) +! assim_net_flu: assim_net calculated with chlflphips2 (if provided), umolm-2s-1 +! pco2c_flu: pco2c calculated from chlflphips2 (if provided), Pa. + double precision assim_net,rdlight,atp,pco2c,realizedfjelect, + &assim_net_flu,pco2c_flu + integer iphotolimit +!------------ Local variables ----------- +! wc: Rubisco limited rate of carboxylation [umol m-2 s-1] +! wj: RuBP limited rate of carboxylation [umol m-2 s-1] +! tpu: rate of triose phosphate utilization [umol m-2 s-1] +! atpcon: the concentration of ATP (mmol ATP m-2) +! fkco +! fkc: Michaelis constant for CO2 (Pa) +! fko: Michaelis constant for O2 (Pa) +! vcmax: maximum RuBP saturated rate of carboxylation [umol m-2 s-1] +! fjelect: rate of electron transport [umol m-2 s-1] + double precision wc,wj,tpu,atpcon,fkco,gmeso,resistwp,resistch, + &fkc,fko,vcmax,fjelect,stargamma,term + integer i + call vcmaxontemp(templeaf,vcmax25,gascon,ha_vcmax,hd_vcmax, + &sv_vcmax,vcmax) + call jontemp(aPPFDlf,templeaf,fjelect,fjmax25,ha_jmax,hd_jmax, + &sv_jmax,gascon,phifactor,thetafactor,betaPSII) + call tpuontemp(templeaf,gascon,tpu25,ha_tpu,hd_tpu,sv_tpu,tpu) + if(resistwp25.gt.0.0d0)then + call gmesoontemp(templeaf,1.0d0,gascon,ha_gmeso,hd_gmeso, + &sv_gmeso,gmeso) + resistwp=resistwp25/gmeso + else + resistwp=0.0d0 + endif + if(resistch25.gt.0.0d0)then + call gmesoontemp(templeaf,1.0d0,gascon,ha_gmeso,hd_gmeso, + &sv_gmeso,gmeso) + resistch=resistch25/gmeso + else + resistch=0.0d0 + endif + call resp_mitocho(templeaf,rdlight25,ha_darkresp,gascon,rdlight) + call co2compens(templeaf,stargamma25,ha_stargamma,gascon, + &stargamma) + call MichaelisCO2(templeaf,fkc25,ha_kc,gascon,fkc) + call MichaelisO2(templeaf,fko25,ha_ko,gascon,fko) + fkco=fkc*(1.0d0+po2i/fko) + call Anet_Final(vcmax,fjelect,tpu,resistwp,resistch,stargamma, + &fkco,pco2i,alpha,rdlight,ilimittype,iphotolimit,assim_net, + &pco2c,realizedfjelect) + wc=vcmax*pco2c/(pco2c+fkco) + wj=fjelect*pco2c/(4.0d0*pco2c+8.0d0*stargamma) + atp=atpcon(wc,wj,vcmax) + assim_net_flu=-9999.0d0 + pco2c_flu=-9999.0d0 + if(chlflphips2.gt.0.0d0)then + fjelect=betaPSII*chlflphips2*aPPFDlf + call Anet_Final(vcmax,fjelect,tpu,resistwp,resistch,stargamma, + &fkco,pco2i,alpha,rdlight,6,i,assim_net_flu,pco2c_flu,term) + endif + return + end subroutine leafanetmodel +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + double precision function threeexp(fact1,fact2,fact3) + implicit none +! +! This function computes +! threeexp=(dexp(fact3)+dexp(fact2+fact3))/(1.0d0+dexp(fact1)) +! in a way that prevents overflow +! + double precision fact1,fact2,fact3,term1,term2 + + if(fact3.gt.fact1)then + if(fact3.gt.-10.0d0)then + if((dexp(-fact3)+dexp(fact1-fact3)).lt.1.0d-20)then + term1=1.0d+30 + else + term1=1.0d0/(dexp(-fact3)+dexp(fact1-fact3)) + endif + else + term1=dexp(fact3)/(1.0d0+dexp(fact1)) + endif + else + if(fact1.gt.-10.0d0)then + term1=dexp(fact3-fact1)/(dexp(-fact1)+1.0d0) + else + term1=dexp(fact3)/(1.0d0+dexp(fact1)) + endif + endif + + if((fact2+fact3).gt.fact1)then + if((fact2+fact3).gt.-10.0d0)then + if((dexp(-fact2-fact3)+dexp(fact1-fact2-fact3)) + & .lt.1.0d-20)then + term2=1.0d+30 + else + term2=1.0d0/ + & (dexp(-fact2-fact3)+dexp(fact1-fact2-fact3)) + endif + else + term2=dexp(fact2+fact3)/(1.0d0+dexp(fact1)) + endif + else + if(fact1.gt.-10.0d0)then + term2=dexp(fact2+fact3-fact1)/(dexp(-fact1)+1.0d0) + else + term2=dexp(fact2+fact3)/(1.0d0+dexp(fact1)) + endif + endif + threeexp=term1+term2 + return + end + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine co2compens(templeaf,gammas25,ha_gammas, + & gascon,gammas) + implicit none + +! purpose: calculates CO2 compensation point. + +!------- Methods ------------------- +! Based on functions in Bernacchi, Pimentel and Long (2003), +! Plant, Cell and Environment, 26, 1419-1430 + + double precision templeaf,gascon, + & gammas,gammas25,ha_gammas + +!------- inputs -------------------- +! templeaf: leaf temperature [K] +! gascon: universal gas constant [JK-1 mol-1]. +! gammas25: the compensation point at 25oC [Pa] +! ha_gammas: parameter in the temperature response function, typically around +! 37.83 kJmol-1 +!------- outputs ------------------- +! gammas: CO2 compensation point (Pa) + + gammas=gammas25*dexp((ha_gammas/gascon)* + & (1000.0d0/298.15d0-1000.0d0/templeaf)) + return + end +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine resp_mitocho(templeaf,rdlight25, + & ha_darkresp,gascon,rdlight) + implicit none + +! purpose: calculates mitochondrial respiration rate and its +! derivative wrt. leaf temperature. + +!------- Methods ------------------- +! Based on functions in Bernacchi, Pimentel and Long (2003), +! Plant, Cell and Environment, 26, 1419-1430 + + double precision templeaf,rdlight25,gascon, + & rdlight,ha_darkresp,term + +!------- inputs -------------------- +! templeaf: leaf temperature [K] +! rdlight25: Mitochondrial respiration rate in the light at 25oC +! of leaf temperature [umol m-2 s-1] +! gascon: universal gas constant [JK-1 mol-1]. +! ha_darkresp: Mitochondrial respiation parameter deltaha = 46.39d0 unit in +! Jmol-1/1000 + +!------- outputs ------------------- +! rdlight: Mitochondrial respiration rate in the light [umol m-2 s-1] + if(ha_darkresp.lt.0.0d0)then +!The calling program uses the Q10 form. ha_darkresp is really -Q10 + term=-ha_darkresp + rdlight=rdlight25* + & (term**((templeaf-298.15d0)/10.0d0)) + else + rdlight=rdlight25*dexp((ha_darkresp/gascon)* + & (1000.0d0/298.15d0-1000.0d0/templeaf)) + endif + return + end +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine MichaelisCO2(templeaf,fkc25,ha_kc,gascon, + &fkc) + implicit none + +! purpose: calculates Michaelis constant for CO2 at a given leaf temperature. + +!------- Methods ------------------- +! Based on functions in Bernacchi, Pimentel and Long (2003), +! Plant, Cell and Environment, 26, 1419-1430 + + double precision templeaf,fkc25,ha_kc, + & gascon,fkc + +!------- inputs -------------------- +! templeaf: leaf temperature [K] +! gascon: universal gas constant [JK-1 mol-1]. +! fkc25: the Michaelis constant for CO2 at 25oC +! ha_kc: a coefficient (~79.43 KJmol-1) +!------- outputs ------------------- +! fkc: Michaelis constant for CO2 (Pa) + + fkc=fkc25*dexp((ha_kc/gascon)* + & (1000.0d0/298.15d0-1000.0d0/templeaf)) + return + end +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine MichaelisO2(templeaf,fko25,ha_ko,gascon, + &fko) + implicit none + +! purpose: calculates Michaelis constant for O2 at a given leaf temperature. + +!------- Methods ------------------- +! Based on functions in Bernacchi, Pimentel and Long (2003), +! Plant, Cell and Environment, 26, 1419-1430 + + double precision templeaf,fko25,ha_ko, + & gascon,fko + +!------- inputs -------------------- +! templeaf: leaf temperature [K] +! gascon: universal gas constant [JK-1 mol-1]. +! fko25: the Michaelis constant for O2 at 25oC +! ha_ko: a coefficient in the temp function (~36.38 KJmol-1) +!------- outputs ------------------- +! fko: Michaelis constant for CO2 (Pa) + + fko=fko25*dexp((ha_ko/gascon)* + & (1000.0d0/298.15d0-1000.0d0/templeaf)) + return + end +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! + subroutine tpuontemp(templeaf,gascon,tpu25, + & dha,dhd,ds,tpu) + implicit none +! +!(in) templeaf: leaf temperature [K] +!(in) gascon: universal gas constant [JK-1 mol-1]. +!(in) tpu25: tpu at 25 oC [umol co2 m-2 s-1] +!(in) dha ~ 53.1d0 (53100/1000) +!(in) dhd ~ 201.8d0 (201800/1000) +!(in) ds ~ 0.65d0 (650/1000) +!(out) tpu: tpu at the given leaf temperature + + double precision templeaf,gascon,tpu25, + & dha,dhd,ds,tpu +! +!-------------- Locals -------------------- + double precision t25k,univR,fact1,fact2,fact3,threeexp + + t25k=273.15d0+25.0d0 + univR=gascon/1000.0d0 + fact1=(ds*templeaf-dhd)/(univR*templeaf) + fact2=(ds*t25k-dhd)/(univR*t25k) + fact3=dha/(univR*t25k)-dha/(univR*templeaf) + + tpu=tpu25*threeexp(fact1,fact2,fact3) + return + end + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine vcmaxontemp(templeaf,vcmax25,gascon, + & ha_vcmax,hd_vcmax,sv_vcmax,vcmax) + implicit none + +! purpose: calculates maximum RuBP saturated rate of carboxylation. + +!------- Methods ------------------- +! Based on functions in Bernacchi, Pimentel and Long (2003), +! Plant, Cell and Environment, 26, 1419-1430 + + double precision templeaf,vcmax25,gascon,ha_vcmax,hd_vcmax, + & sv_vcmax,vcmax +!------- inputs -------------------- +! templeaf: leaf temperature [K] +! vcmax25: maximum RuBP saturated rate of carboxylation at 25oC +! of leaf temperature [umol m-2 s-1] +! gascon: universal gas constant [JK-1 mol-1]. +! ha_vcmax: +! hd_vcmax: +! sv_vcmax: + +!------- outputs ------------------- +! vcmax: maximum RuBP saturated rate of carboxylation [umol m-2 s-1] + +!------- Local variables ----------- + double precision threeexp + double precision T0,univR,fact1,fact2,fact3 + + univR=gascon/1000.0d0 + + T0=25.0d0+273.15d0 + fact1=(sv_vcmax*templeaf-hd_vcmax)/(univR*templeaf) + fact2=(sv_vcmax*T0-hd_vcmax)/(univR*T0) + fact3=ha_vcmax*(1.0d0-T0/templeaf)/(univR*T0) + +! threeexp=(dexp(fact3)+dexp(fact2+fact3))/(1.0d0+dexp(fact1)) + + vcmax=vcmax25*threeexp(fact1,fact2,fact3) + + return + end +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine gmesoontemp(templeaf,gmeso25,gascon, + & ha_gmeso,hd_gmeso,sv_gmeso,gmeso) + implicit none + +! purpose: calculates mesophyll CO2 conductance at a given temperature + +!------- Methods ------------------- +! Based on functions in Bernacchi, et al. (2002), +! Plant Physiology, 130, 1992-1998, or Scafaro et al. (2011), PCE 34: 1999-2008 + + double precision templeaf,gmeso25,gascon,ha_gmeso,hd_gmeso, + & sv_gmeso,gmeso +!------- inputs -------------------- +! templeaf: leaf temperature [K] +! ha_gmeso: The activation energy (Ha) in gmeso temperature response function [kJmol-1] +! hd_gmeso: The deactivation energy (Hd) in gmeso temperature response function [kJmol-1] +! sv_gmeso: The entropy term (Sv) in gmeso temperature response function [kJmol-1K-1] +! gascon: The universal gas constant (JK-1mol-1) + +!------- outputs ------------------- +! gmeso: Mesophyll CO2 transfer conductance [umol m-2 s-1 Pa-1] + +!------- Local variables ----------- + double precision T0,univR,fact1,fact2, + & fact3,threeexp + + univR=gascon/1000.0d0 + T0=25.0d0+273.15d0 +! + if(dabs(sv_gmeso+9999.0d0).lt.1.0d-5.or. + &dabs(hd_gmeso+9999.0d0).lt.1.0d-5)then + gmeso=gmeso25*dexp(ha_gmeso*(1.0d0-T0/templeaf)/(univR*T0)) + return + endif + fact1=(sv_gmeso*templeaf-hd_gmeso)/(univR*templeaf) + fact2=(sv_gmeso*T0-hd_gmeso)/(univR*T0) + fact3=ha_gmeso*(1.0d0-T0/templeaf)/(univR*T0) +! threeexp=(dexp(fact3)+dexp(fact2+fact3))/(1.0d0+dexp(fact1)) + gmeso=gmeso25*threeexp(fact1,fact2,fact3) + return + end +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine jmaxontemp(templeaf,fjmax25,gascon, + & ha_jmax,hd_jmax,sv_jmax,fjmax) + implicit none + +! purpose: calculates maximum rate of electron transport +! and its derivative wrt. leaf temperature. + +!------- Methods ------------------- +! Based on functions in Bernacchi, Pimentel and Long (2003), +! Plant, Cell and Environment, 26, 1419-1430 + +! Sept. 16, 2005. Bernacchi et al. functions are replaced by +! June et al. function, June T., J. R. Evans, G. D. Farquhar (2004) +! A simple new equation for the reversible temperature dependence of +! photosynthetic electron transport: a study on soybean leaf, +! Functional Plant Biology 31, 275-283. + + + double precision templeaf,fjmax25,gascon, + & ha_jmax,hd_jmax,sv_jmax,fjmax + +!------- inputs -------------------- +! templeaf: leaf temperature [K] +! fjmax25: maximum rate of electron transport at 25oC +! of leaf temperature [umol m-2 s-1] +! gascon: universal gas constant [JK-1 mol-1]. +! ha_jmax ~ temperature response function parameter +! hd_jmax ~ temperature response function parameter +! sv_jmax ~ temperature response function parameter + +!------- outputs ------------------- +! fjmax: maximum rate of electron transport [umol m-2 s-1] + +!------- Local variables ----------- + double precision T0,omega,threeexp + double precision univR,fact1,fact2,fact3 + + univR=gascon/1000.0d0 + + T0=25.0d0+273.15d0 + fact1=(sv_jmax*templeaf-hd_jmax)/(univR*templeaf) + fact2=(sv_jmax*T0-hd_jmax)/(univR*T0) + fact3=ha_jmax*(1.0d0-T0/templeaf)/(univR*T0) + +! threeexp=(dexp(fact3)+dexp(fact2+fact3))/(1.0d0+dexp(fact1)) + + fjmax=fjmax25*threeexp(fact1,fact2,fact3) + +! June et al. function +! ha_jmax = 30.0d0+273.15d0 +! hd_jmax = 11.6d0 +! sv_jmax = 0.18d0 +! T0=ha_jmax-273.15d0 +! omega=hd_jmax+sv_jmax*T0 +! fjmax=fjmax25*dexp( +! & (templeaf-273.15d0+25.0d0-2.0d0*T0)* +! & (25.0d0-templeaf+273.15d0)/(omega*omega)) + + return + end +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine jontemp(aPPFDlf,templeaf,fjelect,fjmax25,ha_jmax, + &hd_jmax,sv_jmax,gascon,phifactor,thetafactor,betaPSII) + implicit none + +! purpose: calculates rate of electron transport +! and its derivative wrt. leaf temperature. + +!------- Methods ------------------- +! Based on functions in Bernacchi, Pimentel and Long (2003), +! Plant, Cell and Environment, 26, 1419-1430 +!3/29/2014. Bernacchi method cannot fit A/PAR curves well. phifactor and thetafactor are +!used to modify his method when A/PAR curves are present. + double precision aPPFDlf,templeaf,fjelect,fjmax25,gascon, + &ha_jmax,hd_jmax,sv_jmax,phifactor,thetafactor,betaPSII +!------- inputs -------------------- +! aPPFDlf: absorbed photosynthetic photon flux density by leaf (umol m-2 s-1) +! templeaf: leaf temperature [K] +! fjmax25: maximum rate of electron transport at 25oC +! of leaf temperature [umol m-2 s-1] +! gascon: universal gas constant [JK-1 mol-1]. +! ha_jmax ~ 50300.0d0/1000.0d0 +! hd_jmax ~ 152044.0d0/1000.0d0 +! sv_jmax ~ 495.0d0/1000.0d0 +! phifactor: modifier for phiPSIImax +! thetafactor: modifer for thetaPSII +! betaPSII: fraction of absorbed light that reaches photosystem II (~0.5) +!------- outputs ------------------- +! fjelect: rate of electron transport [umol m-2 s-1] + +!------- Local variables ----------- + double precision Q2,phiPSIImax, + &thetaPSII,zeroT,b2_4ac,b2_4ac_sqrt,fjmax + parameter (zeroT=273.15d0) +! +! beta: fraction of absorbed qunata reaching pSII [--] +! Q2: maximum incident quanta that can be utilized in +! electron transport (umol m-2 s-1) +! phiPSIImax: Maximum dark-adapted quantum yield of PSII [--] +! thetaPSII: convexity term for electron transport rates [--] +! zeroT: zero temperature [K] +! b2-4ac: temporay variable +! b2_4ac_sqrt: sqrt of b2_4ac +! fjmax: maximum rate of electron transport, computed in the +! subroutine of jmaxontime [umol m-2 s-1] + call thetaphipsii(templeaf,phiPSIImax,thetaPSII) + phiPSIImax=phiPSIImax*phifactor + thetaPSII=thetaPSII*thetafactor + Q2=aPPFDlf*phiPSIImax*betaPSII + call jmaxontemp(templeaf,fjmax25,gascon, + & ha_jmax,hd_jmax,sv_jmax,fjmax) + b2_4ac=(Q2+fjmax)*(Q2+fjmax)-4.0d0*thetaPSII*Q2*fjmax + if(b2_4ac.lt.0.0d0)then + b2_4ac=0.0d0 + endif + b2_4ac_sqrt=dsqrt(b2_4ac) + fjelect=(Q2+fjmax-b2_4ac_sqrt)/(2.0d0*thetaPSII) + return + end +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine jmaxfromj(aPPFDlf,templeaf,fjelect,fjmax, + &phifactor,thetafactor,betaPSII) + implicit none +! purpose: calculates jmax from the rate of electron transport, +! leaf temperature and absorbed PAR + +!------- Methods ------------------- +! Based on functions in Bernacchi, Pimentel and Long (2003), +! Plant, Cell and Environment, 26, 1419-1430 +!3/29/2014. Bernacchi method cannot fit A/PAR curves well. phifactor and thetafactor are +!used to modify his method when A/PAR curves are present. +! + double precision aPPFDlf,templeaf,fjelect,fjmax, + &phifactor,thetafactor,betaPSII +!------- inputs -------------------- +! aPPFDlf: absorbed photosynthetic photon flux density by leaf (umol m-2 s-1) +! templeaf: leaf temperature [K] +! fjelect: rate of electron transport [umol m-2 s-1] +! phifactor: modifier for phiPSIImax +! thetafactor: modifer for thetaPSII +! betaPSII: the fracction of absorbed light that reaches photosystem II (~0.5) +!------- outputs ------------------- +! fjmax: maximum rate of electron transport +! of leaf temperature [umol m-2 s-1] + +!------- Local variables ----------- + double precision Q2,phiPSIImax,thetaPSII,zeroT + parameter (zeroT=273.15d0) +! +! beta: fraction of absorbed qunata reaching pSII [--] +! Q2: maximum incident quanta that can be utilized in +! electron transport (umol m-2 s-1) +! phiPSIImax: Maximum dark-adapted quantum yield of PSII [--] +! thetaPSII: convexity term for electron transport rates [--] +! zeroT: zero temperature [K] +! + call thetaphipsii(templeaf,phiPSIImax,thetaPSII) + phiPSIImax=phiPSIImax*phifactor + thetaPSII=thetaPSII*thetafactor + Q2=aPPFDlf*phiPSIImax*betaPSII + fjmax=(thetaPSII*fjelect-Q2)*fjelect/(fjelect-Q2) + return + end + + subroutine thetaphipsii(templeaf0,phiPSIImax,thetaPSII) + implicit none +! Based on functions in Bernacchi, Pimentel and Long (2003), +! Plant, Cell and Environment, 26, 1419-1430 + +! templeaf0: leaf temperature [K] +!------- outputs ------------------- +! phiPSIImax: Maximum dark-adapted quantum yield of PSII [--] +! thetaPSII: convexity term for electron transport rates [--] + double precision phiPSIImax,thetaPSII,templeaf0 + double precision zeroT,templeaf + parameter (zeroT=273.15d0) +! zeroT: zero temperature [K] + + templeaf=dmax1(zeroT+5.0d0,templeaf0) + templeaf=dmin1(zeroT+45.0d0,templeaf) + phiPSIImax=0.352d0+0.022d0*(templeaf-zeroT)-3.4d-4* + & (templeaf-zeroT)*(templeaf-zeroT) + thetaPSII=0.76d0+0.018d0*(templeaf-zeroT)-3.7d-4* + & (templeaf-zeroT)*(templeaf-zeroT) + return + end +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! + double precision function atpcon(wc,wj,vcmax) + implicit none +! +! Calculate the concentration of ATP provided by photophosphorylation +! based on Buckley et al. (2003), Plant, Cell and Environment, 26, 1767-1785. +! +! ------ Inputs --------------------------------------------------- +! wc: Rubisco limited rate of carboxylation [umol m-2 s-1] +! wj: RuBP limited rate of carboxylation [umol m-2 s-1] +! vcmax: maximum RuBP saturated rate of carboxylation [umol m-2 s-1] + double precision wc,wj,vcmax +! +! ------ Outputs --------------------------------------------------- +! atpcon: the concentration of ATP (mmol ATP m-2) + +! ------ Local variables -------------------------------------------- +! at: at in Buckley et al (2003), total concentration of adenylates +! [mmol AxP m-2] +! p: p in Buckley et al (2003), concentration of photophosphorylation +! sites [mmol sites m-2] +! Communication with Buckley reveals error in Table 1 in Buckley paper +! at and p should be divided by 100. +! vr: Vr in Buckley et al (2003), carboxylation rate limited by potential +! RuBP pool size only [umol m-2 s-1] +! tau0: basal ATP level provided by other processes [mmol ATP m-2] +! tauc: atpcon when wc limiting mmol m-2 +! tauj: atpcon when wj limiting mmol m-2 + + double precision at,p,vr,tau0,tauc,tauj + parameter(tau0=1.6d0) + + if(wj.le.0.0d0)then + atpcon=tau0 + else + at=12.6d0*vcmax/100.0d0 + p=2.5d0*vcmax/100.0d0 + vr=2.27d0*vcmax + tauc=at-p*wc/wj + tauj=(at-p)*(vr/vcmax-1.0d0)/(wc*vr/(wj*vcmax)-1.0d0) + if(wc.lt.wj)then + atpcon=tau0+tauc + else + atpcon=tau0+tauj + endif + endif + return + end +! +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine QSat (T, p, es, esdT, qs, + & qsdT) + implicit none +!----------------------------------------------------------------------- +! +! CLMCLMCLMCLMCLMCLMCLMCLMCLMCL A community developed and sponsored, freely +! L M available land surface process model. +! M --COMMUNITY LAND MODEL-- C +! C L +! LMCLMCLMCLMCLMCLMCLMCLMCLMCLM +! +!----------------------------------------------------------------------- +! Purpose: +! Computes saturation mixing ratio and the change in saturation +! mixing ratio with respect to temperature. + +! Method: +! Reference: Polynomial approximations from: +! Piotr J. Flatau, et al.,1992: Polynomial fits to saturation +! vapor pressure. Journal of Applied Meteorology, 31, 1507-1513. +! +! Author: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! April 2002: Vertenstein/Oleson/Levis; Final form +! +!----------------------------------------------------------------------- +! $Id: QSat.F90,v 1.1.8.4 2002/04/10 19:25:07 mvertens Exp $ +!----------------------------------------------------------------------- + +! use precision +! use shr_const_mod, ONLY: SHR_CONST_TKFRZ +! implicit none + +!----Arguments---------------------------------------------------------- + + DOUBLE PRECISION T, p + DOUBLE PRECISION es, esdT, qs, qsdT + DOUBLE PRECISION SHR_CONST_TKFRZ + PARAMETER (SHR_CONST_TKFRZ=273.16d0) + +! real(r8), intent(in) :: T ! temperature (K) +! real(r8), intent(in) :: p ! surface atmospheric pressure (pa) + +! real(r8), intent(out) :: es ! vapor pressure (pa) +! real(r8), intent(out) :: esdT ! d(es)/d(T) +! real(r8), intent(out) :: qs ! humidity (kg vapor/kg moist air) +! real(r8), intent(out) :: qsdT ! d(qs)/d(T) + +!----Local Variables---------------------------------------------------- + + DOUBLE PRECISION T_limit + DOUBLE PRECISION td,vp,vp1,vp2 + DOUBLE PRECISION a0,a1,a2,a3,a4,a5,a6,a7,a8 + DOUBLE PRECISION b0,b1,b2,b3,b4,b5,b6,b7,b8 + DOUBLE PRECISION c0,c1,c2,c3,c4,c5,c6,c7,c8 + DOUBLE PRECISION d0,d1,d2,d3,d4,d5,d6,d7,d8 + +! real(r8) T_limit ! limitation on valid temperatures [C] + +! real(r8) td,vp,vp1,vp2 +! real(r8) a0,a1,a2,a3,a4,a5,a6,a7,a8 +! real(r8) b0,b1,b2,b3,b4,b5,b6,b7,b8 + +! real(r8) c0,c1,c2,c3,c4,c5,c6,c7,c8 +! real(r8) d0,d1,d2,d3,d4,d5,d6,d7,d8 + +! +! For water vapor (temperature range 0C-100C) +! + data a0/6.11213476d0/,a1/0.444007856d0/,a2/0.143064234d-01/, + & a3/0.264461437d-03/,a4/0.305903558d-05/,a5/0.196237241d-07/, + & a6/0.892344772d-10/,a7/-0.373208410d-12/,a8/0.209339997d-15/ + +! +! For derivative:water vapor +! + data b0/0.444017302d0/,b1/0.286064092d-01/,b2/0.794683137d-03/, + & b3/0.121211669d-04/,b4/0.103354611d-06/,b5/0.404125005d-09/, + & b6/-0.788037859d-12/,b7/-0.114596802d-13/,b8/0.381294516d-16/ + +! +! For ice (temperature range -75C-0C) +! + data c0/6.11123516d0/,c1/0.503109514d0/,c2/0.188369801d-01/, + & c3/0.420547422d-03/,c4/0.614396778d-05/,c5/0.602780717d-07/, + & c6/0.387940929d-09/,c7/0.149436277d-11/,c8/0.262655803d-14/ + +! +! For derivative:ice +! + data d0/0.503277922d0/,d1/0.377289173d-01/,d2/0.126801703d-02/, + & d3/0.249468427d-04/,d4/0.313703411d-06/,d5/0.257180651d-08/, + & d6/0.133268878d-10/,d7/0.394116744d-13/,d8/0.498070196d-16/ + +!----End Variable List-------------------------------------------------- + + T_limit = T - SHR_CONST_TKFRZ + if (T_limit .GT. 100.0d0) T_limit=100.0d0 + if (T_limit .LT. -75.0d0) T_limit=-75.0d0 + + td = T_limit + if(td .GE. 0.0d0) then + es=a0+td*(a1+td*(a2+td*(a3+td*(a4+ + & td*(a5 + td*(a6 + td*(a7 + td*a8))))))) + esdT=b0+td*(b1+td*(b2+td*(b3+td*(b4+ + & td*(b5+td*(b6+td*(b7+td*b8))))))) + else + es=c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 + & + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) + esdT=d0+td*(d1+td*(d2 + td*(d3 + td*(d4 + & + td*(d5 + td*(d6 + td*(d7 + td*d8))))))) + endif + + es = es * 100.0d0 +! pa + esdT = esdT * 100.0d0 +! pa/K + vp = 1.00d0 / (p - 0.378d0*es) + vp1 = 0.622d0 * vp + vp2 = vp1 * vp + + qs = es * vp1 +! kg/kg + qsdT = esdT * vp2 * p +! 1 / K + end + + double precision function esat(T, p) + implicit none +!----------------------------------------------------------------------- +! +! CLMCLMCLMCLMCLMCLMCLMCLMCLMCL A community developed and sponsored, freely +! L M available land surface process model. +! M --COMMUNITY LAND MODEL-- C +! C L +! LMCLMCLMCLMCLMCLMCLMCLMCLMCLM +! +!----------------------------------------------------------------------- +! Purpose: +! Computes saturation mixing ratio and the change in saturation +! mixing ratio with respect to temperature. + +! Method: +! Reference: Polynomial approximations from: +! Piotr J. Flatau, et al.,1992: Polynomial fits to saturation +! vapor pressure. Journal of Applied Meteorology, 31, 1507-1513. +! +! Author: +! 15 September 1999: Yongjiu Dai; Initial code +! 15 December 1999: Paul Houser and Jon Radakovich; F90 Revision +! April 2002: Vertenstein/Oleson/Levis; Final form +! +!----------------------------------------------------------------------- +! $Id: QSat.F90,v 1.1.8.4 2002/04/10 19:25:07 mvertens Exp $ +!----------------------------------------------------------------------- + +! use precision +! use shr_const_mod, ONLY: SHR_CONST_TKFRZ +! implicit none + +!----Arguments---------------------------------------------------------- + + DOUBLE PRECISION T, p + DOUBLE PRECISION es + DOUBLE PRECISION SHR_CONST_TKFRZ + PARAMETER (SHR_CONST_TKFRZ=273.15d0) + +! real(r8), intent(in) :: T ! temperature (K) +! real(r8), intent(in) :: p ! surface atmospheric pressure (pa) + +! real(r8), intent(out) :: es ! vapor pressure (pa) + +!----Local Variables---------------------------------------------------- + + DOUBLE PRECISION T_limit + DOUBLE PRECISION td + DOUBLE PRECISION a0,a1,a2,a3,a4,a5,a6,a7,a8 + DOUBLE PRECISION b0,b1,b2,b3,b4,b5,b6,b7,b8 + DOUBLE PRECISION c0,c1,c2,c3,c4,c5,c6,c7,c8 + + +! real(r8) T_limit ! limitation on valid temperatures [C] + +! real(r8) td +! real(r8) a0,a1,a2,a3,a4,a5,a6,a7,a8 + +! real(r8) c0,c1,c2,c3,c4,c5,c6,c7,c8 + +! For water vapor (temperature range 0C-100C) +! + data a0/6.11213476d0/,a1/0.444007856d0/,a2/0.143064234d-01/, + & a3/0.264461437d-03/,a4/0.305903558d-05/,a5/0.196237241d-07/, + & a6/0.892344772d-10/,a7/-0.373208410d-12/,a8/0.209339997d-15/ + +! +! For ice (temperature range -75C-0C) +! + data c0/6.11123516d0/,c1/0.503109514d0/,c2/0.188369801d-01/, + & c3/0.420547422d-03/,c4/0.614396778d-05/,c5/0.602780717d-07/, + & c6/0.387940929d-09/,c7/0.149436277d-11/,c8/0.262655803d-14/ + + +!----End Variable List-------------------------------------------------- + + T_limit = T - SHR_CONST_TKFRZ + if (T_limit .GT. 100.0d0) T_limit=100.0d0 + if (T_limit .LT. -75.0d0) T_limit=-75.0d0 + + td = T_limit + if(td .GE. 0.0d0) then + es=a0+td*(a1+td*(a2+td*(a3+td*(a4+ + & td*(a5 + td*(a6 + td*(a7 + td*a8))))))) + else + es=c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 + & + td*(c5 + td*(c6 + td*(c7 + td*c8))))))) + endif + + es = es * 100.0d0 +! pa + esat=es + +!The following is what used in Li-Cor 6400 so we use it for A/Ci analysis + esat=613.65d0*dexp(17.502d0*(T-273.15d0)/ + & (240.97d0+T-273.15d0)) + return + end +! +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine metvarconverter(airtemp,pres_moistair,vpd, + & pres_h2ovapor,rh,gascon,vapormixingratio,spechumid, + & cp_moistair,dens_moistair,dewpoint,wmoistair) + implicit none +! +! =============Inputs=================================== +! airtemp: air temperature [K] +! pres_moistair: air pressure [Pa] +! rh or vpd or pres_h2ovapor: one of the three must be inputs +! rh: relative humidity [%] +! vpd: vapor pressure deficit [Pa] +! pres_h2ovapor: water vapor partial pressure [Pa] +! gascon: universal gas constant [J K-1 mol-1] +! + double precision airtemp,pres_moistair,vpd, + & pres_h2ovapor,rh,gascon + +!==============Outputs=================================== +! rh, vpd, and pres_h2ovapor: if not provided as inputs +! vapormixingratio: water vapor mixing ratio [g vapor / g dry air] +! spechumid: specific humidity [g vapor / g moist air] +! cp_moistair: specific heat of the moist air [J g-1 K-1] +! dens_moistair: density of the moist air [gm-3] +! dewpoint: dewpoint temperature [K] +! wmoistair: molecular weight of moist air [g mol-1] +! + double precision vapormixingratio,spechumid, + & cp_moistair,dens_moistair,dewpoint,wmoistair + +!==============Locals=================================== +! dryairmw: molecular weight of the dry air [g mol-1] +! h2omw: molecular weight of water [g mol-1] +! cp_dryair: specific heat of dry air [J g-1 K-1] +! cp_watervapor: specific heat of water vapor [J g-1 K-1] +! es: saturation vapor pressure [Pa] +! esdT: not used +! qs: specific humidity at saturation [g vapor / g moist air] +! qsdT: not used +! pres_dryair: partial pressure of the dry air [Pa] +! dens_dryair: density of the dry air [gm-3] +! dens_vapor: density of water vapor [gm-3] +! ws: mixing ratio at saturation [ density vapor / density dry air] +! abszero: absolute zero temperature [K] +! latent: latent heat of vaporization [J g-1] + + double precision dryairmw,h2omw,cp_dryair,cp_watervapor, + & es,esdT,qs,qsdT,pres_dryair,dens_dryair,dens_vapor,esat, + & ws,abszero,latent + parameter(dryairmw=28.9644d0,h2omw=18.016d0) + parameter(cp_dryair=1.00467d0,cp_watervapor=1.84d0) + parameter(abszero=273.15d0) + +! + if((rh.le.0.0d0.or.rh.gt.100.02d0).and.(vpd.lt.0.0d0.or. + & vpd.gt.9000.0d0).and.(pres_h2ovapor.le.0.0d0.or. + & pres_h2ovapor.gt.9000.0d0))then + write(*,*)'At least of the one variables VPD, RH, and + & water vapor partial pressure must be valid. + & check your data. Program stops' + stop + endif + call QSat(airtemp,pres_moistair,es,esdT,qs,qsdT) + ws=qs/(1.0d0-qs) + + if((rh.le.0.0d0.or.rh.gt.100.0d0).or.(vpd.le.0.0d0.or. + & vpd.gt.9000.0d0).or.(pres_h2ovapor.le.0.0d0.or. + & pres_h2ovapor.gt.9000.0d0))then + if(pres_h2ovapor.gt.0.0d0.and.pres_h2ovapor.lt.9000.0d0)then + pres_dryair=pres_moistair-pres_h2ovapor + dens_dryair=pres_dryair*dryairmw/(gascon*airtemp) + dens_vapor=pres_h2ovapor*h2omw/(gascon*airtemp) + vapormixingratio=dens_vapor/dens_dryair + vpd=es-pres_h2ovapor + vpd=dmin1(es,vpd) + vpd=dmax1(0.0d0,vpd) + rh=vapormixingratio*100.0d0/ws + rh=dmin1(100.0d0,rh) + rh=dmax1(0.0d0,rh) + else + if(rh.gt.0.0d0.and.rh.le.100.01d0)then + vapormixingratio=ws*dmin1(rh,100.0d0)/100.0d0 + pres_h2ovapor=vapormixingratio*pres_moistair/( + & vapormixingratio+h2omw/dryairmw) + vpd=es-pres_h2ovapor + else + if(vpd.ge.0.0d0.and.vpd.lt.9000.0d0)then + pres_h2ovapor=es-vpd + pres_h2ovapor=dmin1(es,pres_h2ovapor) + pres_h2ovapor=dmax1(0.0d0,pres_h2ovapor) + pres_dryair=pres_moistair-pres_h2ovapor + dens_dryair=pres_dryair*dryairmw/(gascon*airtemp) + dens_vapor=pres_h2ovapor*h2omw/(gascon*airtemp) + vapormixingratio=dens_vapor/dens_dryair + rh=vapormixingratio*100.0d0/ws + endif + endif + endif + endif + pres_dryair=pres_moistair-pres_h2ovapor + dens_dryair=pres_dryair*dryairmw/(gascon*airtemp) + dens_vapor=pres_h2ovapor*h2omw/(gascon*airtemp) + dens_moistair=dens_dryair+dens_vapor + vapormixingratio=dens_vapor/dens_dryair + spechumid=dens_vapor/dens_moistair + cp_moistair=(cp_dryair*dens_dryair+ + & cp_watervapor*dens_vapor)/dens_moistair + + latent=1.91846d+3*(airtemp/(airtemp-33.91d0))* + & (airtemp/(airtemp-33.91d0)) + call QSat(abszero,pres_moistair,es,esdT,qs,qsdT) + dewpoint=1.0d0/abszero-(gascon/(h2omw*latent))* + & dlog(pres_h2ovapor/es) + dewpoint=1.0d0/dewpoint + wmoistair=dens_moistair*gascon*airtemp/pres_moistair + return + end +! +c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + double precision function latent(temp) +c +c This function calculates latent heat from temperature. The formulae +c is taken from Henderson-sellers, 1984, A new formulae for latent heat +c of vaporation of water as a function of temperature, Quart. J. R. Met. +c Soc. 1984, 110 pp. 1186-1190. +c +c temp: temperature in K. +c latent: latent heat of water in J g-1. + + implicit double precision (a-h,l,o-z) + parameter(abszero=273.15d0,fusionheat=333.7d0) +! + latent=1.91846d+3*(temp/(temp-33.91d0))* + & (temp/(temp-33.91d0)) +! +! assume freezing or sublimation occurs at 273.15d0 K +! latent heat of fusion is 333.7 J/g +! + if(temp.le.abszero)then + latent=latent+fusionheat + endif + return + end +c + +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/leafres/testarea/leafunivphotosyn.f b/leafres/testarea/leafunivphotosyn.f new file mode 100644 index 0000000..af98e29 --- /dev/null +++ b/leafres/testarea/leafunivphotosyn.f @@ -0,0 +1,258 @@ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine leafunivphotosyn(Currentiknowlimit0,ilimittype0, + &ifitmode0,aPPFDlf,templeaf,pco2i_obs0,po2i,chlflphips20,anet_obs0, + &weitpco2i0,weitanet0,weitphips20,weitfjelect0,pco2i_pred0, + &anet_pred0,iphotolimit0,pco2c0,PhiPSII_pred,anet_pred_flu0, + &pco2i_pred_flu0,pco2c_anet_flu0,pco2c_pco2i_flu0,fvalue) + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/pco2ianetfunc.h' +!------------ Inputs ------------------- +!ilimittype=1: Rubisco,RuBp and TPU limitations +! =2: Rubisco and RuBp limitations only +! =3: Rubisco and TPU limitations only +! =4: RuBp and TPU limitations only +! =5: Rubisco limitation only +! =6: RuBp limitation only +! =7: TPU limitation only +!aPPFDlf: absorbed photosynthetic photon flux density by leaf (umol m-2 s-1) +!templeaf: leaf temperature [K] +!pco2i_obs: measured intercellular CO2 partial pressure (Pa). +!po2i: intercellular O2 partial pressure (Pa, often taking the ambient value). +!chlflphips2: photochemical efficiency of photosynthesis (NA), if provided +!anet_obs: meausred net rate of CO2 uptake per unit leaf area [umol m-2 s-1] +!ifitmode: =-2, ordinary fitting with pco2i calculated as a function of anet +!ifitmode: =-1, ordinary fitting with anet calculated as a function of pco2i +!ifitmode: =1, orthogonal fitting with anet calculated as a function of pco2i +!ifitmode: =2, orthogonal fitting with pco2i calculated as a function of anet +!------------ Outputs ------------------- +!anet_pred: net rate of CO2 uptake per unit leaf area calculated from pco2i_obs and photosynthetic parameters [umol m-2 s-1] +!iphotolimit_anet: the limitation state of the photosynthesis determined with anet as the response variable and pco2i as one independent variable +!pco2c_anet: chloroplastic CO2 partial pressure calculated with anet as a response +!fjelect_anet: the realized electron transport rate <= jrubp (=when RuBP regeneration limits photosynthesis) determined with anet as the response +! variable and pco2i as one independent variable. +!anet_pred_flu: if chlflphips2 is provided, net rate of CO2 uptake per unit leaf area calculated from photochemical efficiency. anet is a response. [umol m-2 s-1], +!pco2c_anet_flu: chloroplastic CO2 partial pressure calculated from fluorescence data with anet as a response (Pa) +! +!pco2i_pred: intercellular CO2 partial pressure calculated from anet_obs and photosynthetic parameters [Pa] +!iphotolimit_pco2i: the limitation state of the photosynthesis determined with pco2i as the response variable and anet as one independent variable +!pco2c_pco2i: chloroplastic CO2 partial pressure calculated with pco2i as a response +!fjelect_pco2i: the realized electron transport rate <= jrubp (=when RuBP regeneration limits photosynthesis) determined with pco2i as the response +! variable and anet as one independent variable. +!pco2i_pred_flu: if chlflphips2 is provided, intercellular CO2 partial pressure calculated from photochemical efficiency. pco2i is a response. [Pa] +!pco2c_pco2i_flu: chloroplastic CO2 partial pressure calculated from fluorescence data with pco2i as a response (Pa) +!Note: when alpha25 = 0, pco2i cannot be solved from anet because anet is independent of pco2i and pco2c. so when TPU is limitting, we always treat +! anet as a response and pco2i as an independent. + integer Currentiknowlimit0,ilimittype0,ifitmode0,iphotolimit0 + double precision aPPFDlf,templeaf,pco2i_obs0,po2i,chlflphips20, + &anet_obs0,weitpco2i0,weitanet0,weitphips20,weitfjelect0, + &pco2i_pred0,anet_pred0,pco2c0,PhiPSII_pred,anet_pred_flu0, + &pco2i_pred_flu0,pco2c_anet_flu0,pco2c_pco2i_flu0,fvalue +!------------ Local variables ----------- + integer ierr,n + double precision fkc,fko,ax,bx,cx,fa,fb,fc,lowerbound,upperbound, + &pco2ianetfunc,term,x_pred,deltafract,step,TOL,leafbrent,dum, + &thetaPSII + parameter(TOL=1.0d-7,deltafract=0.2d0) + + Currentiknowlimit=Currentiknowlimit0 + ilimittype=ilimittype0 + ifitmode=ifitmode0 + pco2i_obs=pco2i_obs0 + chlflphips2=chlflphips20 + anet_obs=anet_obs0 + weitpco2i=weitpco2i0 + weitanet=weitanet0 + weitphips2=weitphips20 + weitfjelect=weitfjelect0 + alpha=alpha25 + if(Currentiknowlimit.ne.-1)then + call vcmaxontemp(templeaf,vcmax25,gascon,ha_vcmax,hd_vcmax, + &sv_vcmax,vcmax) + call jontemp(aPPFDlf,templeaf,fjelect,fjmax25,ha_jmax, + &hd_jmax,sv_jmax,gascon,phifactor,thetafactor,betaPSII) + call tpuontemp(templeaf,gascon,tpu25,ha_tpu,hd_tpu,sv_tpu,tpu) + if(chlflphips2.gt.0.0d0)then + chlflfjelect=betaPSII*chlflphips2*aPPFDlf + if(aPPFDlf.lt.0.0d0)then + call thetaphipsii(templeaf,PhiPSIImax,thetaPSII) + PhiPSIImax=PhiPSIImax*phifactor + endif + endif + else + if(chlflphips2.gt.0.0d0)then + fjelect=betaPSII*chlflphips2*aPPFDlf + else + fvalue=0.0d0 + return + endif + endif + call gmesoontemp(templeaf,1.0d0,gascon,ha_gmeso,hd_gmeso, + &sv_gmeso,term) + resistwp=resistwp25/term + resistch=resistch25/term + call resp_mitocho(templeaf,rdlight25,ha_darkresp,gascon,rdlight) + call co2compens(templeaf,stargamma25,ha_stargamma,gascon, + &stargamma) + call MichaelisCO2(templeaf,fkc25,ha_kc,gascon,fkc) + call MichaelisO2(templeaf,fko25,ha_ko,gascon,fko) + fkco=fkc*(1.0d0+po2i/fko) + if(ifitmode.eq.-1)then + ifitmode=1 + fvalue=pco2ianetfunc(pco2i_obs) + goto 100 + endif + if(ifitmode.eq.-2)then + ifitmode=2 + fvalue=pco2ianetfunc(anet_obs) + goto 100 + endif + if(ifitmode.eq.1)then + term=pco2i_obs + upperbound=term*(1.0d0+deltafract) + lowerbound=term*(1.0d0-deltafract) + ax=term*(1.0d0-deltafract/5.0d0) + bx=term + endif + if(ifitmode.eq.2)then + term=dmax1(2.0d0,dabs(anet_obs)) + upperbound=anet_obs+term*deltafract + lowerbound=anet_obs-term*deltafract + ax=anet_obs-term*deltafract/5.0d0 + bx=anet_obs + endif + n=0 +10 call leafmnbrak(ax,bx,cx,fa,fb,fc,lowerbound,upperbound, + &ierr,pco2ianetfunc) + if(ierr.ne.0)then + if(n.le.50)then + if(fb.gt.fa)then + dum=ax + ax=bx + bx=dum + dum=fa + fa=fb + fb=dum +!from ax to bx, f decreases + endif + if(fc.gt.fb)then + if(fc.lt.fa)then + dum=bx + bx=cx + cx=dum + dum=fc + fc=fb + fb=dum + else + dum=ax + ax=cx + cx=dum + dum=fc + fc=fa + fa=dum + endif + endif +!from ax to bx to cx, f decreases + if(dabs(cx-bx).lt.dabs(cx-ax))then + if(ax.gt.cx)then + lowerbound=lowerbound-term*deltafract + else + upperbound=upperbound+term*deltafract + endif + ax=lowerbound+(upperbound-lowerbound)*0.5d0 + bx=lowerbound+(upperbound-lowerbound)*0.51d0 + n=n+1 + goto 10 + else + if(ifitmode.eq.1)x_pred=pco2i_obs + if(ifitmode.eq.2)x_pred=anet_obs + endif + else + if(ifitmode.eq.1)x_pred=pco2i_obs + if(ifitmode.eq.2)x_pred=anet_obs + endif + endif + fvalue=leafbrent(ax,bx,cx,pco2ianetfunc,TOL,x_pred) + fvalue=pco2ianetfunc(x_pred) +100 pco2i_pred0=pco2i_pred + anet_pred0=anet_pred + if(aPPFDlf.gt.0.0d0)then + PhiPSII_pred=realizedfjelect/(betaPSII*aPPFDlf) + else + PhiPSII_pred=PhiPSIImax + endif + iphotolimit0=iphotolimit + pco2c0=pco2c + anet_pred_flu0=anet_pred_flu + pco2i_pred_flu0=pco2i_pred_flu + pco2c_anet_flu0=pco2c_anet_flu + pco2c_pco2i_flu0=pco2c_pco2i_flu + return + end + + double precision function pco2ianetfunc(x) + implicit none + include '../testarea/pco2ianetfunc.h' +!local variables + integer iph + double precision x,term,term1,term2,term3,pco2c_wp,anet_wp + if(ifitmode.eq.1)then +!anet as a function of pco2i + pco2i_pred=x + call Anet_Final(vcmax,fjelect,tpu,resistwp,resistch,stargamma, + &fkco,pco2i_pred,alpha,rdlight,ilimittype,iphotolimit,anet_pred, + &pco2c,realizedfjelect) + pco2ianetfunc=(weitpco2i*(pco2i_obs-pco2i_pred))**2+ + &(weitanet*(anet_obs-anet_pred))**2 + endif + if(ifitmode.eq.2)then +!pco2i as a function of anet + anet_pred=x + call CO2i_Final(vcmax,fjelect,tpu,resistwp,resistch,stargamma, + &fkco,pco2i_pred,alpha,rdlight,ilimittype,iphotolimit, + &anet_pred,pco2c,realizedfjelect,pco2i_obs,pco2c_wp,anet_wp) + if(iphotolimit.eq.3.and.alpha.le.0.0d0)then +!anet is independent of pco2i. assume no error in pco2i. ensure the optimized x = 3*tpu-rd. Vc for tpu +!is computed from the forward mode, i.e. the same as in ifitmode=1 + pco2i_pred=pco2i_obs + anet_pred=anet_wp + pco2c=pco2c_wp + pco2ianetfunc=(weitanet**2)* + &((anet_obs-anet_pred)**2+(x-anet_pred)**2) + else + pco2ianetfunc=(weitpco2i*(pco2i_obs-pco2i_pred))**2+ + &(weitanet*(anet_obs-anet_pred))**2 + endif + endif + if(Currentiknowlimit.ne.-1.and.chlflphips2.gt.0.0d0)then +!use either option 1 or option 2 or option 3 +!option 1 + if(chlflfjelect.gt.0.0d0)then + pco2ianetfunc=pco2ianetfunc+(weitphips2* + &chlflphips2*(1.0d0-realizedfjelect/chlflfjelect))**2 + else + pco2ianetfunc=pco2ianetfunc+ + &(weitphips2*(chlflphips2-PhiPSIImax))**2 + endif +!option 2 + pco2ianetfunc=pco2ianetfunc+ + &(weitfjelect*(chlflfjelect-realizedfjelect))**2 +!option 3 + if(ifitmode.eq.1)then + call Anet_Final(vcmax,chlflfjelect,tpu,resistwp,resistch, + &stargamma,fkco,pco2i_pred,alpha,rdlight,6,iph,anet_pred_flu, + &pco2c_anet_flu,term) + pco2ianetfunc=pco2ianetfunc+ + &(weitanet*(anet_pred-anet_pred_flu))**2 + endif + if(ifitmode.eq.2)then + call CO2i_Final(vcmax,chlflfjelect,tpu,resistwp,resistch, + &stargamma,fkco,pco2i_pred_flu,alpha,rdlight,6,iph,anet_pred, + &pco2c_pco2i_flu,term,term1,term2,term3) + pco2ianetfunc=pco2ianetfunc+ + &(weitpco2i*(pco2i_pred-pco2i_pred_flu))**2 + endif + endif + return + end +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/leafres/testarea/pam_parameters.f b/leafres/testarea/pam_parameters.f new file mode 100644 index 0000000..d73953e --- /dev/null +++ b/leafres/testarea/pam_parameters.f @@ -0,0 +1,189 @@ + subroutine pam_parameters(nsamples,fo,fm,fs,measlight,anet, + &actiniclight,tempK,yield_ps2,yield_npq,qlake,qpuddle,kps2_norm, + &knpq_norm,fo_dark,fm_dark,resp_dark,tempK_dark) + implicit none +!Calculate fluorescence parameters +!The dark-adapted measurements must be put in the beginning of the data section and the +!corresponding par must be set to zero. If the dark-adapted measurements are sampled +!multiple times, these multiple samples must be put immediately one after the other. + integer nsamples + double precision fo(nsamples),fm(nsamples),fs(nsamples), + &measlight(nsamples),anet(nsamples),actiniclight(nsamples), + &tempK(nsamples),yield_ps2(nsamples),yield_npq(nsamples), + &qlake(nsamples),qpuddle(nsamples),kps2_norm(nsamples), + &knpq_norm(nsamples),fo_dark,fm_dark,resp_dark,tempK_dark +! +!==============Inputs========================================== +!nsamples: The total number of samples +!fo: The fluorescence yield in the dark (zero PARi). It is measured on either +! a dark-adapted leaf or a previously illuminated leaf with the actinic light +! turned off and a far-red light applied to energize PSI to drain electrons from +! PSII and reoxidize QA. In other words, here fo can be either fo or fo'(to be indicated by PAR value) +!fm: The fluorescence yield with the all PSII reaction centers closed (all QAs fully +! reduced) by a saturating pulse of light. It is either fm or fm' (to be indicated by PAR value) +!fs: The steady-state fluorescence yield of an illuminated leaf. +!measlight The measuring light (umol photons m-2s-1), not used as of 3/19/2015 +!anet: The net photosynthetical rate (umol/m2/s) +!actiniclight: The total incident actinic photosynthetically active radiation (umol photons /m2/s) +!tempK: The temperature of each measurement (K) +! +!==============Outputs========================================= +!yield_ps2: The photochemical yield of PSII +!yield_npq: The yield of regulated nonphotochemical quenching +!qlake: The fraction of open PSII reaction centers based on the lake model +!qpuddle: The fraction of open PSII reaction centers based on the puddle model +!kps2_norm: The rate constant of photochemical quenching, normalized by the sum of fluorescence rate constant kf and +! intrinsic thermal dissipation rate constant kd. That is, kps2_norm = kp/(kf+kd) +!knpq_norm: The rate constant of regulated nonphotochemical quenching, normalized by the sum of fluorescence rate constant kf and +! intrinsic thermal dissipation rate constant kd. That is, knpq_norm = knqp/(kf+kd). +! knpq_norm is simply the NPQ parameter commonly used in the literature. +!fo_dark: The dark-adapted fo +!fm_dark: The dark-adapted fm +!resp_dark: The dark respiration rate (umol/m2/s) +!tempK_dark: The temperature of the dark measurement (K) +! +!We don't calculate qn because it has no clear physical / biological meaning) +! +! + integer i,j,k,n + double precision fs_dark,threshold +! + do i=1,nsamples + if(measlight(i).gt.0.0d0)then + if(fo(i).gt.0.0d0)fo(i)=fo(i)/dabs(measlight(i)) + if(fm(i).gt.0.0d0)fm(i)=fm(i)/dabs(measlight(i)) + if(fs(i).gt.0.0d0)fs(i)=fs(i)/dabs(measlight(i)) + endif + enddo +!Find the dark-adapted fo and fm +!We assume the following: +!- The first measurement that has a zero actiniclight is a dark-adapted measurement. +!- Any measurements that immediately follow the first dark-adapated measurement and have zero actiniclight are +!- repeated samples of dark-adated measurements. + threshold=0.001d0 + i=1 +10 if(dabs(actiniclight(i)).lt.threshold)then + j=i + goto 20 + endif + if(i.lt.nsamples)then + i=i+1 + goto 10 + endif +!no dark-adapted measurements + fo_dark=-9999.0d0 + fm_dark=-9999.0d0 + fs_dark=-9999.0d0 + resp_dark=-9999.0d0 + tempK_dark=-9999.0d0 + goto 40 +20 j=j+1 + if(j.gt.nsamples)goto 30 + if(dabs(actiniclight(j)).gt.threshold)goto 30 + if(j.lt.nsamples)goto 20 + j=j+1 +30 j=j-1 +! + fo_dark=0.0d0 + n=0 + do k=i,j + if(fo(k).gt.0.0d0)then + n=n+1 + fo_dark=fo_dark+fo(k) + endif + enddo + if(n.eq.0)then + fo_dark=-9999.0d0 + else + fo_dark=fo_dark/dble(n) + endif +! + fm_dark=0.0d0 + n=0 + do k=i,j + if(fm(k).gt.0.0d0)then + n=n+1 + fm_dark=fm_dark+fm(k) + endif + enddo + if(n.eq.0)then + fm_dark=-9999.0d0 + else + fm_dark=fm_dark/dble(n) + endif +! + fs_dark=0.0d0 + n=0 + do k=i,j + if(fs(k).gt.0.0d0)then + n=n+1 + fs_dark=fs_dark+fs(k) + endif + enddo + if(n.eq.0)then + fs_dark=-9999.0d0 + else + fs_dark=fs_dark/dble(n) + endif +! + resp_dark=0.0d0 + n=0 + do k=i,j + if(anet(k).lt.0.0d0.and.dabs(anet(k)+9999.0d0).gt.0.01d0)then + n=n+1 + resp_dark=resp_dark+anet(k) + endif + enddo + if(n.eq.0)then + resp_dark=-9999.0d0 + else + resp_dark=dabs(resp_dark/dble(n)) + endif +! + tempK_dark=0.0d0 + n=0 + do k=i,j + if(tempK(k).gt.0.0d0)then + n=n+1 + tempK_dark=tempK_dark+tempK(k) + endif + enddo + if(n.eq.0)then + tempK_dark=-9999.0d0 + else + tempK_dark=tempK_dark/dble(n) + endif +! +!for dark-adapted measurements, fo_dark and fs_dark are the same + if(fo_dark.lt.0.0d0)fo_dark=fs_dark +! +40 do i=1,nsamples + if(fo(i).lt.0.0d0.and.fo_dark.gt.0.0d0)then +!We use Oxborough and Baker (1997) Photosynthesis Research 54: 135-142 in case when Fo' in the light +!is not measured. + if(fm_dark.gt.0.0d0.and.fm(i).gt.0.0d0)fo(i)= + &fo_dark/(1.0d0-fo_dark/fm_dark+fo_dark/fm(i)) + endif +! + yield_ps2(i)=-9999.0d0 + yield_npq(i)=-9999.0d0 + qpuddle(i)=-9999.0d0 + qlake(i)=-9999.0d0 + if(fm(i).gt.0.0d0.and.fs(i).gt.0.0d0)then + yield_ps2(i)=(fm(i)-fs(i))/fm(i) + if(fm_dark.gt.0.0d0)yield_npq(i)=fs(i)/fm(i)-fs(i)/fm_dark + if(fo(i).gt.0.0d0)then + qpuddle(i)=(fm(i)-fs(i))/(fm(i)-fo(i)) + qlake(i)=qpuddle(i)*fo(i)/fs(i) + endif + endif + knpq_norm(i)=-9999.0d0 + kps2_norm(i)=-9999.0d0 + if(fm_dark.gt.0.0d0.and.fm(i).gt.0.0d0)then + knpq_norm(i)=fm_dark/fm(i)-1.0d0 + if(fs(i).gt.0.0d0) + &kps2_norm(i)=fm_dark*(1.0d0/fs(i)-1.0d0/fm(i)) + endif + enddo + return + end subroutine pam_parameters diff --git a/leafres/testarea/pco2ianetfunc.h b/leafres/testarea/pco2ianetfunc.h new file mode 100644 index 0000000..79c9941 --- /dev/null +++ b/leafres/testarea/pco2ianetfunc.h @@ -0,0 +1,14 @@ + integer ifitmode,Currentiknowlimit,ilimittype,iphotolimit + double precision vcmax,fjelect,tpu,resistwp,resistch,stargamma, + &fkco,alpha,rdlight,pco2i_obs,anet_obs,chlflphips2,chlflfjelect, + &pco2i_pred,anet_pred,pco2c,realizedfjelect,weitanet,weitpco2i, + &weitphips2,weitfjelect,pco2i_pred_flu,anet_pred_flu, + &pco2c_anet_flu,pco2c_pco2i_flu,PhiPSIImax + common/int_pco2ianetfunc/ifitmode,Currentiknowlimit,ilimittype, + &iphotolimit + common/dble_pco2ianetfunc/vcmax,fjelect,tpu,resistwp,resistch, + &stargamma,fkco,alpha,rdlight,pco2i_obs,anet_obs,chlflphips2, + &chlflfjelect,pco2i_pred,anet_pred,pco2c,realizedfjelect,weitanet, + &weitpco2i,weitphips2,weitfjelect,pco2i_pred_flu,anet_pred_flu, + &pco2c_anet_flu,pco2c_pco2i_flu,PhiPSIImax + diff --git a/leafres/testarea/retired/ALightCombinatorial.f b/leafres/testarea/retired/ALightCombinatorial.f new file mode 100644 index 0000000..9e3a29a --- /dev/null +++ b/leafres/testarea/retired/ALightCombinatorial.f @@ -0,0 +1,299 @@ + subroutine ALightCombinatorial() + implicit none + include '../testarea/LeafGasHybridFit.h' + integer i,ilastrubp1,ilastrubis1,ilastrubp2,ilastrubis2, + &ilastrubp3,ilastrubis3,ilastrubp4,ilastrubis4, + &ilastrubp5,ilastrubis5,ilastrubp6,ilastrubis6, + &ilastrubp7,ilastrubis7,ilastrubp8,ilastrubis8, + &ilastrubp9,ilastrubis9,ilastrubp10,ilastrubis10, + &ilastrubp11,ilastrubis11,ilastrubp12,ilastrubis12, + &ilastrubp13,ilastrubis13,ilastrubp14,ilastrubis14, + &ilastrubp15,ilastrubis15 +!common block variables: numALightcurves,nALightPoints(numALightcurves), +!ALightiphotolimit(nALightPoints,numALightcurves) + + if(numALightcurves.eq.0)then +!no conventional A/Light curves. go to free-style measurements directly and then return + call FreeCombinatorial() + return + endif +!(before 17/09/2014 remarks.) Assume rubp, rubisco and tpu limitations in the order of (rubp, rubisco, tpu) but any limitation can be missing in any light response curves +!the nALightPoints data in each light response curve must be ordered from low to high PAR. When ordered in such, the three limitation states +!should occur in the order of (rubp, rubisco, tpu) +! +!17/09/2014 Wenting found (RuBP, TPU, Rubisco) is more likely for A/Light curves if Ci decreases with increased light. Thus the following +!changes are made: +!we generally assume the points of an A/Light curve are lined up in a sequence of (RuBP, TPU and Rubisco), which is indicated by +!ialightorder=0. However, if Ci increases steadily from nstartalight to the end, we assume a sequence of (RuBP, Rubisco and TPU), +!which is indicated by ialightorder=2. + do ilastrubp1=nstartalight(1),nendalight(1) + do i=1,ilastrubp1 + ALightiphotolimit(i,1)=2 + enddo + do 1 ilastrubis1=ilastrubp1,nALightPoints(1) + do i=ilastrubp1+1,ilastrubis1 + ALightiphotolimit(i,1)=3-ialightorder(1) + enddo + do i=ilastrubis1+1,nALightPoints(1) + ALightiphotolimit(i,1)=1+ialightorder(1) + enddo + if(numALightcurves.eq.1)then + call FreeCombinatorial() + goto 1 + endif + + do ilastrubp2=nstartalight(2),nendalight(2) + do i=1,ilastrubp2 + ALightiphotolimit(i,2)=2 + enddo + do 2 ilastrubis2=ilastrubp2,nALightPoints(2) + do i=ilastrubp2+1,ilastrubis2 + ALightiphotolimit(i,2)=3-ialightorder(2) + enddo + do i=ilastrubis2+1,nALightPoints(2) + ALightiphotolimit(i,2)=1+ialightorder(2) + enddo + if(numALightcurves.eq.2)then + call FreeCombinatorial() + goto 2 + endif + + do ilastrubp3=nstartalight(3),nendalight(3) + do i=1,ilastrubp3 + ALightiphotolimit(i,3)=2 + enddo + do 3 ilastrubis3=ilastrubp3,nALightPoints(3) + do i=ilastrubp3+1,ilastrubis3 + ALightiphotolimit(i,3)=3-ialightorder(3) + enddo + do i=ilastrubis3+1,nALightPoints(3) + ALightiphotolimit(i,3)=1+ialightorder(3) + enddo + if(numALightcurves.eq.3)then + call FreeCombinatorial() + goto 3 + endif + + do ilastrubp4=nstartalight(4),nendalight(4) + do i=1,ilastrubp4 + ALightiphotolimit(i,4)=2 + enddo + do 4 ilastrubis4=ilastrubp4,nALightPoints(4) + do i=ilastrubp4+1,ilastrubis4 + ALightiphotolimit(i,4)=3-ialightorder(4) + enddo + do i=ilastrubis4+1,nALightPoints(4) + ALightiphotolimit(i,4)=1+ialightorder(4) + enddo + if(numALightcurves.eq.4)then + call FreeCombinatorial() + goto 4 + endif + + do ilastrubp5=nstartalight(5),nendalight(5) + do i=1,ilastrubp5 + ALightiphotolimit(i,5)=2 + enddo + do 5 ilastrubis5=ilastrubp5,nALightPoints(5) + do i=ilastrubp5+1,ilastrubis5 + ALightiphotolimit(i,5)=3-ialightorder(5) + enddo + do i=ilastrubis5+1,nALightPoints(5) + ALightiphotolimit(i,5)=1+ialightorder(5) + enddo + if(numALightcurves.eq.5)then + call FreeCombinatorial() + goto 5 + endif + + do ilastrubp6=nstartalight(6),nendalight(6) + do i=1,ilastrubp6 + ALightiphotolimit(i,6)=2 + enddo + do 6 ilastrubis6=ilastrubp6,nALightPoints(6) + do i=ilastrubp6+1,ilastrubis6 + ALightiphotolimit(i,6)=3-ialightorder(6) + enddo + do i=ilastrubis6+1,nALightPoints(6) + ALightiphotolimit(i,6)=1+ialightorder(6) + enddo + if(numALightcurves.eq.6)then + call FreeCombinatorial() + goto 6 + endif + + do ilastrubp7=nstartalight(7),nendalight(7) + do i=1,ilastrubp7 + ALightiphotolimit(i,7)=2 + enddo + do 7 ilastrubis7=ilastrubp7,nALightPoints(7) + do i=ilastrubp7+1,ilastrubis7 + ALightiphotolimit(i,7)=3-ialightorder(7) + enddo + do i=ilastrubis7+1,nALightPoints(7) + ALightiphotolimit(i,7)=1+ialightorder(7) + enddo + if(numALightcurves.eq.7)then + call FreeCombinatorial() + goto 7 + endif + + do ilastrubp8=nstartalight(8),nendalight(8) + do i=1,ilastrubp8 + ALightiphotolimit(i,8)=2 + enddo + do 8 ilastrubis8=ilastrubp8,nALightPoints(8) + do i=ilastrubp8+1,ilastrubis8 + ALightiphotolimit(i,8)=3-ialightorder(8) + enddo + do i=ilastrubis8+1,nALightPoints(8) + ALightiphotolimit(i,8)=1+ialightorder(8) + enddo + if(numALightcurves.eq.8)then + call FreeCombinatorial() + goto 8 + endif + + do ilastrubp9=nstartalight(9),nendalight(9) + do i=1,ilastrubp9 + ALightiphotolimit(i,9)=2 + enddo + do 9 ilastrubis9=ilastrubp9,nALightPoints(9) + do i=ilastrubp9+1,ilastrubis9 + ALightiphotolimit(i,9)=3-ialightorder(9) + enddo + do i=ilastrubis9+1,nALightPoints(9) + ALightiphotolimit(i,9)=1+ialightorder(9) + enddo + if(numALightcurves.eq.9)then + call FreeCombinatorial() + goto 9 + endif + + do ilastrubp10=nstartalight(10),nendalight(10) + do i=1,ilastrubp10 + ALightiphotolimit(i,10)=2 + enddo + do 10 ilastrubis10=ilastrubp10,nALightPoints(10) + do i=ilastrubp10+1,ilastrubis10 + ALightiphotolimit(i,10)=3-ialightorder(10) + enddo + do i=ilastrubis10+1,nALightPoints(10) + ALightiphotolimit(i,10)=1+ialightorder(10) + enddo + if(numALightcurves.eq.10)then + call FreeCombinatorial() + goto 10 + endif + + do ilastrubp11=nstartalight(11),nendalight(11) + do i=1,ilastrubp11 + ALightiphotolimit(i,11)=2 + enddo + do 11 ilastrubis11=ilastrubp11,nALightPoints(11) + do i=ilastrubp11+1,ilastrubis11 + ALightiphotolimit(i,11)=3-ialightorder(11) + enddo + do i=ilastrubis11+1,nALightPoints(11) + ALightiphotolimit(i,11)=1+ialightorder(11) + enddo + if(numALightcurves.eq.11)then + call FreeCombinatorial() + goto 11 + endif + + do ilastrubp12=nstartalight(12),nendalight(12) + do i=1,ilastrubp12 + ALightiphotolimit(i,12)=2 + enddo + do 12 ilastrubis12=ilastrubp12,nALightPoints(12) + do i=ilastrubp12+1,ilastrubis12 + ALightiphotolimit(i,12)=3-ialightorder(12) + enddo + do i=ilastrubis12+1,nALightPoints(12) + ALightiphotolimit(i,12)=1+ialightorder(12) + enddo + if(numALightcurves.eq.12)then + call FreeCombinatorial() + goto 12 + endif + + do ilastrubp13=nstartalight(13),nendalight(13) + do i=1,ilastrubp13 + ALightiphotolimit(i,13)=2 + enddo + do 13 ilastrubis13=ilastrubp13,nALightPoints(13) + do i=ilastrubp13+1,ilastrubis13 + ALightiphotolimit(i,13)=3-ialightorder(13) + enddo + do i=ilastrubis13+1,nALightPoints(13) + ALightiphotolimit(i,13)=1+ialightorder(13) + enddo + if(numALightcurves.eq.13)then + call FreeCombinatorial() + goto 13 + endif + + do ilastrubp14=nstartalight(14),nendalight(14) + do i=1,ilastrubp14 + ALightiphotolimit(i,14)=2 + enddo + do 14 ilastrubis14=ilastrubp14,nALightPoints(14) + do i=ilastrubp14+1,ilastrubis14 + ALightiphotolimit(i,14)=3-ialightorder(14) + enddo + do i=ilastrubis14+1,nALightPoints(14) + ALightiphotolimit(i,14)=1+ialightorder(14) + enddo + if(numALightcurves.eq.14)then + call FreeCombinatorial() + goto 14 + endif + + do ilastrubp15=nstartalight(15),nendalight(15) + do i=1,ilastrubp15 + ALightiphotolimit(i,15)=2 + enddo + do 15 ilastrubis15=ilastrubp15,nALightPoints(15) + do i=ilastrubp15+1,ilastrubis15 + ALightiphotolimit(i,15)=3-ialightorder(15) + enddo + do i=ilastrubis15+1,nALightPoints(15) + ALightiphotolimit(i,15)=1+ialightorder(15) + enddo + if(numALightcurves.eq.15)then + call FreeCombinatorial() + goto 15 + endif +15 continue + enddo +14 continue + enddo +13 continue + enddo +12 continue + enddo +11 continue + enddo +10 continue + enddo +9 continue + enddo +8 continue + enddo +7 continue + enddo +6 continue + enddo +5 continue + enddo +4 continue + enddo +3 continue + enddo +2 continue + enddo +1 continue + enddo + return + end subroutine ALightCombinatorial diff --git a/leafres/testarea/retired/FreeCombinatorial.f b/leafres/testarea/retired/FreeCombinatorial.f new file mode 100644 index 0000000..dc55b33 --- /dev/null +++ b/leafres/testarea/retired/FreeCombinatorial.f @@ -0,0 +1,364 @@ + subroutine FreeCombinatorial() + include '../testarea/LeafGasHybridFit.h' + integer + &i01,i02,i03,i04,i05,i06,i07,i08,i09,i10, + &i11,i12,i13,i14,i15,i16,i17,i18,i19,i20, + &i21,i22,i23,i24,i25,i26,i27,i28,i29,i30, + &i31,i32,i33,i34,i35,i36,i37,i38,i39,i40, + &i41,i42,i43,i44,i45,i46,i47,i48,i49,i50 + if(nFreePoints.eq.0)then + call UnivPhotoFit() + return + endif + do 1 i01=1,3 + Freeiphotolimit(1)=i01 + if(nFreePoints.eq.1)then + call UnivPhotoFit() + goto 1 + endif + do 2 i02=1,3 + Freeiphotolimit(2)=i02 + if(nFreePoints.eq.2)then + call UnivPhotoFit() + goto 2 + endif + do 3 i03=1,3 + Freeiphotolimit(3)=i03 + if(nFreePoints.eq.3)then + call UnivPhotoFit() + goto 3 + endif + do 4 i04=1,3 + Freeiphotolimit(4)=i04 + if(nFreePoints.eq.4)then + call UnivPhotoFit() + goto 4 + endif + do 5 i05=1,3 + Freeiphotolimit(5)=i05 + if(nFreePoints.eq.5)then + call UnivPhotoFit() + goto 5 + endif + do 6 i06=1,3 + Freeiphotolimit(6)=i06 + if(nFreePoints.eq.6)then + call UnivPhotoFit() + goto 6 + endif + do 7 i07=1,3 + Freeiphotolimit(7)=i07 + if(nFreePoints.eq.7)then + call UnivPhotoFit() + goto 7 + endif + do 8 i08=1,3 + Freeiphotolimit(8)=i08 + if(nFreePoints.eq.8)then + call UnivPhotoFit() + goto 8 + endif + do 9 i09=1,3 + Freeiphotolimit(9)=i09 + if(nFreePoints.eq.9)then + call UnivPhotoFit() + goto 9 + endif + do 10 i10=1,3 + Freeiphotolimit(10)=i10 + if(nFreePoints.eq.10)then + call UnivPhotoFit() + goto 10 + endif + do 11 i11=1,3 + Freeiphotolimit(11)=i11 + if(nFreePoints.eq.11)then + call UnivPhotoFit() + goto 11 + endif + do 12 i12=1,3 + Freeiphotolimit(12)=i12 + if(nFreePoints.eq.12)then + call UnivPhotoFit() + goto 12 + endif + do 13 i13=1,3 + Freeiphotolimit(13)=i13 + if(nFreePoints.eq.13)then + call UnivPhotoFit() + goto 13 + endif + do 14 i14=1,3 + Freeiphotolimit(14)=i14 + if(nFreePoints.eq.14)then + call UnivPhotoFit() + goto 14 + endif + do 15 i15=1,3 + Freeiphotolimit(15)=i15 + if(nFreePoints.eq.15)then + call UnivPhotoFit() + goto 15 + endif + do 16 i16=1,3 + Freeiphotolimit(16)=i16 + if(nFreePoints.eq.16)then + call UnivPhotoFit() + goto 16 + endif + do 17 i17=1,3 + Freeiphotolimit(17)=i17 + if(nFreePoints.eq.17)then + call UnivPhotoFit() + goto 17 + endif + do 18 i18=1,3 + Freeiphotolimit(18)=i18 + if(nFreePoints.eq.18)then + call UnivPhotoFit() + goto 18 + endif + do 19 i19=1,3 + Freeiphotolimit(19)=i19 + if(nFreePoints.eq.19)then + call UnivPhotoFit() + goto 19 + endif + do 20 i20=1,3 + Freeiphotolimit(20)=i20 + if(nFreePoints.eq.20)then + call UnivPhotoFit() + goto 20 + endif + do 21 i21=1,3 + Freeiphotolimit(21)=i21 + if(nFreePoints.eq.21)then + call UnivPhotoFit() + goto 21 + endif + do 22 i22=1,3 + Freeiphotolimit(22)=i22 + if(nFreePoints.eq.22)then + call UnivPhotoFit() + goto 22 + endif + do 23 i23=1,3 + Freeiphotolimit(23)=i23 + if(nFreePoints.eq.23)then + call UnivPhotoFit() + goto 23 + endif + do 24 i24=1,3 + Freeiphotolimit(24)=i24 + if(nFreePoints.eq.24)then + call UnivPhotoFit() + goto 24 + endif + do 25 i25=1,3 + Freeiphotolimit(25)=i25 + if(nFreePoints.eq.25)then + call UnivPhotoFit() + goto 25 + endif + do 26 i26=1,3 + Freeiphotolimit(26)=i26 + if(nFreePoints.eq.26)then + call UnivPhotoFit() + goto 26 + endif + do 27 i27=1,3 + Freeiphotolimit(27)=i27 + if(nFreePoints.eq.27)then + call UnivPhotoFit() + goto 27 + endif + do 28 i28=1,3 + Freeiphotolimit(28)=i28 + if(nFreePoints.eq.28)then + call UnivPhotoFit() + goto 28 + endif + do 29 i29=1,3 + Freeiphotolimit(29)=i29 + if(nFreePoints.eq.29)then + call UnivPhotoFit() + goto 29 + endif + do 30 i30=1,3 + Freeiphotolimit(30)=i30 + if(nFreePoints.eq.30)then + call UnivPhotoFit() + goto 30 + endif + do 31 i31=1,3 + Freeiphotolimit(31)=i31 + if(nFreePoints.eq.31)then + call UnivPhotoFit() + goto 31 + endif + do 32 i32=1,3 + Freeiphotolimit(32)=i32 + if(nFreePoints.eq.32)then + call UnivPhotoFit() + goto 32 + endif + do 33 i33=1,3 + Freeiphotolimit(33)=i33 + if(nFreePoints.eq.33)then + call UnivPhotoFit() + goto 33 + endif + do 34 i34=1,3 + Freeiphotolimit(34)=i34 + if(nFreePoints.eq.34)then + call UnivPhotoFit() + goto 34 + endif + do 35 i35=1,3 + Freeiphotolimit(35)=i35 + if(nFreePoints.eq.35)then + call UnivPhotoFit() + goto 35 + endif + do 36 i36=1,3 + Freeiphotolimit(36)=i36 + if(nFreePoints.eq.36)then + call UnivPhotoFit() + goto 36 + endif + do 37 i37=1,3 + Freeiphotolimit(37)=i37 + if(nFreePoints.eq.37)then + call UnivPhotoFit() + goto 37 + endif + do 38 i38=1,3 + Freeiphotolimit(38)=i38 + if(nFreePoints.eq.38)then + call UnivPhotoFit() + goto 38 + endif + do 39 i39=1,3 + Freeiphotolimit(39)=i39 + if(nFreePoints.eq.39)then + call UnivPhotoFit() + goto 39 + endif + do 40 i40=1,3 + Freeiphotolimit(40)=i40 + if(nFreePoints.eq.40)then + call UnivPhotoFit() + goto 40 + endif + do 41 i41=1,3 + Freeiphotolimit(41)=i41 + if(nFreePoints.eq.41)then + call UnivPhotoFit() + goto 41 + endif + do 42 i42=1,3 + Freeiphotolimit(42)=i42 + if(nFreePoints.eq.42)then + call UnivPhotoFit() + goto 42 + endif + do 43 i43=1,3 + Freeiphotolimit(43)=i43 + if(nFreePoints.eq.43)then + call UnivPhotoFit() + goto 43 + endif + do 44 i44=1,3 + Freeiphotolimit(44)=i44 + if(nFreePoints.eq.44)then + call UnivPhotoFit() + goto 44 + endif + do 45 i45=1,3 + Freeiphotolimit(45)=i45 + if(nFreePoints.eq.45)then + call UnivPhotoFit() + goto 45 + endif + do 46 i46=1,3 + Freeiphotolimit(46)=i46 + if(nFreePoints.eq.46)then + call UnivPhotoFit() + goto 46 + endif + do 47 i47=1,3 + Freeiphotolimit(47)=i47 + if(nFreePoints.eq.47)then + call UnivPhotoFit() + goto 47 + endif + do 48 i48=1,3 + Freeiphotolimit(48)=i48 + if(nFreePoints.eq.48)then + call UnivPhotoFit() + goto 48 + endif + do 49 i49=1,3 + Freeiphotolimit(49)=i49 + if(nFreePoints.eq.49)then + call UnivPhotoFit() + goto 49 + endif + do 50 i50=1,3 + Freeiphotolimit(50)=i50 + if(nFreePoints.eq.50)then + call UnivPhotoFit() + goto 50 + endif +50 continue +49 continue +48 continue +47 continue +46 continue +45 continue +44 continue +43 continue +42 continue +41 continue +40 continue +39 continue +38 continue +37 continue +36 continue +35 continue +34 continue +33 continue +32 continue +31 continue +30 continue +29 continue +28 continue +27 continue +26 continue +25 continue +24 continue +23 continue +22 continue +21 continue +20 continue +19 continue +18 continue +17 continue +16 continue +15 continue +14 continue +13 continue +12 continue +11 continue +10 continue +9 continue +8 continue +7 continue +6 continue +5 continue +4 continue +3 continue +2 continue +1 continue + return + end subroutine FreeCombinatorial diff --git a/leafres/testarea/retired/HybridCombinatorial.f b/leafres/testarea/retired/HybridCombinatorial.f new file mode 100644 index 0000000..32319fe --- /dev/null +++ b/leafres/testarea/retired/HybridCombinatorial.f @@ -0,0 +1,587 @@ +!We consider four types of leaf gas exchange measurements. These four types must be clearly indicated in the input: +!1. Points whose limitation states are known from other means (e.g. chlorophyll fluorescence): these points will be called fixed points and +! their limitation states will not be changed by the parameter estimation program. +!2. Points from conventional CO2 response measurements (A/Ci curves) that are done without fluorescence. Limitation states are not known but follow +! the order of Rubisco, RuBP and TPU along the CO2i axis as suggested in Gu et al. (2010) PCE paper. We call these points ACi points. +! The ACi points must be already ordered from low to high CO2i. +!3. Points from conventional light response measurements (A/PAR curves) that are done without fluorescence. Limitation states are not known but follow +! the order of RuBP, Rubisco and TPU along the PAR axis. We call these points ALight points. The ALight points must be already ordered from low to high PAR. +!4. Points whose limitation states follow no order. We call these points free points. They are obtained with no control of environmental conditions. + subroutine HybridCombinatorial() + implicit none + include '../testarea/LeafGasParams.h' + include '../testarea/LeafGasHybridFit.h' + integer i,ilastrubis1,ilastrubp1,ilastrubis2,ilastrubp2, + &ilastrubis3,ilastrubp3,ilastrubis4,ilastrubp4, + &ilastrubis5,ilastrubp5,ilastrubis6,ilastrubp6, + &ilastrubis7,ilastrubp7,ilastrubis8,ilastrubp8, + &ilastrubis9,ilastrubp9,ilastrubis10,ilastrubp10, + &ilastrubis11,ilastrubp11,ilastrubis12,ilastrubp12, + &ilastrubis13,ilastrubp13,ilastrubis14,ilastrubp14, + &ilastrubis15,ilastrubp15,k1,k2,k3,k4,k5,k6,k7,k8, + &k9,k10,k11,k12,k13,k14,k15,ilasttpu1,ilasttpu2, + &ilasttpu3,ilasttpu4,ilasttpu5,ilasttpu6,ilasttpu7, + &ilasttpu8,ilasttpu9,ilasttpu10,ilasttpu11,ilasttpu12, + &ilasttpu13,ilasttpu14,ilasttpu15 + double precision rdlight,atp,resistwp,resistch,stargamma, + &realizedfjelect,term +! +!common block variables:idokco,idoalpha,minimumrubis,minimumfj,minimumvt,nACiPoints,ACiiphotolimit(nACiPoints) + minimumfj=3 + if(idokc.eq.0.and.idoko.eq.0)then + minimumrubis=3 + else + if(idokc.eq.0.or.idoko.eq.0)then + minimumrubis=4 + else + minimumrubis=5 + endif + endif + if((nFixedPoints+numACicurves+nFreePoints).eq.0)minimumrubis=2 + if(idoalpha.eq.0)then + minimumvt=2 + else + minimumvt=3 + endif + i=0 + do k1=1,numACicurves + do k2=nendaci(k1)+1,nACiPoints(k1) + i=i+1 + enddo + enddo + if(i.gt.0)minimumvt=i +! + ntotunivparams=13 + univparamsmin(1)=resistwp25min + univparamsmax(1)=resistwp25max + univparamsmin(2)=resistch25min + univparamsmax(2)=resistch25max + univparamsmin(3)=rdlight25min + univparamsmax(3)=rdlight25max + univparamsmin(4)=stargamma25min + univparamsmax(4)=stargamma25max + univparamsmin(5)=vcmax25min + univparamsmax(5)=vcmax25max + univparamsmin(6)=fkc25min + univparamsmax(6)=fkc25max + univparamsmin(7)=fko25min + univparamsmax(7)=fko25max + univparamsmin(8)=fjmax25min + univparamsmax(8)=fjmax25max + univparamsmin(9)=tpu25min + univparamsmax(9)=tpu25max + univparamsmin(10)=alpha25min + univparamsmax(10)=alpha25max + univparamsmin(11)=phifactormin + univparamsmax(11)=phifactormax + univparamsmin(12)=thetafactormin + univparamsmax(12)=thetafactormax + univparamsmin(13)=betaPSIImin + univparamsmax(13)=betaPSIImax + + bestilimittype=-9999 + do ilastrubis1=1,7 + subbestsumsquare(ilastrubis1)=1.0d+100 + subbestunivparams(1,ilastrubis1)=resistwp25_ori + subbestunivparams(2,ilastrubis1)=resistch25_ori + subbestunivparams(3,ilastrubis1)=rdlight25_ori + subbestunivparams(4,ilastrubis1)=stargamma25_ori + subbestunivparams(5,ilastrubis1)=vcmax25_ori + subbestunivparams(6,ilastrubis1)=fkc25_ori + subbestunivparams(7,ilastrubis1)=fko25_ori + subbestunivparams(8,ilastrubis1)=fjmax25_ori + subbestunivparams(9,ilastrubis1)=tpu25_ori + subbestunivparams(10,ilastrubis1)=alpha25_ori + subbestunivparams(11,ilastrubis1)=phifactor_ori + subbestunivparams(12,ilastrubis1)=thetafactor_ori + subbestunivparams(13,ilastrubis1)=betaPSII_ori + do i=1,ntotsamples + subbestiphotolimit(i,ilastrubis1)=-9999 + enddo + enddo + do i=1,ntotsamples + forcings(i,1)=pco2i_ori(i) + forcings(i,2)=aPPFDlf_ori(i) + forcings(i,3)=templeaf_ori(i) + forcings(i,4)=po2i_ori(i) + responses(i,1)=anet_obs(i) + weitforcings(i,1)=1.0d0 + weitforcings(i,2)=1.0d0 + weitforcings(i,3)=1.0d0 + weitforcings(i,4)=1.0d0 + weitresponses(i,1)=1.0d0 + if(ntotphips2.ge.1)then + if(chlflphips2_ori(i).gt.0.0d0)then +!for least square regression + responses(i,2)=chlflphips2_ori(i) +!a factor of 50 makes PhiPSII comparable to Anet in magnitude + weitresponses(i,2)=50.0d0 + else + responses(i,2)=chlflphips2_ori(i) + weitresponses(i,2)=0.0d0 + endif + endif + if(Prioriknowlimit.eq.-1)then +!fluorescence fit only. chlflphips2 becomes a response variable + forcings(i,5)=chlflphips2_ori(i) + weitforcings(i,5)=1.0d0 + if(chlflphips2_ori(i).le.0.0d0)then + weitforcings(i,5)=0.0d0 + weitresponses(i,1)=0.0d0 + endif + endif + enddo + do i=1,12 + gacontrol(i)=-1.0d0 + enddo + gacontrol(1)=250.0d0 + gacontrol(2)=5000.0d0 + gacontrol(3)=8.0d0 + +!Priorilimittype: indicator for the choice of overall mixtures of limitation types +! = 1, Rubisco+RuBP+TPU +! = 2, Rubisco+RuBP +! = 3, Rubisco+TPU +! = 4, RuBP+TPU +! = 5, Rubisco Only +! = 6, RuBP Only +! = 7, TPU Only + +!Prioriknowlimit: indicator for how the limitation type of each point is set before the fitting +! = 0, the limitation type of each individual point has not been pre-set when mixed +! limitation states are present in the dataset. When Priorilimittype = 5, 6, 7, +! all points are limited by one type. +! = 1, the limit type of each individual point has been pre-set. Don't allow the fitting +! algorithm to change the limitation type of each point during the first fit. But +! check the admissibility after the first fit. If the admissibility is violated, +! treat the osicilation points as colimited; if there is no osicilation, use the penalty +! approach to refit. +! = 2, the limit type of each individual point has been pre-set. Allow the fitting +! algorithm to change the limitation type of each point during the fit. Penalize any fit +! that results in any point to have a limitation type different from the pre-set type. +! =-1, only do a fluorescence fit +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + if(Prioriknowlimit.eq.-1)then +!fluorescence only fit + Priorilimittype=6 + Currentilimittype=Priorilimittype + Currentiknowlimit=Prioriknowlimit +!we pass UnivPhotoFit and call DoUnivPhotoFit directly + call DoUnivPhotoFit() + if(numALightcurves.gt.0.and.idorch.eq.1)then + call fluorescencejmax() + endif + return + endif +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ + Prioriknowlimit=0 + bestsumsquare=1.0d+100 + do Priorilimittype=1,7 + call UnivPhotoFit() + if(subbestsumsquare(Priorilimittype).le.bestsumsquare)then + bestilimittype=Priorilimittype + bestsumsquare=subbestsumsquare(Priorilimittype) + do i=1,ntotunivparams + bestunivparams(i)=subbestunivparams(i,Priorilimittype) + enddo + do i=1,ntotsamples + bestiphotolimit(i)=subbestiphotolimit(i,Priorilimittype) + enddo + endif + enddo +! goto 1000 + bestilimittype=-9999 + Prioriknowlimit=1 + Priorilimittype=-9999 +! +c gacontrol( 1) - number of individuals in a population (default +c is 100) +c gacontrol( 2) - number of generations over which solution is +c to evolve (default is 500) +c gacontrol( 3) - number of significant digits (i.e., number of +c genes) retained in chromosomal encoding (default +c is 6) (Note: This number is limited by the +c machine floating point precision. Most 32-bit +c floating point representations have only 6 full +c digits of precision. To achieve greater preci- +c sion this routine could be converted to double +c precision, but note that this would also require +c a double precision random number generator, which +c likely would not have more than 9 digits of +c precision if it used 4-byte integers internally.) +c gacontrol( 4) - crossover probability; must be <= 1.0 (default +c is 0.85). If crossover takes place, either one +c or two splicing points are used, with equal +c probabilities +c gacontrol( 5) - mutation mode; 1/2/3/4/5 (default is 2) +c 1=one-point mutation, fixed rate +c 2=one-point, adjustable rate based on fitness +c 3=one-point, adjustable rate based on distance +c 4=one-point+creep, fixed rate +c 5=one-point+creep, adjustable rate based on fitness +c 6=one-point+creep, adjustable rate based on distance +c gacontrol( 6) - initial mutation rate; should be small (default +c is 0.005) (Note: the mutation rate is the proba- +c bility that any one gene locus will mutate in +c any one generation.) +c gacontrol( 7) - minimum mutation rate; must be >= 0.0 (default +c is 0.0005) +c gacontrol( 8) - maximum mutation rate; must be <= 1.0 (default +c is 0.25) +c gacontrol( 9) - relative fitness differential; range from 0 +c (none) to 1 (maximum). (default is 1.) +c gacontrol(10) - reproduction plan; 1/2/3=Full generational +c replacement/Steady-state-replace-random/Steady- +c state-replace-worst (default is 3) +c gacontrol(11) - elitism flag; 0/1=off/on (default is 0) +c (Applies only to reproduction plans 1 and 2) +c gacontrol(12) - printed output 0/1/2=None/Minimal/Verbose +c (default is 0) +c + if(numACicurves.eq.0)then +!no conventional A/Ci curves. go to light response curves directly. + call ALightCombinatorial() + goto 1000 + endif +!Assume rubisco, rubp and tpu limitations in the order of (rubisco, rubp, tpu) but any limitation can be missing in any ACi curves. +!The nACiPoints points of each ACi curve must have been already ordered from low to high Ci within each individual ACi curve. + do ilastrubis1=0,nendaci(1) + do i=1,ilastrubis1 + ACiiphotolimit(i,1)=1 + enddo + k1=max0(nstartaci(1)-1,ilastrubis1) + do 1 ilasttpu1=k1,nendaci(1) + do i=ilasttpu1+1,nACiPoints(1) + ACiiphotolimit(i,1)=3 + enddo + do i=ilastrubis1+1,ilasttpu1 + ACiiphotolimit(i,1)=2 + enddo + if(numACicurves.eq.1)then + call ALightCombinatorial() + goto 1 + endif + + do ilastrubis2=0,nendaci(2) + do i=1,ilastrubis2 + ACiiphotolimit(i,2)=1 + enddo + k2=max0(nstartaci(2)-1,ilastrubis2) + do 2 ilasttpu2=k2,nendaci(2) + do i=ilasttpu2+1,nACiPoints(2) + ACiiphotolimit(i,2)=3 + enddo + do i=ilastrubis2+1,ilasttpu2 + ACiiphotolimit(i,2)=2 + enddo + if(numACicurves.eq.2)then + call ALightCombinatorial() + goto 2 + endif + + do ilastrubis3=0,nendaci(3) + do i=1,ilastrubis3 + ACiiphotolimit(i,3)=1 + enddo + k3=max0(nstartaci(3)-1,ilastrubis3) + do 3 ilasttpu3=k3,nendaci(3) + do i=ilasttpu3+1,nACiPoints(3) + ACiiphotolimit(i,3)=3 + enddo + do i=ilastrubis3+1,ilasttpu3 + ACiiphotolimit(i,3)=2 + enddo + if(numACicurves.eq.3)then + call ALightCombinatorial() + goto 3 + endif + + do ilastrubis4=0,nendaci(4) + do i=1,ilastrubis4 + ACiiphotolimit(i,4)=1 + enddo + k4=max0(nstartaci(4)-1,ilastrubis4) + do 4 ilasttpu4=k4,nendaci(4) + do i=ilasttpu4+1,nACiPoints(4) + ACiiphotolimit(i,4)=3 + enddo + do i=ilastrubis4+1,ilasttpu4 + ACiiphotolimit(i,4)=2 + enddo + if(numACicurves.eq.4)then + call ALightCombinatorial() + goto 4 + endif + + do ilastrubis5=0,nendaci(5) + do i=1,ilastrubis5 + ACiiphotolimit(i,5)=1 + enddo + k5=max0(nstartaci(5)-1,ilastrubis5) + do 5 ilasttpu5=k5,nendaci(5) + do i=ilasttpu5+1,nACiPoints(5) + ACiiphotolimit(i,5)=3 + enddo + do i=ilastrubis5+1,ilasttpu5 + ACiiphotolimit(i,5)=2 + enddo + if(numACicurves.eq.5)then + call ALightCombinatorial() + goto 5 + endif + + do ilastrubis6=0,nendaci(6) + do i=1,ilastrubis6 + ACiiphotolimit(i,6)=1 + enddo + k6=max0(nstartaci(6)-1,ilastrubis6) + do 6 ilasttpu6=k6,nendaci(6) + do i=ilasttpu6+1,nACiPoints(6) + ACiiphotolimit(i,6)=3 + enddo + do i=ilastrubis6+1,ilasttpu6 + ACiiphotolimit(i,6)=2 + enddo + if(numACicurves.eq.6)then + call ALightCombinatorial() + goto 6 + endif + + do ilastrubis7=0,nendaci(7) + do i=1,ilastrubis7 + ACiiphotolimit(i,7)=1 + enddo + k7=max0(nstartaci(7)-1,ilastrubis7) + do 7 ilasttpu7=k7,nendaci(7) + do i=ilasttpu7+1,nACiPoints(7) + ACiiphotolimit(i,7)=3 + enddo + do i=ilastrubis7+1,ilasttpu7 + ACiiphotolimit(i,7)=2 + enddo + if(numACicurves.eq.7)then + call ALightCombinatorial() + goto 7 + endif + + do ilastrubis8=0,nendaci(8) + do i=1,ilastrubis8 + ACiiphotolimit(i,8)=1 + enddo + k8=max0(nstartaci(8)-1,ilastrubis8) + do 8 ilasttpu8=k8,nendaci(8) + do i=ilasttpu8+1,nACiPoints(8) + ACiiphotolimit(i,8)=3 + enddo + do i=ilastrubis8+1,ilasttpu8 + ACiiphotolimit(i,8)=2 + enddo + if(numACicurves.eq.8)then + call ALightCombinatorial() + goto 8 + endif + + do ilastrubis9=0,nendaci(9) + do i=1,ilastrubis9 + ACiiphotolimit(i,9)=1 + enddo + k9=max0(nstartaci(9)-1,ilastrubis9) + do 9 ilasttpu9=k9,nendaci(9) + do i=ilasttpu9+1,nACiPoints(9) + ACiiphotolimit(i,9)=3 + enddo + do i=ilastrubis9+1,ilasttpu9 + ACiiphotolimit(i,9)=2 + enddo + if(numACicurves.eq.9)then + call ALightCombinatorial() + goto 9 + endif + + do ilastrubis10=0,nendaci(10) + do i=1,ilastrubis10 + ACiiphotolimit(i,10)=1 + enddo + k10=max0(nstartaci(10)-1,ilastrubis10) + do 10 ilasttpu10=k10,nendaci(10) + do i=ilasttpu10+1,nACiPoints(10) + ACiiphotolimit(i,10)=3 + enddo + do i=ilastrubis10+1,ilasttpu10 + ACiiphotolimit(i,10)=2 + enddo + if(numACicurves.eq.10)then + call ALightCombinatorial() + goto 10 + endif + + do ilastrubis11=0,nendaci(11) + do i=1,ilastrubis11 + ACiiphotolimit(i,11)=1 + enddo + k11=max0(nstartaci(11)-1,ilastrubis11) + do 11 ilasttpu11=k11,nendaci(11) + do i=ilasttpu11+1,nACiPoints(11) + ACiiphotolimit(i,11)=3 + enddo + do i=ilastrubis11+1,ilasttpu11 + ACiiphotolimit(i,11)=2 + enddo + if(numACicurves.eq.11)then + call ALightCombinatorial() + goto 11 + endif + + do ilastrubis12=0,nendaci(12) + do i=1,ilastrubis12 + ACiiphotolimit(i,12)=1 + enddo + k12=max0(nstartaci(12)-1,ilastrubis12) + do 12 ilasttpu12=k12,nendaci(12) + do i=ilasttpu12+1,nACiPoints(12) + ACiiphotolimit(i,12)=3 + enddo + do i=ilastrubis12+1,ilasttpu12 + ACiiphotolimit(i,12)=2 + enddo + if(numACicurves.eq.12)then + call ALightCombinatorial() + goto 12 + endif + + do ilastrubis13=0,nendaci(13) + do i=1,ilastrubis13 + ACiiphotolimit(i,13)=1 + enddo + k13=max0(nstartaci(13)-1,ilastrubis13) + do 13 ilasttpu13=k13,nendaci(13) + do i=ilasttpu13+1,nACiPoints(13) + ACiiphotolimit(i,13)=3 + enddo + do i=ilastrubis13+1,ilasttpu13 + ACiiphotolimit(i,13)=2 + enddo + if(numACicurves.eq.13)then + call ALightCombinatorial() + goto 13 + endif + + do ilastrubis14=0,nendaci(14) + do i=1,ilastrubis14 + ACiiphotolimit(i,14)=1 + enddo + k14=max0(nstartaci(14)-1,ilastrubis14) + do 14 ilasttpu14=k14,nendaci(14) + do i=ilasttpu14+1,nACiPoints(14) + ACiiphotolimit(i,14)=3 + enddo + do i=ilastrubis14+1,ilasttpu14 + ACiiphotolimit(i,14)=2 + enddo + if(numACicurves.eq.14)then + call ALightCombinatorial() + goto 14 + endif + + do ilastrubis15=0,nendaci(15) + do i=1,ilastrubis15 + ACiiphotolimit(i,15)=1 + enddo + k15=max0(nstartaci(15)-1,ilastrubis15) + do 15 ilasttpu15=k15,nendaci(15) + do i=ilasttpu15+1,nACiPoints(15) + ACiiphotolimit(i,15)=3 + enddo + do i=ilastrubis15+1,ilasttpu15 + ACiiphotolimit(i,15)=2 + enddo + if(numACicurves.eq.15)then + call ALightCombinatorial() + goto 15 + endif +15 continue + enddo +14 continue + enddo +13 continue + enddo +12 continue + enddo +11 continue + enddo +10 continue + enddo +9 continue + enddo +8 continue + enddo +7 continue + enddo +6 continue + enddo +5 continue + enddo +4 continue + enddo +3 continue + enddo +2 continue + enddo +1 continue + enddo + bestsumsquare=1.0d+100 + do Priorilimittype=1,7 + if(subbestsumsquare(Priorilimittype).le.bestsumsquare)then + bestilimittype=Priorilimittype + bestsumsquare=subbestsumsquare(Priorilimittype) + do i=1,ntotunivparams + bestunivparams(i)=subbestunivparams(i,Priorilimittype) + enddo + do i=1,ntotsamples + bestiphotolimit(i)=subbestiphotolimit(i,Priorilimittype) + enddo + endif + enddo +1000 do i=1,ntotunivparams + univparams(i)=bestunivparams(i) + enddo + call UnivParamsAlloc(2) + call ilimittypestats(ntotsamples,bestiphotolimit, + &bestilimittype,bestnumrubis,bestnumrubp,bestnumtpu) + if(bestnumrubis.eq.0)then + vcmax25=-9999 + if(idokc.eq.1)fkc25=-9999.0d0 + if(idoko.eq.1)fko25=-9999.0d0 + endif + if(bestnumrubp.eq.0)fjmax25=-9999 + if(bestnumtpu.eq.0)then + tpu25=-9999 + if(idoalpha.eq.1)alpha25=-9999 + endif + do i=1,ntotsamples + ilastrubp1=bestiphotolimit(i)+4 + call leafunivphotosyn(Prioriknowlimit,ilastrubp1,ifitmode, + &aPPFDlf(i),templeaf(i),pco2i(i),po2i(i),chlflphips2(i), + &anet_obs(i),weitresponses(i:i,1:1),weitresponses(i:i,1:1), + &weitresponses(i:i,2:2),weitresponses(i:i,1:1), + &pco2i_pred(i),anet_pred(i),Postiphotolimit(i),pco2c(i), + &PhiPSII_pred(i),anet_pred_flu(i),pco2i_pred_flu(i), + &pco2c_anet_flu(i),pco2c_pco2i_flu(i),term) + if(chlflphips2(i).lt.0.0d0)then + anet_pred_flu(i)=-9999.0d0 + pco2i_pred_flu(i)=-9999.0d0 + pco2c_anet_flu(i)=-9999.0d0 + pco2c_pco2i_flu(i)=-9999.0d0 + else + if(iabs(ifitmode).eq.1)then + pco2i_pred_flu(i)=-9999.0d0 + pco2c_pco2i_flu(i)=-9999.0d0 + endif + if(iabs(ifitmode).eq.2)then + anet_pred_flu(i)=-9999.0d0 + pco2c_anet_flu(i)=-9999.0d0 + endif + endif + enddo + return + end subroutine HybridCombinatorial diff --git a/leafres/testarea/sim_ALightCombinatorial.f b/leafres/testarea/sim_ALightCombinatorial.f new file mode 100644 index 0000000..e3d6b3f --- /dev/null +++ b/leafres/testarea/sim_ALightCombinatorial.f @@ -0,0 +1,257 @@ + subroutine sim_ALightCombinatorial() + implicit none + include '../testarea/LeafGasHybridFit.h' + integer i,ilastrubp1,ilastrubis1,ilastrubp2,ilastrubis2, + &ilastrubp3,ilastrubis3,ilastrubp4,ilastrubis4, + &ilastrubp5,ilastrubis5,ilastrubp6,ilastrubis6, + &ilastrubp7,ilastrubis7,ilastrubp8,ilastrubis8, + &ilastrubp9,ilastrubis9,ilastrubp10,ilastrubis10, + &ilastrubp11,ilastrubis11,ilastrubp12,ilastrubis12, + &ilastrubp13,ilastrubis13,ilastrubp14,ilastrubis14, + &ilastrubp15,ilastrubis15 +!common block variables: numALightcurves,nALightPoints(numALightcurves), +!ALightiphotolimit(nALightPoints,numALightcurves) + + if(numALightcurves.eq.0)then +!no conventional A/Light curves. go to free-style measurements directly and then return + call FreeCombinatorial() + return + endif +!(before 17/09/2014 remarks.) Assume rubp, rubisco and tpu limitations in the order of (rubp, rubisco, tpu) but any limitation can be missing in any light response curves +!the nALightPoints data in each light response curve must be ordered from low to high PAR. When ordered in such, the three limitation states +!should occur in the order of (rubp, rubisco, tpu) +! +!17/09/2014 Wenting found (RuBP, TPU, Rubisco) is more likely for A/Light curves if Ci decreases with increased light. Thus the following +!changes are made: +!we generally assume the points of an A/Light curve are lined up in a sequence of (RuBP, TPU and Rubisco), which is indicated by +!ialightorder=0. However, if Ci increases steadily from nstartalight to the end, we assume a sequence of (RuBP, Rubisco and TPU), +!which is indicated by ialightorder=2. +! +!Assume a light response curve is either rubp and rubisco or rubp and tpu + + do ilastrubp1=nstartalight(1),nendalight(1) + do i=1,ilastrubp1 + ALightiphotolimit(i,1)=2 + enddo + do 1 ilastrubis1=1,2 + do i=ilastrubp1+1,nALightPoints(1) + ALightiphotolimit(i,1)=2*ilastrubis1-1 + enddo + if(numALightcurves.eq.1)then + call FreeCombinatorial() + goto 1 + endif + + do ilastrubp2=nstartalight(2),nendalight(2) + do i=1,ilastrubp2 + ALightiphotolimit(i,2)=2 + enddo + do 2 ilastrubis2=1,2 + do i=ilastrubp2+1,nALightPoints(2) + ALightiphotolimit(i,2)=2*ilastrubis2-1 + enddo + if(numALightcurves.eq.2)then + call FreeCombinatorial() + goto 2 + endif + + do ilastrubp3=nstartalight(3),nendalight(3) + do i=1,ilastrubp3 + ALightiphotolimit(i,3)=2 + enddo + do 3 ilastrubis3=1,2 + do i=ilastrubp3+1,nALightPoints(3) + ALightiphotolimit(i,3)=2*ilastrubis3-1 + enddo + if(numALightcurves.eq.3)then + call FreeCombinatorial() + goto 3 + endif + + do ilastrubp4=nstartalight(4),nendalight(4) + do i=1,ilastrubp4 + ALightiphotolimit(i,4)=2 + enddo + do 4 ilastrubis4=1,2 + do i=ilastrubp4+1,nALightPoints(4) + ALightiphotolimit(i,4)=2*ilastrubis4-1 + enddo + if(numALightcurves.eq.4)then + call FreeCombinatorial() + goto 4 + endif + + do ilastrubp5=nstartalight(5),nendalight(5) + do i=1,ilastrubp5 + ALightiphotolimit(i,5)=2 + enddo + do 5 ilastrubis5=1,2 + do i=ilastrubp5+1,nALightPoints(5) + ALightiphotolimit(i,5)=2*ilastrubis5-1 + enddo + if(numALightcurves.eq.5)then + call FreeCombinatorial() + goto 5 + endif + + do ilastrubp6=nstartalight(6),nendalight(6) + do i=1,ilastrubp6 + ALightiphotolimit(i,6)=2 + enddo + do 6 ilastrubis6=1,2 + do i=ilastrubp6+1,nALightPoints(6) + ALightiphotolimit(i,6)=2*ilastrubis6-1 + enddo + if(numALightcurves.eq.6)then + call FreeCombinatorial() + goto 6 + endif + + do ilastrubp7=nstartalight(7),nendalight(7) + do i=1,ilastrubp7 + ALightiphotolimit(i,7)=2 + enddo + do 7 ilastrubis7=1,2 + do i=ilastrubp7+1,nALightPoints(7) + ALightiphotolimit(i,7)=2*ilastrubis7-1 + enddo + if(numALightcurves.eq.7)then + call FreeCombinatorial() + goto 7 + endif + + do ilastrubp8=nstartalight(8),nendalight(8) + do i=1,ilastrubp8 + ALightiphotolimit(i,8)=2 + enddo + do 8 ilastrubis8=1,2 + do i=ilastrubp8+1,nALightPoints(8) + ALightiphotolimit(i,8)=2*ilastrubis8-1 + enddo + if(numALightcurves.eq.8)then + call FreeCombinatorial() + goto 8 + endif + + do ilastrubp9=nstartalight(9),nendalight(9) + do i=1,ilastrubp9 + ALightiphotolimit(i,9)=2 + enddo + do 9 ilastrubis9=1,2 + do i=ilastrubp9+1,nALightPoints(9) + ALightiphotolimit(i,9)=2*ilastrubis9-1 + enddo + if(numALightcurves.eq.9)then + call FreeCombinatorial() + goto 9 + endif + + do ilastrubp10=nstartalight(10),nendalight(10) + do i=1,ilastrubp10 + ALightiphotolimit(i,10)=2 + enddo + do 10 ilastrubis10=1,2 + do i=ilastrubp10+1,nALightPoints(10) + ALightiphotolimit(i,10)=2*ilastrubis10-1 + enddo + if(numALightcurves.eq.10)then + call FreeCombinatorial() + goto 10 + endif + + do ilastrubp11=nstartalight(11),nendalight(11) + do i=1,ilastrubp11 + ALightiphotolimit(i,11)=2 + enddo + do 11 ilastrubis11=1,2 + do i=ilastrubp11+1,nALightPoints(11) + ALightiphotolimit(i,11)=2*ilastrubis11-1 + enddo + if(numALightcurves.eq.11)then + call FreeCombinatorial() + goto 11 + endif + + do ilastrubp12=nstartalight(12),nendalight(12) + do i=1,ilastrubp12 + ALightiphotolimit(i,12)=2 + enddo + do 12 ilastrubis12=1,2 + do i=ilastrubp12+1,nALightPoints(12) + ALightiphotolimit(i,12)=2*ilastrubis12-1 + enddo + if(numALightcurves.eq.12)then + call FreeCombinatorial() + goto 12 + endif + + do ilastrubp13=nstartalight(13),nendalight(13) + do i=1,ilastrubp13 + ALightiphotolimit(i,13)=2 + enddo + do 13 ilastrubis13=1,2 + do i=ilastrubp13+1,nALightPoints(13) + ALightiphotolimit(i,13)=2*ilastrubis13-1 + enddo + if(numALightcurves.eq.13)then + call FreeCombinatorial() + goto 13 + endif + + do ilastrubp14=nstartalight(14),nendalight(14) + do i=1,ilastrubp14 + ALightiphotolimit(i,14)=2 + enddo + do 14 ilastrubis14=1,2 + do i=ilastrubp14+1,nALightPoints(14) + ALightiphotolimit(i,14)=2*ilastrubis14-1 + enddo + if(numALightcurves.eq.14)then + call FreeCombinatorial() + goto 14 + endif + + do ilastrubp15=nstartalight(15),nendalight(15) + do i=1,ilastrubp15 + ALightiphotolimit(i,15)=2 + enddo + do 15 ilastrubis15=1,2 + do i=ilastrubp15+1,nALightPoints(15) + ALightiphotolimit(i,15)=2*ilastrubis15-1 + enddo + if(numALightcurves.eq.15)then + call FreeCombinatorial() + goto 15 + endif +15 continue + enddo +14 continue + enddo +13 continue + enddo +12 continue + enddo +11 continue + enddo +10 continue + enddo +9 continue + enddo +8 continue + enddo +7 continue + enddo +6 continue + enddo +5 continue + enddo +4 continue + enddo +3 continue + enddo +2 continue + enddo +1 continue + enddo + return + end subroutine sim_ALightCombinatorial diff --git a/leafres/testarea/stom_regression.f b/leafres/testarea/stom_regression.f new file mode 100644 index 0000000..f1ddeec --- /dev/null +++ b/leafres/testarea/stom_regression.f @@ -0,0 +1,331 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +! + subroutine StomRegression(npoints,istommodel,pco2s, + & rehulfsurf,gammas,assim_net,gswmeas, + & stomintercept,stomslope,pvapordef_s,rayDzero) + implicit none +c +C ODRPACK ARGUMENT DEFINITIONS +C ==> FCN NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE +C ==> N NUMBER OF OBSERVATIONS +C ==> M COLUMNS OF DATA IN THE EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C <==> BETA FUNCTION PARAMETERS +C ==> Y RESPONSE VARIABLE +C ==> LDY LEADING DIMENSION OF ARRAY Y +C ==> X EXPLANATORY VARIABLE +C ==> LDX LEADING DIMENSION OF ARRAY X +C ==> WE "EPSILON" WEIGHTS +C ==> LDWE LEADING DIMENSION OF ARRAY WE +C ==> LD2WE SECOND DIMENSION OF ARRAY WE +C ==> WD "DELTA" WEIGHTS +C ==> LDWD LEADING DIMENSION OF ARRAY WD +C ==> LD2WD SECOND DIMENSION OF ARRAY WD +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> JOB TASK TO BE PERFORMED +C ==> NDIGIT GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS +C ==> TAUFAC TRUST REGION INITIALIZATION FACTOR +C ==> SSTOL SUM OF SQUARES CONVERGENCE CRITERION +C ==> PARTOL PARAMETER CONVERGENCE CRITERION +C ==> MAXIT MAXIMUM NUMBER OF ITERATIONS +C ==> IPRINT PRINT CONTROL +C ==> LUNERR LOGICAL UNIT FOR ERROR REPORTS +C ==> LUNRPT LOGICAL UNIT FOR COMPUTATION REPORTS +C ==> STPB STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA +C ==> STPD STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA +C ==> LDSTPD LEADING DIMENSION OF ARRAY STPD +C ==> SCLB SCALE VALUES FOR PARAMETERS BETA +C ==> SCLD SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE +C ==> LDSCLD LEADING DIMENSION OF ARRAY SCLD +C <==> WORK DOUBLE PRECISION WORK VECTOR +C ==> LWORK DIMENSION OF VECTOR WORK +C <== IWORK INTEGER WORK VECTOR +C ==> LIWORK DIMENSION OF VECTOR IWORK +C <== INFO STOPPING CONDITION + +C PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER +C MAXN MAXIMUM NUMBER OF OBSERVATIONS +C MAXM MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C MAXNP MAXIMUM NUMBER OF FUNCTION PARAMETERS +C MAXNQ MAXIMUM NUMBER OF RESPONSES PER OBSERVATION + +C PARAMETER DECLARATIONS AND SPECIFICATIONS + INTEGER LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + + LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ + PARAMETER (MAXM=25,MAXN=10000,MAXNP=30,MAXNQ=1, + + LDY=MAXN,LDX=MAXN, + + LDWE=1,LD2WE=1,LDWD=1,LD2WD=1, + + LDIFX=MAXN,LDSTPD=1,LDSCLD=1, + + LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + + + 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP + + + 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + + + 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ, + + LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM)) +C VARIABLE DECLARATIONS + INTEGER I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N, + + NDIGIT,NP,NQ + INTEGER IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK) + DOUBLE PRECISION PARTOL,SSTOL,TAUFAC + DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM), + + STPB(MAXNP),STPD(LDSTPD,MAXM), + + WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ), + + WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ) +c + integer npoints,istommodel,istommodel0,i1,i2,i3,i4,i5 + double precision pco2s(npoints),gswmeas(npoints), + & rehulfsurf(npoints),gammas(npoints), + & assim_net(npoints),pvapordef_s(npoints),stomintercept, + & stomslope,rayDzero + common /stommodelindicator/istommodel0 + + EXTERNAL STOMFCN +c +C SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS + WE(1,1,1) = -1.0D0 + WD(1,1,1) = -1.0D0 + IFIXB(1) = -1 +! IFIXX(1,1) = -1 +! JOB = 00023 + JOB=23 + NDIGIT = -1 + TAUFAC = -1.0D0 + SSTOL = -1.0D0 + PARTOL = -1.0D0 + MAXIT = -1 +! IPRINT = -1 + IPRINT=0 + LUNERR = -1 + LUNRPT = -1 + STPB(1) = -1.0D0 + STPD(1,1) = -1.0D0 + SCLB(1) = -1.0D0 + SCLD(1,1) = -1.0D0 + + MAXIT = 200000 +C SET UP ODRPACK REPORT FILES + LUNERR = 9 + LUNRPT = 9 +c + N=npoints + istommodel0=istommodel + BETA(1)=stomintercept + BETA(2)=stomslope + do I=1,N + X(I,1)=assim_net(I) + Y(I,1)=gswmeas(I) + enddo + + if(istommodel0.eq.1)then +! Ball-Berry + NP=2 + M=3 + do I=1,N + X(I,2)=pco2s(I) + X(I,3)=rehulfsurf(I) + enddo + endif + + if(istommodel0.eq.2)then +! Leuning with leaf surface co2 + NP=3 + BETA(3)=rayDzero + M=4 + do I=1,N + X(I,2)=pco2s(I) + X(I,3)=gammas(I) + X(I,4)=pvapordef_s(I) + enddo + endif + + if(istommodel0.eq.3)then +! Belinda Medlyn model + NP=2 + M=3 + do I=1,N + X(I,2)=pco2s(I) + X(I,3)=pvapordef_s(I) + enddo + endif + + if(istommodel0.eq.4)then +! Dewar model + NP=3 + BETA(3)=rayDzero + M=3 + do I=1,N + X(I,2)=pco2s(I) + X(I,3)=pvapordef_s(I) + enddo + endif + + NQ=1 + +C READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX + DO 10 I=1,N + DO 15 J=1, M + IFIXX(I,J) = 1 +15 CONTINUE +10 CONTINUE +60 CALL DODRC(STOMFCN, + + N,M,NP,NQ, + + BETA, + + Y,LDY,X,LDX, + + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + + IFIXB,IFIXX,LDIFX, + + JOB,NDIGIT,TAUFAC, + + SSTOL,PARTOL,MAXIT, + + IPRINT,LUNERR,LUNRPT, + + STPB,STPD,LDSTPD, + + SCLB,SCLD,LDSCLD, + + WORK,LWORK,IWORK,LIWORK, + + INFO) + i1=mod(INFO,10) + i2=(mod(INFO,100)-i1)/10 + i3=(mod(INFO,1000)-mod(INFO,100))/100 + i4=(mod(INFO,10000)-mod(INFO,1000))/1000 + i5=(INFO-mod(INFO,10000))/10000 + + stomintercept=BETA(1) + stomslope=BETA(2) + if(istommodel0.eq.2.or.istommodel0.eq.4)RayDzero=BETA(3) + return + END +c + SUBROUTINE STOMFCN(N,M,NP,NQ, + + LDN,LDM,LDNP, + + BETA,XPLUSD, + + IFIXB,IFIXX,LDIFX, + + IDEVAL,F,FJACB,FJACD, + + ISTOP) + implicit none +C SUBROUTINE ARGUMENTS +C ==> N NUMBER OF OBSERVATIONS +C ==> M NUMBER OF COLUMNS IN EXPLANATORY VARIABLE +C ==> NP NUMBER OF PARAMETERS +C ==> NQ NUMBER OF RESPONSES PER OBSERVATION +C ==> LDN LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N +C ==> LDM LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M +C ==> LDNP LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP +C ==> BETA CURRENT VALUES OF PARAMETERS +C ==> XPLUSD CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA +C ==> IFIXB INDICATORS FOR "FIXING" PARAMETERS (BETA) +C ==> IFIXX INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X) +C ==> LDIFX LEADING DIMENSION OF ARRAY IFIXX +C ==> IDEVAL INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED +C <== F PREDICTED FUNCTION VALUES +C <== FJACB JACOBIAN WITH RESPECT TO BETA +C <== FJACD JACOBIAN WITH RESPECT TO ERRORS DELTA +C <== ISTOP STOPPING CONDITION, WHERE +C 0 MEANS CURRENT BETA AND X+DELTA WERE +C ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY +C 1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD SELECT VALUES +C CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE +C -1 MEANS CURRENT BETA AND X+DELTA ARE +C NOT ACCEPTABLE; ODRPACK SHOULD STOP + +C INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE: + INTEGER I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ + DOUBLE PRECISION BETA(NP+1),XPLUSD(LDN,M) + INTEGER IFIXB(NP+1),IFIXX(LDIFX,M) +C OUTPUT ARGUMENTS: + DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ) + + integer istommodel0 + common /stommodelindicator/istommodel0 + + double precision pco2s,rehulfsurf,gammas, + & pvapordef_s,rayDzero,assim_net,stomintercept, + & stomslope,gswmod,derivb,derivslope,derivd0 + +C CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM +c + do I=1,NP + if(BETA(I).lt.0.0d0)then + ISTOP = 1 + RETURN + endif + enddo +! + IF (MOD(IDEVAL,10).GE.1) THEN + DO 110 L = 1,NQ + DO 100 I = 1,N + stomintercept=BETA(1) + stomslope=BETA(2) + assim_net=XPLUSD(I,1) + if(istommodel0.eq.1)then +! Ball-Berry + pco2s=XPLUSD(I,2) + rehulfsurf=XPLUSD(I,3) + endif + if(istommodel0.eq.2)then +! Leuning with leaf surface co2 + RayDzero=BETA(3) + pco2s=XPLUSD(I,2) + gammas=XPLUSD(I,3) + pvapordef_s=XPLUSD(I,4) + endif + if(istommodel0.eq.3)then +! Belinda Medlyn with leaf surface co2 + pco2s=XPLUSD(I,2) + pvapordef_s=XPLUSD(I,3) + endif + if(istommodel0.eq.4)then +! dewar with leaf surface co2 + RayDzero=BETA(3) + pco2s=XPLUSD(I,2) + pvapordef_s=XPLUSD(I,3) + endif + call StomatalConductance(pco2s,rehulfsurf,gammas, + & pvapordef_s,rayDzero,assim_net,istommodel0, + & stomintercept,stomslope,gswmod) + F(I,L)=gswmod + 100 CONTINUE + 110 CONTINUE + END IF + +C COMPUTE DERIVATIVES WITH RESPECT TO BETA + IF (MOD(IDEVAL/10,10).GE.1) THEN + DO 210 L = 1,NQ + DO 200 I = 1,N + stomintercept=BETA(1) + stomslope=BETA(2) + assim_net=XPLUSD(I,1) + if(istommodel0.eq.1)then +! Ball-Berry + pco2s=XPLUSD(I,2) + rehulfsurf=XPLUSD(I,3) + endif + if(istommodel0.eq.2)then +! Leuning with leaf surface co2 + RayDzero=BETA(3) + pco2s=XPLUSD(I,2) + gammas=XPLUSD(I,3) + pvapordef_s=XPLUSD(I,4) + endif + if(istommodel0.eq.3)then +! Belinda Medlyn model + pco2s=XPLUSD(I,2) + pvapordef_s=XPLUSD(I,3) + endif + if(istommodel0.eq.4)then +! Dewar model + RayDzero=BETA(3) + pco2s=XPLUSD(I,2) + pvapordef_s=XPLUSD(I,3) + endif + call Der_StomatalConductance(pco2s,rehulfsurf,gammas, + & pvapordef_s,rayDzero,assim_net,istommodel0, + & stomintercept,stomslope,derivb,derivslope,derivd0) + FJACB(I,1,L)=derivb + FJACB(I,2,L)=derivslope + if(istommodel0.eq.2.or.istommodel0.eq.4)FJACB(I,3,L)=derivd0 + 200 CONTINUE + 210 CONTINUE + END IF + RETURN + END +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/leafres/testarea/stomlfitbasis.f b/leafres/testarea/stomlfitbasis.f new file mode 100644 index 0000000..1ba411e --- /dev/null +++ b/leafres/testarea/stomlfitbasis.f @@ -0,0 +1,12 @@ + subroutine lfitbasisfuncs(x,afunc,ma) + implicit none + integer ma + double precision x,afunc(ma) + afunc(1)=1.0d0 + afunc(2)=x + if(ma.gt.2)then + afunc(3)=x*x/1000.0d0 + endif + return + end + diff --git a/leafres/testarea/stomoptim.h b/leafres/testarea/stomoptim.h new file mode 100644 index 0000000..2ef3a53 --- /dev/null +++ b/leafres/testarea/stomoptim.h @@ -0,0 +1,16 @@ +! used for the stomatal optimization block + integer maxdimobs + parameter(maxdimobs=200) + + double precision xpco2i(maxdimobs),pco2s(maxdimobs), + & rehulfsurf(maxdimobs),gammas(maxdimobs),pres_air(maxdimobs), + & assim_net(maxdimobs),gswmeas(maxdimobs),pvapordef_s(maxdimobs), + & bmin(10),bmax(10) + + common /stomvariables/xpco2i,pco2s,rehulfsurf,gammas, + & pres_air,assim_net,gswmeas,pvapordef_s,bmin,bmax + + integer istommodel,nobs + common /stomindices/istommodel,nobs + +!-------- End of list of common block variables ------------------ diff --git a/leafres/testarea/stomoptimization.f b/leafres/testarea/stomoptimization.f new file mode 100644 index 0000000..b839d3f --- /dev/null +++ b/leafres/testarea/stomoptimization.f @@ -0,0 +1,69 @@ +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + subroutine stomoptimization(npoints,ioption,pco2s0,rehulfsurf0, + &gammas0,yAnet0,gswmeas0,stomintercept,stomslope,pvapordef_s0, + &rayDzero) + implicit none + include '../testarea/stomoptim.h' +c + integer npoints,ioption + double precision pco2s0(npoints),rehulfsurf0(npoints), + &gammas0(npoints),yAnet0(npoints),gswmeas0(npoints), + &pvapordef_s0(npoints),stomintercept,stomslope,rayDzero + integer i,ndim + double precision beta(10),fatbeta,ftol + parameter(ftol=1.0d-7) + external funkmin_stom,f1dim_stom + + istommodel=ioption + nobs = npoints + + do i=1,npoints + pco2s(i)=pco2s0(i) + rehulfsurf(i)=rehulfsurf0(i) + gammas(i)=gammas0(i) + assim_net(i)=yAnet0(i) + gswmeas(i)=gswmeas0(i) + pvapordef_s(i)=pvapordef_s0(i) + enddo + + ndim=2 + beta(1)=stomintercept + bmin(1)=0.0d0 + bmax(1)=1.0d+7 + if(stomintercept.lt.bmin(1).or.stomintercept.gt.bmax(1)) + &beta(1)=0.001d0 + + beta(2)=stomslope + bmin(2)=0.0d0 + bmax(2)=1.0d+8 + if(stomslope.lt.bmin(2).or.stomslope.gt.bmax(2)) + &beta(2)=10.0d0 + + if(istommodel.eq.1.or.istommodel.eq.3)then + ndim=2 + endif + if(istommodel.eq.2.or.istommodel.eq.4)then + ndim=3 + beta(3)=rayDzero + bmin(3)=0.00001d0 + bmax(3)=1.0d+8 + if(rayDzero.lt.bmin(3).or.rayDzero.gt.bmax(3)) + &beta(3)=2000.0d0 + endif +! +! Initialize the cost function evaluation counter in the subroutine funkmin. +! The counter counts and memorizes points where the cost function is evaluated. + + call funkmin_stom(ndim,beta,fatbeta) + call nongradopt(ndim,funkmin_stom,f1dim_stom,beta, + & bmin,bmax,ftol,fatbeta) + call RepeatCompassSearch(ndim,beta,fatbeta,bmin, + & bmax,funkmin_stom,f1dim_stom,ftol) +! Replace these parameters with their optimized values + stomintercept=beta(1) + stomslope=beta(2) + if(istommodel.eq.2.or.istommodel.eq.4)rayDzero=beta(3) + return + END subroutine stomoptimization +c +!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ diff --git a/leafres/testarea/surffunc.f b/leafres/testarea/surffunc.f new file mode 100644 index 0000000..f00768f --- /dev/null +++ b/leafres/testarea/surffunc.f @@ -0,0 +1,227 @@ + subroutine surffunc(nyvars,yvars,nxvars, + & xvars,ndim,beta,dydxp,idowhat) + implicit none +!idowhat=0, value of the function only +!idowhat=1, derivative with respect to the independent variable x +!idowhat=2, derivative with respect to the parameters + integer nyvars,nxvars,ndim,idowhat + double precision yvars(nyvars),xvars(nxvars), + &beta(5),dydxp(nyvars,(nxvars+5)) +!------------------------------------------------------- + double precision y0,a,b,c,x0,x,term,crit + parameter(crit=300.0d0) + a=beta(1) + b=beta(2) + c=beta(3) + x=xvars(1) + if(ndim.eq.3)then + term=dexp(-b*x) + if(idowhat.eq.0)yvars(1)=c+a*(1.0d0-term) + if(idowhat.eq.1)then + dydxp(1,1)=a*b*term + endif + if(idowhat.eq.2)then + dydxp(1,1)=1.0d0-term + dydxp(1,2)=a*x*term + dydxp(1,3)=1.0d0 + endif + return + endif + if(ndim.eq.4)then + x0=beta(4) + if(idowhat.eq.0)yvars(1)=a*(1.0d0-b*x)*(x-x0)/(1.0d0+c*x) + if(idowhat.eq.1)then + dydxp(1,1)=a*(1.0d0-2.0d0*b*x-b*c*x*x+(b+c)*x0)/ + &((1.0d0+c*x)*(1.0d0+c*x)) + endif + if(idowhat.eq.2)then + dydxp(1,1)=(1.0d0-b*x)*(x-x0)/(1.0d0+c*x) + dydxp(1,2)=a*(1.0d0-x)*(x-x0)/(1.0d0+c*x) + dydxp(1,3)=-a*(1.0d0-b*x)*(x-x0)*x/((1.0d0+c*x)*(1.0d0+c*x)) + dydxp(1,4)=-a*(1.0d0-b*x)/(1.0d0+c*x) + endif + return + endif +! if(ndim.eq.3)then +! yvars(1)=(1.0d0+a*x)/(b+c*x) +! if(idowhat.eq.0)return +! if(idowhat.eq.1)then +! dydxp(1,1)=(a-yvars(1)*c)/(b+c*x) +! return +! endif +! if(idowhat.eq.2)then +! dydxp(1,1)=x/(b+c*x) +! dydxp(1,2)=-yvars(1)/(b+c*x) +! dydxp(1,3)=-yvars(1)*dydxp(1,1) +! return +! endif +! endif + +!A/Ci or A/PAR curves + x0=beta(4) + y0=beta(5) + if(idowhat.eq.0)then + if((-(x-x0)/b).lt.crit)then + term=dexp(-(x-x0)/b) + yvars(1)=y0+a*(1.0d0/(1.0d0+term))**c + else + term=dexp((x-x0)/b) + yvars(1)=y0+a*(term/(1.0d0+term))**c + endif + endif + if(idowhat.eq.1)then + if((-(x-x0)/b).lt.crit)then + term=dexp(-(x-x0)/b) + dydxp(1,1)=(a*c*term/b)* + & (1.0d0/(1.0d0+term))**(1.0d0+c) + else + term=(x-x0)/b + dydxp(1,1)=(a*c/b)*(dexp(term*c/(c+1.0d0))/ + & (1.0d0+dexp(term)))**(c+1.0d0) + endif + endif + if(idowhat.eq.2)then + dydxp(1,5)=1.0d0 + if((-(x-x0)/b).lt.crit)then + term=dexp(-(x-x0)/b) + dydxp(1,1)=(1.0d0/(1.0d0+term))**c + dydxp(1,4)=-(a*c*term/b)* + & (1.0d0/(1.0d0+term))**(1.0d0+c) + dydxp(1,2)=-(a*c*term*(x-x0)/(b*b))* + & (1.0d0/(1.0d0+term))**(1.0d0+c) + dydxp(1,3)=-(a*dlog(1.0d0+term))* + & (1.0d0/(1.0d0+term))**c + else + term=(x-x0)/b + dydxp(1,1)=(dexp(term)/(1.0d0+dexp(term)))**c + dydxp(1,4)=-(a*c/b)*(dexp(term*c/(c+1))/ + & (1.0d0+dexp(term)))**(c+1.0d0) + dydxp(1,2)=-(a*c*(x-x0)/(b*b))*(dexp(term*c/ + & (c+1.0d0))/(1.0d0+dexp(term)))**(1.0d0+c) + dydxp(1,3)=-a*(dlog(1.0d0+dexp(term))-term)* + & (dexp(term)/(1.0d0+dexp(term)))**c + endif + endif + return + end +!========================================================== + subroutine properties_surffunc(ndim,beta,root,der_root,fmax, + &yinter,der_yinter,agivenx,der_agivenx,funcval_agivenx, + &xmin,xmax,curvatmax,xcurvatmax) + implicit none + integer ndim + double precision beta(5),root,der_root,fmax,yinter,der_yinter, + &agivenx,der_agivenx,funcval_agivenx,xmin,xmax,curvatmax,xcurvatmax + double precision a,b,c,x0,y0,term,term1,term2,term3,step, + &deratx,der2atx + + a=beta(1) + b=beta(2) + c=beta(3) + + if(ndim.eq.3)then +!y=c+a(1-exp(-bx)) + root=-dlog(1.0d0+c/a)/b + der_root=a*b*dexp(-b*root) + fmax=c+a + yinter=c + der_yinter=a*b + funcval_agivenx=c+a*(1.0d0-dexp(-b*agivenx)) + der_agivenx=a*b*dexp(-b*agivenx) + xcurvatmax=dlog(2*a*a*b*b)/(2.0d0*b) +! curvatmax=-a*b*b*dexp(-b*xcurvatmax)/ +! &((1.0d0+a*a*b*b*dexp(-2.0d0*b*xcurvatmax))**1.5d0) + curvatmax=-b*0.3849d0 + curvatmax=dabs(curvatmax)*1000.0d0 + return + endif + + if(ndim.eq.4)then +!y=a*(1-bx)*(x-x0)/(1+c*x) +!we ignore the other root +!dydxp(1,1)=a*(1.0d0-2.0d0*b*x-b*c*x*x+(b+c)*x0)/((1.0d0+c*x)*(1.0d0+c*x)) + x0=beta(4) + root=x0 + der_root=a*(1.0d0-2.0d0*b*root-b*c*root*root+(b+c)*x0)/ + &((1.0d0+c*root)*(1.0d0+c*root)) + term=(dsqrt((b+c)*(1.0d0+c*x0)/b)-1.0d0)/c + fmax=a*(1.0d0-b*term)*(term-x0)/(1.0d0+c*term) + yinter=-a*x0 + der_yinter=a*(1.0d0+(b+c)*x0) + funcval_agivenx=a*(1.0d0-b*agivenx)*(agivenx-x0)/ + &(1.0d0+c*agivenx) + der_agivenx= + &a*(1.0d0-2.0d0*b*agivenx-b*c*agivenx*agivenx+(b+c)*x0)/ + &((1.0d0+c*agivenx)*(1.0d0+c*agivenx)) + xcurvatmax=-9999.0d0 + curvatmax=-9999.0d0 + return + endif +! if(ndim.eq.3)then +!y=(1+a*x)/(b+c*x) +! root=-1.0d0/a +! der_root=a/(b-c/a) +! fmax=a/c +! yinter=1.0d0/b +! der_yinter=(a*b-c)/(b*b) +! return +! endif + x0=beta(4) + y0=beta(5) + if((-a/y0).gt.0.0d0)then + term=(-a/y0)**(1.0d0/c)-1.0d0 + root=x0-b*dlog(term) + term=dexp(-(root-x0)/b) + der_root=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c) + else + root=-9999.0d0 + der_root=-9999.0d0 + endif + fmax=a+y0 + call surffunc(1,yinter,1,0.0d0,ndim,beta,term,0) + call surffunc(1,term,1,0.0d0,ndim,beta,der_yinter,1) + call surffunc(1,term,1,agivenx,ndim,beta,der_agivenx,1) + call surffunc(1,funcval_agivenx,1,agivenx,ndim,beta,term,0) + + curvatmax=-9999.0d0 + xcurvatmax=-9999.0d0 + step=(xmax-xmin)/1000.0d0 + do term=xmin,xmax,step + call surffunc(1,term1,1,term,ndim,beta,deratx,1) + term2=dexp(-(term-x0)/b) + der2atx=-deratx/b+ + &(1.0d0+c)*deratx*deratx*((1.0d0+term2)**c)/(a*c) + term3=dabs(der2atx/((1.0d0+deratx*deratx)**1.5d0)) + if(term3.gt.curvatmax)then + curvatmax=term3 + xcurvatmax=term + endif + enddo + if(dabs(xcurvatmax-xmin).le.step.or. + &dabs(xcurvatmax-xmax).le.step)then + curvatmax=-9999.0d0 + xcurvatmax=-9999.0d0 + else + curvatmax=dabs(curvatmax)*1000.0d0 + endif + return + end +!========================================================== + subroutine indices_surffunc(ndim,beta,root, + & der_root,fmax) + implicit none + integer ndim + double precision beta(ndim),root,der_root,fmax + double precision a,b,c,x0,y0,term + a=beta(1) + b=beta(2) + c=beta(3) + x0=beta(4) + y0=beta(5) + term=(-a/y0)**(1.0d0/c)-1.0d0 + root=x0-b*dlog(term) + term=dexp(-(root-x0)/b) + der_root=(a*c*term/b)*(1.0d0/(1.0d0+term))**(1.0d0+c) + fmax=a+y0 + return + end diff --git a/leafres/testarea/time_resolution.f b/leafres/testarea/time_resolution.f new file mode 100644 index 0000000..cf057d3 --- /dev/null +++ b/leafres/testarea/time_resolution.f @@ -0,0 +1,51 @@ + subroutine time_resolution(npoints,sampletime, + & avetimeresolution,avetimesampled) + implicit none + integer npoints + double precision sampletime(npoints), + & avetimeresolution,avetimesampled + +! sampletime: hour fraction +! avetimeresolution: minutes +! avetimesampled: hour fraction + + integer i,j,nactual + double precision term,copy(npoints),temp,sum + + nactual=0 + do i=1,npoints + if(sampletime(i).gt.-9000.0d0)then + nactual=nactual+1 + copy(nactual)=sampletime(i) + endif + enddo + if(nactual.eq.0)then + avetimeresolution=-9999.0d0 + avetimesampled=-9999.0d0 + return + endif + do i=1,nactual + do j=i,nactual + if(copy(j).lt.copy(i))then + temp=copy(i) + copy(i)=copy(j) + copy(j)=temp + endif + enddo + enddo + + sum=copy(1) + avetimeresolution=0.0d0 + do i=2,nactual + sum=sum+copy(i) + avetimeresolution=avetimeresolution+copy(i)-copy(i-1) + enddo + avetimesampled=sum/dble(nactual) + if(nactual.eq.1)then + avetimeresolution=-9999.0d0 + else + avetimeresolution=60.0d0* + & avetimeresolution/dble(nactual-1) + endif + return + end diff --git a/leafres/testarea/try.f b/leafres/testarea/try.f new file mode 100644 index 0000000..8a43fb2 --- /dev/null +++ b/leafres/testarea/try.f @@ -0,0 +1,6 @@ + program try + integer i,k(5) + do 1 k(2)=1,3 +1 continue + end + diff --git a/leafres/testrun/Makefile b/leafres/testrun/Makefile new file mode 100644 index 0000000..bb3c27e --- /dev/null +++ b/leafres/testrun/Makefile @@ -0,0 +1,38 @@ +# This is the makefile for piscal +# name of executable +ALL = mpipiscal + +# compiler options +FF = mpif90 +#FOPTS = -g -C +FOPTS = -g + +#Base directory +BASEDIR = /home/piscaladmin + +VPATH =$(BASEDIR)/leafres/testarea:\ + $(BASEDIR)/dataassim/math/optimization:\ + $(BASEDIR)/dataassim/math/othersupmath:\ + $(BASEDIR)/dataassim/math/algebra:\ + $(BASEDIR)/dataassim/math/specialfuncs:\ + $(BASEDIR)/dataassim/math/nonlinsystems/ + +# Define objects + +OBJS = LeafGasPISCAL_single.o adsor.o clustering.o cppowell.o GenericRegres.o lfit.o stomoptimization.o ALightCombinatorial.o commonparameters.o\ + dble_pikaia.o HybridCombinatorial.o powell.o stom_regression.o Anet_Final.o CompassSearch.o extCharToFloatNum.o ilimittypestats.o\ + SetUpLeafGasFit.o bookkeeping.o cpbookkeeping.o Externals_GenericRegres.o ispartnum.o shortestdist.o supmath.o\ + broydn.o cpbroydn.o fixedpoint.o leafanetmodel.o nongradopt.o sigmoid.o surffunc.o charlineparser.o cpCompassSearch.o FreeCombinatorial.o\ + LeafGasFit_Stom.o nonsyssolver.o time_resolution.o CharToNumeric.o cpfixedpoint.o funkmin_cica5.o NumberToChar.o\ + stdmaxmeanmin.o ToLeafGasOptimization.o cica5.o cpnongradopt.o funkmin_stom.o LeafGasPrintToFiles.o odr_leastsquare.o StomatalConductance.o\ + UnivParamsAlloc.o cica_Regression5.o cpnonsyssolver.o funkmin_UnivPhotoFit.o leafunivphotosyn.o odrpack.o stomlfitbasis.o UnivPhotoFit.o\ + fluorescencejmax.o funkmin_flujmax.o pam_parameters.o + +$(ALL): $(OBJS) + $(FF) $(FOPTS) $(OBJS) -o $@ + +.f.o: + $(FF) -c $(FOPTS) $< + +depend: + /usr/bin/X11/makedepend -- $(CFLAGS) -- $(SRCS)