Fcalva/OpenLibm
1
0
Fork 0
mirror of https://git.planet-casio.com/Lephenixnoir/OpenLibm.git synced 2025-01-01 06:23:39 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions
OpenLibm/slatec/scov.f
Viral B. Shah c977aa998f Add Makefile.extras to build libopenlibm-extras. 
Replace amos with slatec
2012-12-31 16:37:05 -05:00

264 lines
9 KiB
Fortran
Raw Blame History

*DECK SCOV
SUBROUTINE SCOV (FCN, IOPT, M, N, X, FVEC, R, LDR, INFO, WA1, WA2,
+ WA3, WA4)
C***BEGIN PROLOGUE SCOV
C***PURPOSE Calculate the covariance matrix for a nonlinear data
C fitting problem. It is intended to be used after a
C successful return from either SNLS1 or SNLS1E.
C***LIBRARY SLATEC
C***CATEGORY K1B1
C***TYPE SINGLE PRECISION (SCOV-S, DCOV-D)
C***KEYWORDS COVARIANCE MATRIX, NONLINEAR DATA FITTING,
C NONLINEAR LEAST SQUARES
C***AUTHOR Hiebert, K. L., (SNLA)
C***DESCRIPTION
C
C 1. Purpose.
C
C SCOV calculates the covariance matrix for a nonlinear data
C fitting problem. It is intended to be used after a
C successful return from either SNLS1 or SNLS1E. SCOV
C and SNLS1 (and SNLS1E) have compatible parameters. The
C required external subroutine, FCN, is the same
C for all three codes, SCOV, SNLS1, and SNLS1E.
C
C 2. Subroutine and Type Statements.
C
C SUBROUTINE SCOV(FCN,IOPT,M,N,X,FVEC,R,LDR,INFO,
C WA1,WA2,WA3,WA4)
C INTEGER IOPT,M,N,LDR,INFO
C REAL X(N),FVEC(M),R(LDR,N),WA1(N),WA2(N),WA3(N),WA4(M)
C EXTERNAL FCN
C
C 3. Parameters.
C
C FCN is the name of the user-supplied subroutine which calculates
C the functions. If the user wants to supply the Jacobian
C (IOPT=2 or 3), then FCN must be written to calculate the
C Jacobian, as well as the functions. See the explanation
C of the IOPT argument below. FCN must be declared in an
C EXTERNAL statement in the calling program and should be
C written as follows.
C
C SUBROUTINE FCN(IFLAG,M,N,X,FVEC,FJAC,LDFJAC)
C INTEGER IFLAG,LDFJAC,M,N
C REAL X(N),FVEC(M)
C ----------
C FJAC and LDFJAC may be ignored , if IOPT=1.
C REAL FJAC(LDFJAC,N) , if IOPT=2.
C REAL FJAC(N) , if IOPT=3.
C ----------
C IFLAG will never be zero when FCN is called by SCOV.
C RETURN
C ----------
C If IFLAG=1, calculate the functions at X and return
C this vector in FVEC.
C RETURN
C ----------
C If IFLAG=2, calculate the full Jacobian at X and return
C this matrix in FJAC. Note that IFLAG will never be 2 unless
C IOPT=2. FVEC contains the function values at X and must
C not be altered. FJAC(I,J) must be set to the derivative
C of FVEC(I) with respect to X(J).
C RETURN
C ----------
C If IFLAG=3, calculate the LDFJAC-th row of the Jacobian
C and return this vector in FJAC. Note that IFLAG will
C never be 3 unless IOPT=3. FJAC(J) must be set to
C the derivative of FVEC(LDFJAC) with respect to X(J).
C RETURN
C ----------
C END
C
C
C The value of IFLAG should not be changed by FCN unless the
C user wants to terminate execution of SCOV. In this case, set
C IFLAG to a negative integer.
C
C
C IOPT is an input variable which specifies how the Jacobian will
C be calculated. If IOPT=2 or 3, then the user must supply the
C Jacobian, as well as the function values, through the
C subroutine FCN. If IOPT=2, the user supplies the full
C Jacobian with one call to FCN. If IOPT=3, the user supplies
C one row of the Jacobian with each call. (In this manner,
C storage can be saved because the full Jacobian is not stored.)
C If IOPT=1, the code will approximate the Jacobian by forward
C differencing.
C
C M is a positive integer input variable set to the number of
C functions.
C
C N is a positive integer input variable set to the number of
C variables. N must not exceed M.
C
C X is an array of length N. On input X must contain the value
C at which the covariance matrix is to be evaluated. This is
C usually the value for X returned from a successful run of
C SNLS1 (or SNLS1E). The value of X will not be changed.
C
C FVEC is an output array of length M which contains the functions
C evaluated at X.
C
C R is an output array. For IOPT=1 and 2, R is an M by N array.
C For IOPT=3, R is an N by N array. On output, if INFO=1,
C the upper N by N submatrix of R contains the covariance
C matrix evaluated at X.
C
C LDR is a positive integer input variable which specifies
C the leading dimension of the array R. For IOPT=1 and 2,
C LDR must not be less than M. For IOPT=3, LDR must not
C be less than N.
C
C INFO is an integer output variable. If the user has terminated
C execution, INFO is set to the (negative) value of IFLAG. See
C description of FCN. Otherwise, INFO is set as follows.
C
C INFO = 0 Improper input parameters (M.LE.0 or N.LE.0).
C
C INFO = 1 Successful return. The covariance matrix has been
C calculated and stored in the upper N by N
C submatrix of R.
C
C INFO = 2 The Jacobian matrix is singular for the input value
C of X. The covariance matrix cannot be calculated.
C The upper N by N submatrix of R contains the QR
C factorization of the Jacobian (probably not of
C interest to the user).
C
C WA1 is a work array of length N.
C WA2 is a work array of length N.
C WA3 is a work array of length N.
C WA4 is a work array of length M.
C
C***REFERENCES (NONE)
C***ROUTINES CALLED ENORM, FDJAC3, QRFAC, RWUPDT, XERMSG
C***REVISION HISTORY (YYMMDD)
C 810522 DATE WRITTEN
C 890505 REVISION DATE from Version 3.2
C 891214 Prologue converted to Version 4.0 format. (BAB)
C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ)
C 900510 Fixed an error message. (RWC)
C***END PROLOGUE SCOV
C
C REVISED 820707-1100
C REVISED YYMMDD HHMM
C
INTEGER I,IDUM,IFLAG,INFO,IOPT,J,K,KP1,LDR,M,N,NM1,NROW
REAL X(*),R(LDR,*),FVEC(*),WA1(*),WA2(*),WA3(*),WA4(*)
EXTERNAL FCN
REAL ONE,SIGMA,TEMP,ZERO
LOGICAL SING
SAVE ZERO, ONE
DATA ZERO/0.E0/,ONE/1.E0/
C***FIRST EXECUTABLE STATEMENT SCOV
SING=.FALSE.
IFLAG=0
IF (M.LE.0 .OR. N.LE.0) GO TO 300
C
C CALCULATE SIGMA = (SUM OF THE SQUARED RESIDUALS) / (M-N)
IFLAG=1
CALL FCN(IFLAG,M,N,X,FVEC,R,LDR)
IF (IFLAG.LT.0) GO TO 300
TEMP=ENORM(M,FVEC)
SIGMA=ONE
IF (M.NE.N) SIGMA=TEMP*TEMP/(M-N)
C
C CALCULATE THE JACOBIAN
IF (IOPT.EQ.3) GO TO 200
C
C STORE THE FULL JACOBIAN USING M*N STORAGE
IF (IOPT.EQ.1) GO TO 100
C
C USER SUPPLIES THE JACOBIAN
IFLAG=2
CALL FCN(IFLAG,M,N,X,FVEC,R,LDR)
GO TO 110
C
C CODE APPROXIMATES THE JACOBIAN
100 CALL FDJAC3(FCN,M,N,X,FVEC,R,LDR,IFLAG,ZERO,WA4)
110 IF (IFLAG.LT.0) GO TO 300
C
C COMPUTE THE QR DECOMPOSITION
CALL QRFAC(M,N,R,LDR,.FALSE.,IDUM,1,WA1,WA1,WA1)
DO 120 I=1,N
120 R(I,I)=WA1(I)
GO TO 225
C
C COMPUTE THE QR FACTORIZATION OF THE JACOBIAN MATRIX CALCULATED ONE
C ROW AT A TIME AND STORED IN THE UPPER TRIANGLE OF R.
C ( (Q TRANSPOSE)*FVEC IS ALSO CALCULATED BUT NOT USED.)
200 CONTINUE
DO 210 J=1,N
WA2(J)=ZERO
DO 205 I=1,N
R(I,J)=ZERO
205 CONTINUE
210 CONTINUE
IFLAG=3
DO 220 I=1,M
NROW = I
CALL FCN(IFLAG,M,N,X,FVEC,WA1,NROW)
IF (IFLAG.LT.0) GO TO 300
TEMP=FVEC(I)
CALL RWUPDT(N,R,LDR,WA1,WA2,TEMP,WA3,WA4)
220 CONTINUE
C
C CHECK IF R IS SINGULAR.
225 CONTINUE
DO 230 I=1,N
IF (R(I,I).EQ.ZERO) SING=.TRUE.
230 CONTINUE
IF (SING) GO TO 300
C
C R IS UPPER TRIANGULAR. CALCULATE (R TRANSPOSE) INVERSE AND STORE
C IN THE UPPER TRIANGLE OF R.
IF (N.EQ.1) GO TO 275
NM1=N-1
DO 270 K=1,NM1
C
C INITIALIZE THE RIGHT-HAND SIDE (WA1(*)) AS THE K-TH COLUMN OF THE
C IDENTITY MATRIX.
DO 240 I=1,N
WA1(I)=ZERO
240 CONTINUE
WA1(K)=ONE
C
R(K,K)=WA1(K)/R(K,K)
KP1=K+1
DO 260 I=KP1,N
C
C SUBTRACT R(K,I-1)*R(I-1,*) FROM THE RIGHT-HAND SIDE, WA1(*).
DO 250 J=I,N
WA1(J)=WA1(J)-R(K,I-1)*R(I-1,J)
250 CONTINUE
R(K,I)=WA1(I)/R(I,I)
260 CONTINUE
270 CONTINUE
275 R(N,N)=ONE/R(N,N)
C
C CALCULATE R-INVERSE * (R TRANSPOSE) INVERSE AND STORE IN THE UPPER
C TRIANGLE OF R.
DO 290 I=1,N
DO 290 J=I,N
TEMP=ZERO
DO 280 K=J,N
TEMP=TEMP+R(I,K)*R(J,K)
280 CONTINUE
R(I,J)=TEMP*SIGMA
290 CONTINUE
INFO=1
C
300 CONTINUE
IF (M.LE.0 .OR. N.LE.0) INFO=0
IF (IFLAG.LT.0) INFO=IFLAG
IF (SING) INFO=2
IF (INFO .LT. 0) CALL XERMSG ('SLATEC', 'SCOV',
+ 'EXECUTION TERMINATED BECAUSE USER SET IFLAG NEGATIVE.', 1, 1)
IF (INFO .EQ. 0) CALL XERMSG ('SLATEC', 'SCOV',
+ 'INVALID INPUT PARAMETER.', 2, 1)
IF (INFO .EQ. 2) CALL XERMSG ('SLATEC', 'SCOV',
+ 'SINGULAR JACOBIAN MATRIX, COVARIANCE MATRIX CANNOT BE ' //
+ 'CALCULATED.', 1, 1)
RETURN
END
Reference in a new issue View git blame Copy permalink