*SODR
SUBROUTINE SODR
+ (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 SODR
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 SINGLE 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 SODCNT
C***END PROLOGUE SODR
C...SCALAR ARGUMENTS
INTEGER
+ INFO,JOB,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,LIWORK,LWORK,
+ M,N,NDIGIT,NP,NQ
C...ARRAY ARGUMENTS
REAL
+ 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
REAL
+ NEGONE,PARTOL,SSTOL,TAUFAC,ZERO
INTEGER
+ IPRINT,LDIFX,LDSCLD,LDSTPD,LUNERR,LUNRPT,MAXIT
LOGICAL
+ SHORT
C...LOCAL ARRAYS
REAL
+ SCLB(1),SCLD(1,1),STPB(1),STPD(1,1),WD1(1,1,1)
INTEGER
+ IFIXB(1),IFIXX(1,1)
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SODCNT
C...DATA STATEMENTS
DATA
+ NEGONE,ZERO
+ /-1.0E0,0.0E0/
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.0E0.
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.0E0.
C WE: THE EPSILON WEIGHTS.
C WORK: THE REAL WORK SPACE.
C X: THE EXPLANATORY VARIABLE.
C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT.
C***FIRST EXECUTABLE STATEMENT SODR
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 SODCNT
+ (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 SODCNT
+ (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
*SODRC
SUBROUTINE SODRC
+ (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 SODRC
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 SINGLE 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 SODCNT
C***END PROLOGUE SODRC
C...SCALAR ARGUMENTS
REAL
+ 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
REAL
+ 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
REAL
+ NEGONE,ZERO
LOGICAL
+ SHORT
C...LOCAL ARRAYS
REAL
+ WD1(1,1,1)
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SODCNT
C...DATA STATEMENTS
DATA
+ NEGONE,ZERO
+ /-1.0E0,0.0E0/
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.0E0.
C WE: THE EPSILON WEIGHTS.
C WORK: THE REAL WORK SPACE.
C X: THE EXPLANATORY VARIABLE.
C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT.
C***FIRST EXECUTABLE STATEMENT SODRC
SHORT = .FALSE.
IF (WD(1,1,1).NE.ZERO) THEN
CALL SODCNT
+ (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 SODCNT
+ (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
*SACCES
SUBROUTINE SACCES
+ (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 SACCES
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SIWINF,SWINF
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE ACCESS OR STORE VALUES IN THE WORK ARRAYS
C***END PROLOGUE SACESS
C...SCALAR ARGUMENTS
REAL
+ 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
REAL
+ 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
+ SIWINF,SWINF
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 REAL 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 SACCES
C FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE
CALL SIWINF(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 REAL WORK SPACE
CALL SWINF(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
*SETAF
SUBROUTINE SETAF
+ (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 SETAF
C***REFER TO SODR,SODRC
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 SETAF
C...SCALAR ARGUMENTS
REAL
+ EPSMAC,ETA
INTEGER
+ ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW
C...ARRAY ARGUMENTS
REAL
+ 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
REAL
+ 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.0E0,0.1E0,0.2E0,0.5E0,1.0E0,2.0E0,1.0E2/
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.0E2.
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.0E0.
C P1: THE VALUE 0.1E0.
C P2: THE VALUE 0.2E0.
C P5: THE VALUE 0.5E0.
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.0E0.
C***FIRST EXECUTABLE STATEMENT SETAF
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
*SFCTR
SUBROUTINE SFCTR(OKSEMI,A,LDA,N,INFO)
C***BEGIN PROLOGUE SFCTR
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SDOT
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 SPOFA)
C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C *LINPACK USERS GUIDE*, SIAM, 1979.
C***END PROLOGUE SFCTR
C...SCALAR ARGUMENTS
INTEGER INFO,LDA,N
LOGICAL OKSEMI
C...ARRAY ARGUMENTS
REAL A(LDA,N)
C...LOCAL SCALARS
REAL XI,S,T,TEN,ZERO
INTEGER J,K
C...EXTERNAL FUNCTIONS
EXTERNAL SMPREC,SDOT
REAL SMPREC,SDOT
C...INTRINSIC FUNCTIONS
INTRINSIC SQRT
C...DATA STATEMENTS
DATA
+ ZERO,TEN
+ /0.0E0,10.0E0/
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.0E0.
C XI: A VALUE USED TO TEST FOR NON POSITIVE SEMIDEFINITENESS.
C ZERO: THE VALUE 0.0E0.
C***FIRST EXECUTABLE STATEMENT SFCTR
C SET RELATIVE TOLERANCE FOR DETECTING NON POSITIVE SEMIDEFINITENESS.
XI = -TEN*SMPREC()
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) - SDOT(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
*SFCTRW
SUBROUTINE SFCTRW
+ (N,M,NQ,NPP,
+ ISODR,
+ WE,LDWE,LD2WE,WD,LDWD,LD2WD,
+ WRK0,WRK4,
+ WE1,NNZW,INFO)
C***BEGIN PROLOGUE SFCTRW
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SFCTR
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 SFCTRW
C...SCALAR ARGUMENTS
INTEGER
+ INFO,LDWD,LDWE,LD2WD,LD2WE,
+ M,N,NNZW,NPP,NQ
LOGICAL
+ ISODR
C...ARRAY ARGUMENTS
REAL
+ WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),
+ WRK0(NQ,NQ),WRK4(M,M)
C...LOCAL SCALARS
REAL
+ ZERO
INTEGER
+ I,INF,J,J1,J2,L,L1,L2
LOGICAL
+ NOTZRO
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SFCTR
C...DATA STATEMENTS
DATA
+ ZERO
+ /0.0E0/
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.0E0.
C***FIRST EXECUTABLE STATEMENT SFCTRW
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 SFCTR(.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 SFCTR(.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 SFCTR(.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 SFCTR(.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
*SJACCD
SUBROUTINE SJACCD
+ (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 SJACCD
C***REFER TO SODR,SODRC
C***ROUTINES CALLED FCN,SHSTEP,SZERO
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 SJACCD
C...SCALAR ARGUMENTS
INTEGER
+ ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ
LOGICAL
+ ISODR
C...ARRAY ARGUMENTS
REAL
+ 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
REAL
+ BETAK,ONE,TYPJ,ZERO
INTEGER
+ I,J,K,L
LOGICAL
+ DOIT,SETZRO
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SZERO
C...EXTERNAL FUNCTIONS
REAL
+ SHSTEP
EXTERNAL
+ SHSTEP
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,MAX,SIGN,SQRT
C...DATA STATEMENTS
DATA
+ ZERO,ONE
+ /0.0E0,1.0E0/
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.0E0.
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.0E0.
C***FIRST EXECUTABLE STATEMENT SJACCD
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 SZERO(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*SHSTEP(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 SZERO(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*SHSTEP(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
*SJACFD
SUBROUTINE SJACFD
+ (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 SJACFD
C***REFER TO SODR,SODRC
C***ROUTINES CALLED FCN,SHSTEP,SZERO
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 SJACFD
C...SCALAR ARGUMENTS
INTEGER
+ ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ
LOGICAL
+ ISODR
C...ARRAY ARGUMENTS
REAL
+ 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
REAL
+ BETAK,ONE,TYPJ,ZERO
INTEGER
+ I,J,K,L
LOGICAL
+ DOIT,SETZRO
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SZERO
C...EXTERNAL FUNCTIONS
REAL
+ SHSTEP
EXTERNAL
+ SHSTEP
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,MAX,SIGN,SQRT
C...DATA STATEMENTS
DATA
+ ZERO,ONE
+ /0.0E0,1.0E0/
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.0E0.
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.0E0.
C***FIRST EXECUTABLE STATEMENT SJACFD
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 SZERO(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*SHSTEP(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 SZERO(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*SHSTEP(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
*SJCK
SUBROUTINE SJCK
+ (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 SJCK
C***REFER TO SODR,SODRC
C***ROUTINES CALLED FCN,SHSTEP,SJCKM
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 SJCK
C...SCALAR ARGUMENTS
REAL
+ EPSMAC,ETA
INTEGER
+ ISTOP,LDIFX,LDSTPD,LDTT,
+ M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL
LOGICAL
+ ISODR
C...ARRAY ARGUMENTS
REAL
+ 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
REAL
+ DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO
INTEGER
+ IDEVAL,J,LQ,MSGB1,MSGD1
LOGICAL
+ ISFIXD,ISWRTB
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SJCKM
C...EXTERNAL FUNCTIONS
REAL
+ SHSTEP
EXTERNAL
+ SHSTEP
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,INT,LOG10
C...DATA STATEMENTS
DATA
+ ZERO,P5,ONE
+ /0.0E0,0.5E0,1.0E0/
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 SETAF.
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.0E0.
C P5: THE VALUE 0.5E0.
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.0E0.
C***FIRST EXECUTABLE STATEMENT SJCK
C SET TOLERANCE FOR CHECKING DERIVATIVES
TOL = ETA**(0.25E0)
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 = SHSTEP(0,NETA,1,J,STPB,1)
HC0 = H0
C CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW
CALL SJCKM(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 = SHSTEP(0,NETA,NROW,J,STPD,LDSTPD)
HC0 = SHSTEP(1,NETA,NROW,J,STPD,LDSTPD)
C CHECK DERIVATIVE WRT THE J-TH COLUMN OF DELTA AT ROW NROW
CALL SJCKM(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
*SJCKC
SUBROUTINE SJCKC
+ (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 SJCKC
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SJCKF,SPVB,SPVD
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 SJCKC
C...SCALAR ARGUMENTS
REAL
+ 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
REAL
+ 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
REAL
+ CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SJCKF,SPVB,SPVD
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,SIGN
C...DATA STATEMENTS
DATA
+ P01,ONE,TWO,TEN
+ /0.01E0,1.0E0,2.0E0,10.0E0/
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.0E0.
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.01E0.
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.0E0.
C TOL: THE AGREEMENT TOLERANCE.
C TWO: THE VALUE 2.0E0.
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 SJCKC
IF (ISWRTB) THEN
C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT BETA
STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J)
CALL SPVB(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 SPVB(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 SPVD(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 SPVD(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 SJCKF(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 SPVB(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 SPVD(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
*SJCKF
SUBROUTINE SJCKF
+ (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 SJCKF
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SPVB,SPVD
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 SJCKF
C...SCALAR ARGUMENTS
REAL
+ 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
REAL
+ 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
REAL
+ HUNDRD,ONE,P1,STP,TWO
LOGICAL
+ LARGE
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SPVB,SPVD
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,SIGN
C...DATA STATEMENTS
DATA
+ P1,ONE,TWO,HUNDRD
+ /0.1E0,1.0E0,2.0E0,100.0E0/
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.0E0.
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.0E0.
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.1E0.
C STP0: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C TOL: THE AGREEMENT TOLERANCE.
C TWO: THE VALUE 2.0E0.
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 SJCKF
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 SPVB(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 SPVD(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
*SJCKM
SUBROUTINE SJCKM
+ (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 SJCKM
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SJCKC,SJCKZ,SPVB,SPVD
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 SJCKM
C...SCALAR ARGUMENTS
REAL
+ 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
REAL
+ 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
REAL
+ BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0,
+ TEN,THREE,TOL2,TWO,ZERO
INTEGER
+ I
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SJCKC,SJCKZ,SPVB,SPVD
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,MAX,SIGN,SQRT
C...DATA STATEMENTS
DATA
+ ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD
+ /0.0E0,0.01E0,0.1E0,1.0E0,2.0E0,3.0E0,1.0E1,1.0E2/
DATA
+ BIG,TOL2
+ /1.0E19,5.0E-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.0E0.
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.0E0.
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.01E0.
C P1: THE VALUE 0.1E0.
C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE.
C TEN: THE VALUE 10.0E0.
C THREE: THE VALUE 3.0E0.
C TWO: THE VALUE 2.0E0.
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.0E0.
C***FIRST EXECUTABLE STATEMENT SJCKM
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 SPVB(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 SPVD(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 SJCKZ(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 SJCKC(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
*SJCKZ
SUBROUTINE SJCKZ
+ (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 SJCKZ
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SPVB,SPVD
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 SJCKZ
C...SCALAR ARGUMENTS
REAL
+ 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
REAL
+ 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
REAL
+ CD,ONE,PVMSTP,THREE,TWO,ZERO
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SPVB,SPVD
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,MIN
C...DATA STATEMENTS
DATA
+ ZERO,ONE,TWO,THREE
+ /0.0E0,1.0E0,2.0E0,3.0E0/
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.0E0.
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.0E0.
C TWO: THE VALUE 2.0E0.
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.0E0.
C***FIRST EXECUTABLE STATEMENT SJCKZ
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 SPVB(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 SPVD(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
*SODCHK
SUBROUTINE SODCHK
+ (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 SODCHK
C***REFER TO SODR,SODRC
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 SODCHK
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
REAL
+ 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 SODCHK
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
*SODDRV
SUBROUTINE SODDRV
+ (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 SODDRV
C***REFER TO SODR,SODRC
C***ROUTINES CALLED FCN,SCOPY,SDOT,SETAF,SFCTRW,SFLAGS,
C SINIWK,SIWINF,SJCK,SNRM2,SODCHK,SODMN,
C SODPER,SPACK,SSETN,SUNPAC,SWGHT,SWINF,SXMY,SXPY
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 SODDRV
C...SCALAR ARGUMENTS
REAL
+ 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
REAL
+ 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
REAL
+ 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
REAL
+ SDOT,SNRM2
EXTERNAL
+ SDOT,SNRM2
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SCOPY,SETAF,SFCTRW,SFLAGS,SINIWK,SIWINF,SJCK,SODCHK,
+ SODMN,SODPER,SPACK,SSETN,SUNPAC,SWGHT,SWINF,SXMY,SXPY
C...DATA STATEMENTS
DATA
+ ZERO,P5,ONE,TEN
+ /0.0E0,0.5E0,1.0E0,10.0E0/
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 SJCK.
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.0E0.
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.5E0.
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.0E0.
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 REAL 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.0E0.
C***FIRST EXECUTABLE STATEMENT SODDRV
C INITIALIZE NECESSARY VARIABLES
CALL SFLAGS(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 SIWINF)
CALL SIWINF(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 REAL WORK SPACE
C (INVALID VALUES OF N, M, NP, NQ, LDWE AND/OR LD2WE
C ARE HANDLED REASONABLY BY SWINF)
CALL SWINF(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 SCOPY(N*NQ,WORK(FNI),1,WORK(FI),1)
ELSE
CALL SXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N)
END IF
CALL SWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N)
WORK(WSSEPI) = SDOT(N*NQ,WORK(FI),1,WORK(FI),1)
WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI)
ELSE
C PERFORM ERROR CHECKING
INFO = 0
CALL SODCHK(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 SINIWK(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 SPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB)
CALL SPACK(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 SFCTRW(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 SUNPAC(NP,WORK(BETACI),BETA,IFIXB)
CALL SXPY(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 SCOPY(N*NQ,WORK(FNI),1,WORK(FI),1)
ELSE
CALL SXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N)
END IF
CALL SWGHT(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 SWGHT(NPP,1,WORK(SSI),NPP,1,WORK(BETACI),NPP,
+ WORK(WRK),NPP)
IF (ISODR) THEN
CALL SWGHT(N,M,WORK(TTI),IWORK(LDTTI),1,WORK(DELTAI),N,
+ WORK(WRK+NPP),N)
WORK(PNORMI) = SNRM2(NPP+N*M,WORK(WRK),1)
ELSE
WORK(PNORMI) = SNRM2(NPP,WORK(WRK),1)
END IF
C COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS
WORK(WSSEPI) = SDOT(N*NQ,WORK(FI),1,WORK(FI),1)
IF (ISODR) THEN
CALL SWGHT(N,M,WD,LDWD,LD2WD,WORK(DELTAI),N,WORK(WRK),N)
WORK(WSSDEI) = SDOT(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 SSETN(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 SETAF(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 SJCK(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 SODPER
+ (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 SCOPY(NP,BETA,1,WORK(BETA0I),1)
C FIND LEAST SQUARES SOLUTION
CALL SCOPY(N*NQ,WORK(FNI),1,WORK(FSI),1)
LDTT = IWORK(LDTTI)
CALL SODMN(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
*SODLM
SUBROUTINE SODLM
+ (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 SODLM
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SDOT,SNRM2,SODSTP,SSCALE,SWGHT
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 SODLM
C...SCALAR ARGUMENTS
REAL
+ ALPHA2,EPSFCN,RCOND,TAU
INTEGER
+ IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ
LOGICAL
+ ISODR
C...ARRAY ARGUMENTS
REAL
+ 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
REAL
+ ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO
INTEGER
+ I,IWRK,J,K,L
LOGICAL
+ FORVCV
C...EXTERNAL FUNCTIONS
REAL
+ SDOT,SNRM2
EXTERNAL
+ SDOT,SNRM2
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SODSTP,SSCALE,SWGHT
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,MAX,MIN,SQRT
C...DATA STATEMENTS
DATA
+ ZERO,P001,P1
+ /0.0E0,0.001E0,0.1E0/
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 SODSTP.
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.001E0
C P1: THE VALUE 0.1E0
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.0E0.
C***FIRST EXECUTABLE STATEMENT SODLM
FORVCV = .FALSE.
ISTOPC = 0
C COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0)
ALPHA1 = ZERO
CALL SODSTP(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) = SDOT(N*NQ,TFJACB(1,1,K),1,F(1,1),1)
30 CONTINUE
CALL SSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP)
IF (ISODR) THEN
CALL SWGHT(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) +
+ SDOT(NQ,FJACD(I,J,1),N*M,F(I,1),N)
40 CONTINUE
50 CONTINUE
CALL SSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N)
TOP = SNRM2(NPP+N*M,WRK,1)/TAU
ELSE
TOP = SNRM2(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 SODSTP(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
*SODMN
SUBROUTINE SODMN
+ (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 SODMN
C***REFER TO SODR,SODRC
C***ROUTINES CALLED FCN,SACCES,SCOPY,SDOT,SEVJAC,SFLAGS,SNRM2,SODLM,
C SODPCR,SODVCV,SUNPAC,SWGHT,SXMY,SXPY
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE ITERATIVELY COMPUTE LEAST SQUARES SOLUTION
C***END PROLOGUE SODMN
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
REAL
+ 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
REAL
+ 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
REAL
+ WSS(3)
C...EXTERNAL FUNCTIONS
REAL
+ SDOT,SNRM2
EXTERNAL
+ SDOT,SNRM2
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SACCES,SCOPY,SEVJAC,SFLAGS,
+ SODLM,SODPCR,SODVCV,SUNPAC,SWGHT,SXMY,SXPY
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,MIN,MOD,SQRT
C...DATA STATEMENTS
DATA
+ ZERO,P0001,P1,P25,P5,P75,ONE
+ /0.0E0,0.00010E0,0.10E0,0.250E0,
+ 0.50E0,0.750E0,1.0E0/
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 SODSTP.
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.0E0.
C P0001: THE VALUE 0.0001E0.
C P1: THE VALUE 0.1E0.
C P25: THE VALUE 0.25E0.
C P5: THE VALUE 0.5E0.
C P75: THE VALUE 0.75E0.
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 REAL 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.0E0.
C***FIRST EXECUTABLE STATEMENT SODMN
C INITIALIZE NECESSARY VARIABLES
CALL SFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
+ ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
ACCESS = .TRUE.
CALL SACCES(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 SODPCR(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 SEVJAC(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 SODLM(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 SXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP)
IF (ISODR) CALL SXPY(N,M,DELTA,N,T,N,DELTAN,N)
C COMPUTE NORM OF SCALED STEPS S AND T (TSNORM)
CALL SWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP)
IF (ISODR) THEN
CALL SWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N)
TSNORM = SNRM2(NPP+N*M,WRK,1)
ELSE
TSNORM = SNRM2(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) = SDOT(NPP,FJACB(I,1,L),N,S,1)
IF (ISODR) WRK(IWRK) = WRK(IWRK) +
+ SDOT(M,FJACD(I,1,L),N,T(I,1),N)
120 CONTINUE
130 CONTINUE
IF (ISODR) THEN
CALL SWGHT(N,M,WD,LDWD,LD2WD,T,N,WRK(N*NQ+1),N)
TEMP1 = SDOT(N*NQ,WRK,1,WRK,1) + SDOT(N*M,T,1,WRK(N*NQ+1),1)
TEMP1 = SQRT(TEMP1)/RNORM
ELSE
TEMP1 = SNRM2(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 SUNPAC(NP,BETAN,BETA,IFIXB)
CALL SXPY(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 SCOPY(N*NQ,FN,1,WRK,1)
ELSE
CALL SXMY(N,NQ,FN,N,Y,LDY,WRK,N)
END IF
CALL SWGHT(N,NQ,WE1,LDWE,LD2WE,WRK,N,WRK,N)
IF (ISODR) THEN
CALL SWGHT(N,M,WD,LDWD,LD2WD,DELTAN,N,WRK(N*NQ+1),N)
RNORMN = SQRT(SDOT(N*NQ,WRK,1,WRK,1) +
+ SDOT(N*M,DELTAN,1,WRK(N*NQ+1),1))
ELSE
RNORMN = SNRM2(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 SCOPY(NPP,BETAS,1,BETAN,1)
CALL SCOPY(N*M,DELTAS,1,DELTAN,1)
CALL SCOPY(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 SCOPY(NPP,BETAN,1,BETAS,1)
CALL SCOPY(N*M,DELTAN,1,DELTAS,1)
CALL SCOPY(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 SCOPY(N*NQ,FN,1,FS,1)
IF (IMPLCT) THEN
CALL SCOPY(N*NQ,FS,1,F,1)
ELSE
CALL SXMY(N,NQ,FS,N,Y,LDY,F,N)
END IF
CALL SWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,F,N)
CALL SCOPY(NPP,BETAN,1,BETAC,1)
CALL SCOPY(N*M,DELTAN,1,DELTA,1)
RNORM = RNORMN
CALL SWGHT(NPP,1,SS,NPP,1,BETAC,NPP,WRK,NPP)
IF (ISODR) THEN
CALL SWGHT(N,M,TT,LDTT,1,DELTA,N,WRK(NPP+1),N)
PNORM = SNRM2(NPP+N*M,WRK,1)
ELSE
PNORM = SNRM2(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 SUNPAC(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 SODPCR(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 SCOPY(N*NQ,FS,1,F,1)
ELSE
CALL SXMY(N,NQ,FS,N,Y,LDY,F,N)
END IF
CALL SUNPAC(NP,BETAC,BETA,IFIXB)
CALL SXPY(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 SEVJAC(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 SWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
RSS = SDOT(N*M,DELTA,1,WRK(N*NQ+1),1)
ELSE
RSS = RNORM*RNORM
END IF
IF (REDOJ .OR. NITER.GE.1) THEN
CALL SODVCV(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 SWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,WRK,N)
WSS(3) = SDOT(N*NQ,WRK,1,WRK,1)
IF (ISODR) THEN
CALL SWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
WSS(2) = SDOT(N*M,DELTA,1,WRK(N*NQ+1),1)
ELSE
WSS(2) = ZERO
END IF
WSS(1) = WSS(2) + WSS(3)
ACCESS = .FALSE.
CALL SACCES(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 SODPCR(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
*SODPC1
SUBROUTINE SODPC1
+ (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 SODPC1
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SHSTEP
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE GENERATE INITIAL SUMMARY REPORT
C***END PROLOGUE SODPC1
C...SCALAR ARGUMENTS
REAL
+ 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
REAL
+ 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
REAL
+ 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
REAL
+ SHSTEP
EXTERNAL
+ SHSTEP
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,MIN
C...DATA STATEMENTS
DATA
+ ZERO
+ /0.0E0/
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 REAL VALUE.
C TEMP2: A TEMPORARY REAL VALUE.
C TEMP3: A TEMPORARY REAL 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.0E0.
C***FIRST EXECUTABLE STATEMENT SODPC1
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 = SHSTEP(1,NETA,1,J,STPB,1)
ELSE
TEMP2 = SHSTEP(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 = SHSTEP(1,NETA,I,J,STPD,LDSTPD)
ELSE
TEMP3 = SHSTEP(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,E12.2,
+ ' (SUM OF SQUARES STOPPING TOLERANCE)'/
+ ' PARTOL = ',1P,E12.2,
+ ' (PARAMETER STOPPING TOLERANCE)'/
+ ' MAXIT = ',I5,
+ ' (MAXIMUM NUMBER OF ITERATIONS)')
1500 FORMAT
+ (/' --- INITIAL SUM OF SQUARED WEIGHTED DELTAS =',
+ 17X,1P,E17.8)
1510 FORMAT
+ ( ' INITIAL PENALTY FUNCTION VALUE =',1P,E17.8/
+ ' PENALTY TERM =',1P,E17.8/
+ ' PENALTY PARAMETER =',1P,E10.1)
1600 FORMAT
+ (/' --- INITIAL WEIGHTED SUM OF SQUARES =',
+ 17X,1P,E17.8)
1610 FORMAT
+ ( ' SUM OF SQUARED WEIGHTED DELTAS =',1P,E17.8/
+ ' SUM OF SQUARED WEIGHTED EPSILONS =',1P,E17.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,E16.8,4X,A5,E16.8,1X,A13)
4320 FORMAT
+ (7X,I5,1P,E16.8,4X,A5,E16.8,1X,E13.5)
5110 FORMAT
+ (9X,A2,I1,1P,2E12.3,4X,A5,2E10.2,1X,A13)
5120 FORMAT
+ (8X,A2,I2,1P,2E12.3,4X,A5,2E10.2,1X,A13)
5210 FORMAT
+ (9X,A2,I1,1P,2E12.3,4X,A5,2E10.2,1X,E13.5)
5220 FORMAT
+ (8X,A2,I2,1P,2E12.3,4X,A5,2E10.2,1X,E13.5)
6000 FORMAT
+ (' ')
END
*SODPC3
SUBROUTINE SODPC3
+ (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 SODPC3
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SPPT
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE GENERATE FINAL SUMMARY REPORT
C***END PROLOGUE SODPC3
C...SCALAR ARGUMENTS
REAL
+ 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
REAL
+ BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP)
INTEGER
+ IFIXB2(NP)
C...LOCAL SCALARS
REAL
+ TVAL
INTEGER
+ D1,D2,D3,D4,D5,I,J,K,L,NPLM1
CHARACTER FMT1*90
C...EXTERNAL FUNCTIONS
REAL
+ SPPT
EXTERNAL
+ SPPT
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 SODPC3
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 = SPPT(0.975E0,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,E12.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,E17.8)
2010 FORMAT
+ ( ' FINAL PENALTY FUNCTION VALUE = ',1P,E17.8/
+ ' PENALTY TERM = ',1P,E17.8/
+ ' PENALTY PARAMETER = ',1P,E10.1)
2100 FORMAT
+ (/' --- FINAL WEIGHTED SUMS OF SQUARES = ',17X,1P,E17.8)
2110 FORMAT
+ ( ' SUM OF SQUARED WEIGHTED DELTAS = ',1P,E17.8/
+ ' SUM OF SQUARED WEIGHTED EPSILONS = ',1P,E17.8)
2200 FORMAT
+ (/' --- RESIDUAL STANDARD DEVIATION = ',
+ 17X,1P,E17.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,5E16.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,E16.8)
8200 FORMAT
+ (3X,I5,' TO',I5,1P,7E16.8)
8400 FORMAT
+ (3X,I5,1X,1P,E16.8,3X,E12.4,3X,E16.8,1X,'TO',E16.8)
8500 FORMAT
+ (3X,I5,1X,1P,E16.8,6X,'ESTIMATED')
8600 FORMAT
+ (3X,I5,1X,1P,E16.8,6X,' FIXED')
8700 FORMAT
+ (3X,I5,1X,1P,E16.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
*SODPCR
SUBROUTINE SODPCR
+ (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 SODPCR
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SFLAGS,SODPC1,SODPC2,SODPC3,SODPHD
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE GENERATE COMPUTATION REPORTS
C***END PROLOGUE SODPCR
C...SCALAR ARGUMENTS
REAL
+ 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
REAL
+ 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
REAL
+ PNLTY
LOGICAL
+ ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT
CHARACTER TYP*3
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SFLAGS,SODPC1,SODPC2,SODPC3,SODPHD
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 SODPCR
CALL SFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
+ ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
PNLTY = ABS(WE(1,1,1))
IF (HEAD) THEN
CALL SODPHD(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 SODPC1
+ (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 SODPC2
+ (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 SODPC3
+ (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
*SODPE1
SUBROUTINE SODPE1
+ (UNIT,D1,D2,D3,D4,D5,
+ N,M,NQ,
+ LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD,
+ LWKMN,LIWKMN)
C***BEGIN PROLOGUE SODPE1
C***REFER TO SODR,SODRC
C***ROUTINES CALLED (NONE)
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE PRINT ERROR REPORTS
C***END PROLOGUE SODPE1
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 SODPE1
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
*SODPE2
SUBROUTINE SODPE2
+ (UNIT,
+ N,M,NP,NQ,
+ FJACB,FJACD,
+ DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD,
+ XPLUSD,NROW,NETA,NTOL)
C***BEGIN PROLOGUE SODPE2
C***REFER TO SODR,SODRC
C***ROUTINES CALLED (NONE)
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE GENERATE THE DERIVATIVE CHECKING REPORT
C***END PROLOGUE SODPE2
C...SCALAR ARGUMENTS
INTEGER
+ M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT
LOGICAL
+ ISODR
C...ARRAY ARGUMENTS
REAL
+ 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 SODPE2
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,2E13.2,3X,A1,
+ 'VERIFIED')
3300 FORMAT (' BETA(',I3,')', 1P,2E13.2,3X,A1,
+ 'QUESTIONABLE (SEE NOTE ',I1,')')
4100 FORMAT (' DELTA(',I2,',',I2,')', ' --- ',
+ ' --- ',' UNCHECKED')
4200 FORMAT (' DELTA(',I2,',',I2,')', 1P,2E13.2,3X,A1,
+ 'VERIFIED')
4300 FORMAT (' DELTA(',I2,',',I2,')', 1P,2E13.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,3E16.8)
END
*SODPE3
SUBROUTINE SODPE3
+ (UNIT,D2,D3)
C***BEGIN PROLOGUE SODPE3
C***REFER TO SODR,SODRC
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 SODPE3
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 SODPE3
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
*SODPER
SUBROUTINE SODPER
+ (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 SODPER
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SODPE1,SODPE2,SODPE3,SODPHD
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS
C***END PROLOGUE SODPER
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
REAL
+ 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
+ SODPE1,SODPE2,SODPE3,SODPHD
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 SODPER
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 SODPHD(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 SODPE1(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 SODPE2(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 SODPE3(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 SODR'/
+ ' + (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 SODRC'/
+ ' + (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
*SODSTP
SUBROUTINE SODSTP
+ (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 SODSTP
C***REFER TO SODR,SODRC
C***ROUTINES CALLED ISAMAX,SCHEX,SESUBI,SFCTR,SNRM2,SQRDC,SQRSL,SROT,
C SROTG,SSOLVE,STRCO,STRSL,SVEVTR,SWGHT,SZERO
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 SODSTP
C...SCALAR ARGUMENTS
REAL
+ ALPHA,EPSFCN,PHI,RCOND
INTEGER
+ IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ
LOGICAL
+ ISODR
C...ARRAY ARGUMENTS
REAL
+ 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
REAL
+ CO,ONE,SI,TEMP,ZERO
INTEGER
+ I,IMAX,INF,IPVT,J,K,K1,K2,KP,L
LOGICAL
+ ELIM,FORVCV
C...LOCAL ARRAYS
REAL
+ DUM(2)
C...EXTERNAL FUNCTIONS
REAL
+ SNRM2
INTEGER
+ ISAMAX
EXTERNAL
+ SNRM2,ISAMAX
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SCHEX,SESUBI,SFCTR,SQRDC,SQRSL,SROT,SROTG,
+ SSOLVE,STRCO,STRSL,SVEVTR,SWGHT,SZERO
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,SQRT
C...DATA STATEMENTS
DATA
+ ZERO,ONE
+ /0.0E0,1.0E0/
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 SODSTP.
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.0E0.
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.0E0.
C***FIRST EXECUTABLE STATEMENT SODSTP
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 SWGHT(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 SESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4)
CALL SFCTR(.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 SVEVTR(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 SFCTR(.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 SSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,4)
CALL SSOLVE(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 SSOLVE(M,WRK4,M,WRK5,1,4)
CALL SSOLVE(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 SSOLVE(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 SSOLVE(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 SQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT)
CALL SQRSL(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 SZERO(NPP,1,S,NPP)
DO 430 K1=1,KP
CALL SZERO(KP,1,WRK3,KP)
WRK3(K1) = SQRT(ALPHA)
DO 420 K2=K1,KP
CALL SROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI)
IF (KP-K2.GE.1) THEN
CALL SROT(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 STRCO(TFJACB,N*NQ,KP,RCOND,U,1)
IF (RCOND.LE.EPSFCN) THEN
ELIM = .TRUE.
IMAX = ISAMAX(KP,U,1)
C IMAX IS THE COLUMN TO REMOVE - USE SCHEX AND FIX KPVT
IF (IMAX.NE.KP) THEN
CALL SCHEX(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 STRSL(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 SESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4)
CALL SFCTR(.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 SSOLVE(M,WRK4,M,WRK5,1,4)
CALL SSOLVE(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 SSOLVE(M,WRK4,M,T(I,1),N,4)
CALL SSOLVE(M,WRK4,M,T(I,1),N,2)
670 CONTINUE
END IF
C COMPUTE PHI(ALPHA) FROM SCALED S AND T
CALL SWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP)
IF (ISODR) THEN
CALL SWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N)
PHI = SNRM2(NPP+N*M,WRK,1)
ELSE
PHI = SNRM2(NPP,WRK,1)
END IF
RETURN
END
*SODVCV
SUBROUTINE SODVCV
+ (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 SODVCV
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SPODI,SODSTP
C***DATE WRITTEN 901207 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
C***END PROLOGUE SODVCV
C...SCALAR ARGUMENTS
REAL
+ EPSFCN,RCOND,RSS,RVAR
INTEGER
+ IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ
LOGICAL
+ ISODR
C...ARRAY ARGUMENTS
REAL
+ 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
REAL
+ TEMP,ZERO
INTEGER
+ I,IUNFIX,J,JUNFIX,KP,L
LOGICAL
+ FORVCV
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SPODI,SODSTP
C...INTRINSIC FUNCTIONS
INTRINSIC
+ ABS,SQRT
C...DATA STATEMENTS
DATA
+ ZERO
+ /0.0E0/
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 SODSTP 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 SODSTP.
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.0E0.
C***FIRST EXECUTABLE STATEMENT SODVCV
FORVCV = .TRUE.
ISTOPC = 0
CALL SODSTP(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 SPODI (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
*SSOLVE
SUBROUTINE SSOLVE(N,T,LDT,B,LDB,JOB)
C***BEGIN PROLOGUE SSOLVE
C***REFER TO SODR,SODRC
C***ROUTINES CALLED SAXPY,SDOT
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 STRSL)
C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W.,
C *LINPACK USERS GUIDE*, SIAM, 1979.
C***END PROLOGUE SSOLVE
C...SCALAR ARGUMENTS
INTEGER
+ JOB,LDB,LDT,N
C...ARRAY ARGUMENTS
REAL
+ B(LDB,N),T(LDT,N)
C...LOCAL SCALARS
REAL
+ TEMP,ZERO
INTEGER
+ J1,J,JN
C...EXTERNAL FUNCTIONS
REAL
+ SDOT
EXTERNAL
+ SDOT
C...EXTERNAL SUBROUTINES
EXTERNAL
+ SAXPY
C...DATA STATEMENTS
DATA
+ ZERO
+ /0.0E0/
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.0E0.
C***FIRST EXECUTABLE STATEMENT SSOLVE
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 SAXPY(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 SAXPY(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) - SDOT(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) - SDOT(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
*SWINF
SUBROUTINE SWINF
+ (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 SWINF
C***REFER TO SODR,SODRC
C***ROUTINES CALLED (NONE)
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE SET STORAGE LOCATIONS WITHIN REAL WORK SPACE
C***END PROLOGUE SWINF
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 SWINF
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
*SODPHD
SUBROUTINE SODPHD
+ (HEAD,UNIT)
C***BEGIN PROLOGUE SODPHD
C***REFER TO SODR,SODRC
C***ROUTINES CALLED (NONE)
C***DATE WRITTEN 860529 (YYMMDD)
C***REVISION DATE 920619 (YYMMDD)
C***PURPOSE PRINT ODRPACK HEADING
C***END PROLOGUE SODPHD
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 SODPHD
IF (HEAD) THEN
WRITE(UNIT,1000)
HEAD = .FALSE.
END IF
RETURN
C FORMAT STATEMENTS
1000 FORMAT (
+ ' ******************************************************* '/
+ ' * ODRPACK VERSION 2.01 OF 06-19-92 (SINGLE PRECISION) * '/
+ ' ******************************************************* '/)
END
.
