*DODR SUBROUTINE DODR + (FCN, + N,M,NP,NQ, + BETA, + Y,LDY,X,LDX, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + JOB, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) C***BEGIN PROLOGUE DODR C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C ROGERS, JANET E. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST C SQUARES (OLS) SOLUTION (SHORT CALL STATEMENT) C***DESCRIPTION C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1989), C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED C ORTHOGONAL DISTANCE REGRESSION," C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND C R. B. SCHNABEL (1992), C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C INTERNAL REPORT NUMBER 92-4834. C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR C ORTHOGONAL DISTANCE REGRESSION," C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. C***ROUTINES CALLED DODCNT C***END PROLOGUE DODR C...SCALAR ARGUMENTS INTEGER + INFO,JOB,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,LIWORK,LWORK, + M,N,NDIGIT,NP,NQ C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + X(LDX,M),Y(LDY,NQ) INTEGER + IWORK(LIWORK) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + NEGONE,PARTOL,SSTOL,TAUFAC,ZERO INTEGER + IPRINT,LDIFX,LDSCLD,LDSTPD,LUNERR,LUNRPT,MAXIT LOGICAL + SHORT C...LOCAL ARRAYS DOUBLE PRECISION + SCLB(1),SCLD(1,1),STPB(1),STPD(1,1),WD1(1,1,1) INTEGER + IFIXB(1),IFIXX(1,1) C...EXTERNAL SUBROUTINES EXTERNAL + DODCNT C...DATA STATEMENTS DATA + NEGONE,ZERO + /-1.0D0,0.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C IPRINT: THE PRINT CONTROL VARIABLE. C IWORK: THE INTEGER WORK SPACE. C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LDX: THE LEADING DIMENSION OF ARRAY X. C LDY: THE LEADING DIMENSION OF ARRAY Y. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C LIWORK: THE LENGTH OF VECTOR IWORK. C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. C LWORK: THE LENGTH OF VECTOR WORK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C N: THE NUMBER OF OBSERVATIONS. C NEGONE: THE VALUE -1.0D0. C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. C SCLB: THE SCALING VALUES FOR BETA. C SCLD: THE SCALING VALUES FOR DELTA. C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO BETA. C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO DELTA. C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL C (SHORT=.FALSE.). C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION C DIAMETER. C WD: THE DELTA WEIGHTS. C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. C WE: THE EPSILON WEIGHTS. C WORK: THE DOUBLE PRECISION WORK SPACE. C X: THE EXPLANATORY VARIABLE. C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. C***FIRST EXECUTABLE STATEMENT DODR C INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES IFIXB(1) = -1 IFIXX(1,1) = -1 LDIFX = 1 NDIGIT = -1 TAUFAC = NEGONE SSTOL = NEGONE PARTOL = NEGONE MAXIT = -1 STPB(1) = NEGONE STPD(1,1) = NEGONE LDSTPD = 1 SCLB(1) = NEGONE SCLD(1,1) = NEGONE LDSCLD = 1 SHORT = .TRUE. IF (WD(1,1,1).NE.ZERO) THEN CALL DODCNT + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + WORK,LWORK,IWORK,LIWORK, + INFO) ELSE WD1(1,1,1) = NEGONE CALL DODCNT + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + WORK,LWORK,IWORK,LIWORK, + INFO) END IF RETURN END *DODRC SUBROUTINE DODRC + (FCN, + N,M,NP,NQ, + BETA, + Y,LDY,X,LDX, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + IFIXB,IFIXX,LDIFX, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + STPB,STPD,LDSTPD, + SCLB,SCLD,LDSCLD, + WORK,LWORK,IWORK,LIWORK, + INFO) C***BEGIN PROLOGUE DODRC C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C ROGERS, JANET E. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST C SQUARES (OLS) SOLUTION (LONG CALL STATEMENT) C***DESCRIPTION C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1989), C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED C ORTHOGONAL DISTANCE REGRESSION," C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND C R. B. SCHNABEL (1992), C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C INTERNAL REPORT NUMBER 92-4834. C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR C ORTHOGONAL DISTANCE REGRESSION," C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. C***ROUTINES CALLED DODCNT C***END PROLOGUE DODRC C...SCALAR ARGUMENTS DOUBLE PRECISION + PARTOL,SSTOL,TAUFAC INTEGER + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + X(LDX,M),Y(LDY,NQ) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + NEGONE,ZERO LOGICAL + SHORT C...LOCAL ARRAYS DOUBLE PRECISION + WD1(1,1,1) C...EXTERNAL SUBROUTINES EXTERNAL + DODCNT C...DATA STATEMENTS DATA + NEGONE,ZERO + /-1.0D0,0.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C IPRINT: THE PRINT CONTROL VARIABLE. C IWORK: THE INTEGER WORK SPACE. C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LDX: THE LEADING DIMENSION OF ARRAY X. C LDY: THE LEADING DIMENSION OF ARRAY Y. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C LIWORK: THE LENGTH OF VECTOR IWORK. C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. C LWORK: THE LENGTH OF VECTOR WORK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C N: THE NUMBER OF OBSERVATIONS. C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. C SCLB: THE SCALING VALUES FOR BETA. C SCLD: THE SCALING VALUES FOR DELTA. C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO BETA. C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO DELTA. C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL C (SHORT=.FALSE.). C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION C DIAMETER. C WD: THE DELTA WEIGHTS. C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. C WE: THE EPSILON WEIGHTS. C WORK: THE DOUBLE PRECISION WORK SPACE. C X: THE EXPLANATORY VARIABLE. C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. C***FIRST EXECUTABLE STATEMENT DODRC SHORT = .FALSE. IF (WD(1,1,1).NE.ZERO) THEN CALL DODCNT + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + WORK,LWORK,IWORK,LIWORK, + INFO) ELSE WD1(1,1,1) = NEGONE CALL DODCNT + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + WORK,LWORK,IWORK,LIWORK, + INFO) END IF RETURN END *DACCES SUBROUTINE DACCES + (N,M,NP,NQ,LDWE,LD2WE, + WORK,LWORK,IWORK,LIWORK, + ACCESS,ISODR, + JPVT,OMEGA,U,QRAUX,SD,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + NNZW,NPP, + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + WSS,RVAR,IDF, + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) C***BEGIN PROLOGUE DACCES C***REFER TO DODR,DODRC C***ROUTINES CALLED DIWINF,DWINF C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE ACCESS OR STORE VALUES IN THE WORK ARRAYS C***END PROLOGUE DACESS C...SCALAR ARGUMENTS DOUBLE PRECISION + ACTRS,ALPHA,ETA,OLMAVG,PARTOL,PNORM,PRERS,RCOND, + RNORMS,RVAR,SSTOL,TAU,TAUFAC INTEGER + IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOP,ISTOPI,JOB,JPVT, + LDWE,LD2WE,LIWORK,LUNRPT,LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV, + NNZW,NP,NPP,NQ,OMEGA,QRAUX,SD,U,VCV, + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 LOGICAL + ACCESS,ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + WORK(LWORK),WSS(3) INTEGER + IWORK(LIWORK) C...LOCAL SCALARS INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I, + DELTAI,DELTNI,DELTSI,DIFFI,EPSI, + EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT, + IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI, + MSGB,MSGD,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI, + NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + WSSI,WSSDEI,WSSEPI,XPLUSI C...EXTERNAL SUBROUTINES EXTERNAL + DIWINF,DWINF C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN C THEM (ACCESS=FALSE). C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C IDFI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE IDF. C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS. C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. C IPR1: THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE INITIAL SUMMARY REPORT. C IPR2: THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE ITERATION REPORTS. C IPR2F: THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. C IPR3: THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FINAL SUMMARY REPORT. C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. C IPRINT: THE PRINT CONTROL VARIABLE. C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS TO BE C FOUND BY ODR (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. C IWORK: THE INTEGER WORK SPACE. C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. C JPVT: THE PIVOT VECTOR. C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE JPVT. C LDTTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE LDTT. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C LIWORK: THE LENGTH OF VECTOR IWORK. C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C LWORK: THE LENGTH OF VECTOR WORK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. C NITER: THE NUMBER OF ITERATIONS TAKEN. C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NPP: THE NUMBER OF FUNCTION PARAMETERS ACTUALLY ESTIMATED. C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER C ITERATION. C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. C OMEGA: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. C PRERS: THE SAVED PREDICTED RELATIVE REDUCTION IN THE C SUM-OF-SQUARES. C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C RNORMS: THE NORM OF THE SAVED WEIGHTED EPSILONS AND DELTAS. C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. C RVAR: THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. C SCLB: THE SCALING VALUES USED FOR BETA. C SCLD: THE SCALING VALUES USED FOR DELTA. C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG- C CALL (SHORT=FALSE). C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. C TAU: THE TRUST REGION DIAMETER. C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION C DIAMETER. C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. C WORK: THE DOUBLE PRECISION WORK SPACE. C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. C WSS: THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS, AND C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C WSSI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(1). C WSSDEI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(2). C WSSEPI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(3). C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. C***FIRST EXECUTABLE STATEMENT DACCES C FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE CALL DIWINF(M,NP,NQ, + MSGB,MSGD,JPVTI,ISTOPI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + PARTLI,SSTOLI,TAUFCI,EPSMAI, + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + FSI,FJACBI,WE1I,DIFFI, + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + LWKMN) IF (ACCESS) THEN C SET STARTING LOCATIONS FOR WORK VECTORS JPVT = JPVTI OMEGA = OMEGAI QRAUX = QRAUXI SD = SDI VCV = VCVI U = UI WRK1 = WRK1I WRK2 = WRK2I WRK3 = WRK3I WRK4 = WRK4I WRK5 = WRK5I WRK6 = WRK6I C ACCESS VALUES FROM THE WORK VECTORS ACTRS = WORK(ACTRSI) ALPHA = WORK(ALPHAI) ETA = WORK(ETAI) OLMAVG = WORK(OLMAVI) PARTOL = WORK(PARTLI) PNORM = WORK(PNORMI) PRERS = WORK(PRERSI) RCOND = WORK(RCONDI) WSS(1) = WORK(WSSI) WSS(2) = WORK(WSSDEI) WSS(3) = WORK(WSSEPI) RVAR = WORK(RVARI) RNORMS = WORK(RNORSI) SSTOL = WORK(SSTOLI) TAU = WORK(TAUI) TAUFAC = WORK(TAUFCI) NETA = IWORK(NETAI) IRANK = IWORK(IRANKI) JOB = IWORK(JOBI) LUNRPT = IWORK(LUNRPI) MAXIT = IWORK(MAXITI) NFEV = IWORK(NFEVI) NITER = IWORK(NITERI) NJEV = IWORK(NJEVI) NNZW = IWORK(NNZWI) NPP = IWORK(NPPI) IDF = IWORK(IDFI) INT2 = IWORK(INT2I) C SET UP PRINT CONTROL VARIABLES IPRINT = IWORK(IPRINI) IPR1 = MOD(IPRINT,10000)/1000 IPR2 = MOD(IPRINT,1000)/100 IPR2F = MOD(IPRINT,100)/10 IPR3 = MOD(IPRINT,10) ELSE C STORE VALUES INTO THE WORK VECTORS WORK(ACTRSI) = ACTRS WORK(ALPHAI) = ALPHA WORK(OLMAVI) = OLMAVG WORK(PARTLI) = PARTOL WORK(PNORMI) = PNORM WORK(PRERSI) = PRERS WORK(RCONDI) = RCOND WORK(WSSI) = WSS(1) WORK(WSSDEI) = WSS(2) WORK(WSSEPI) = WSS(3) WORK(RVARI) = RVAR WORK(RNORSI) = RNORMS WORK(SSTOLI) = SSTOL WORK(TAUI) = TAU IWORK(IRANKI) = IRANK IWORK(ISTOPI) = ISTOP IWORK(NFEVI) = NFEV IWORK(NITERI) = NITER IWORK(NJEVI) = NJEV IWORK(IDFI) = IDF IWORK(INT2I) = INT2 END IF RETURN END *DESUBI SUBROUTINE DESUBI + (N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,E) C***BEGIN PROLOGUE DESUBI C***REFER TO DODR,DODRC C***ROUTINES CALLED DZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE COMPUTE E = WD + ALPHA*TT**2 C***END PROLOGUE DESUBI C...SCALAR ARGUMENTS DOUBLE PRECISION + ALPHA INTEGER + LDTT,LDWD,LD2WD,M,N C...ARRAY ARGUMENTS DOUBLE PRECISION + E(M,M),TT(LDTT,M),WD(LDWD,LD2WD,M) C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + I,J,J1,J2 C...EXTERNAL SUBROUTINES EXTERNAL + DZERO C...DATA STATEMENTS DATA + ZERO + /0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. C E: THE VALUE OF THE ARRAY E = WD + ALPHA*TT**2 C I: AN INDEXING VARIABLE. C J: AN INDEXING VARIABLE. C J1: AN INDEXING VARIABLE. C J2: AN INDEXING VARIABLE. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NP: THE NUMBER OF RESPONSES PER OBSERVATION. C TT: THE SCALING VALUES USED FOR DELTA. C WD: THE SQUARED DELTA WEIGHTS, D**2. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DESUBI C N.B. THE LOCATIONS OF WD AND TT ACCESSED DEPEND ON THE VALUE C OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSIONS C OF THE MULTIPLY SUBSCRIPTED ARRAYS. IF (N.EQ.0 .OR. M.EQ.0) RETURN IF (WD(1,1,1).GE.ZERO) THEN IF (LDWD.GE.N) THEN C THE ELEMENTS OF WD HAVE BEEN INDIVIDUALLY SPECIFIED IF (LD2WD.EQ.1) THEN C THE ARRAYS STORED IN WD ARE DIAGONAL CALL DZERO(M,M,E,M) DO 10 J=1,M E(J,J) = WD(I,1,J) 10 CONTINUE ELSE C THE ARRAYS STORED IN WD ARE FULL POSITIVE SEMIDEFINITE MATRICES DO 30 J1=1,M DO 20 J2=1,M E(J1,J2) = WD(I,J1,J2) 20 CONTINUE 30 CONTINUE END IF IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 110 J=1,M E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 110 CONTINUE ELSE DO 120 J=1,M E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 120 CONTINUE END IF ELSE DO 130 J=1,M E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 130 CONTINUE END IF ELSE C WD IS AN M BY M MATRIX IF (LD2WD.EQ.1) THEN C THE ARRAY STORED IN WD IS DIAGONAL CALL DZERO(M,M,E,M) DO 140 J=1,M E(J,J) = WD(1,1,J) 140 CONTINUE ELSE C THE ARRAY STORED IN WD IS A FULL POSITIVE SEMIDEFINITE MATRICES DO 160 J1=1,M DO 150 J2=1,M E(J1,J2) = WD(1,J1,J2) 150 CONTINUE 160 CONTINUE END IF IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 210 J=1,M E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 210 CONTINUE ELSE DO 220 J=1,M E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 220 CONTINUE END IF ELSE DO 230 J=1,M E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 230 CONTINUE END IF END IF ELSE C WD IS A DIAGONAL MATRIX WITH ELEMENTS ABS(WD(1,1,1)) CALL DZERO(M,M,E,M) IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 310 J=1,M E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(I,J)**2 310 CONTINUE ELSE DO 320 J=1,M E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,J)**2 320 CONTINUE END IF ELSE DO 330 J=1,M E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,1)**2 330 CONTINUE END IF END IF RETURN END *DETAF SUBROUTINE DETAF + (FCN, + N,M,NP,NQ, + XPLUSD,BETA,EPSMAC,NROW, + PARTMP,PV0, + IFIXB,IFIXX,LDIFX, + ISTOP,NFEV,ETA,NETA, + WRK1,WRK2,WRK6,WRK7) C***BEGIN PROLOGUE DETAF C***REFER TO DODR,DODRC C***ROUTINES CALLED FCN C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS C (ADAPTED FROM STARPAC SUBROUTINE ETAFUN) C***END PROLOGUE DETAF C...SCALAR ARGUMENTS DOUBLE PRECISION + EPSMAC,ETA INTEGER + ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),PARTMP(NP),PV0(N,NQ), + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),WRK7(-2:2,NQ),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + A,B,FAC,HUNDRD,ONE,P1,P2,P5,STP,TWO,ZERO INTEGER + J,K,L C...INTRINSIC FUNCTIONS INTRINSIC + ABS,INT,LOG10,MAX,SQRT C...DATA STATEMENTS DATA + ZERO,P1,P2,P5,ONE,TWO,HUNDRD + /0.0D0,0.1D0,0.2D0,0.5D0,1.0D0,2.0D0,1.0D2/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C A: PARAMETERS OF THE LOCAL FIT. C B: PARAMETERS OF THE LOCAL FIT. C BETA: THE FUNCTION PARAMETERS. C EPSMAC: THE VALUE OF MACHINE PRECISION. C ETA: THE NOISE IN THE MODEL RESULTS. C FAC: A FACTOR USED IN THE COMPUTATIONS. C HUNDRD: THE VALUE 1.0D2. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C J: AN INDEX VARIABLE. C K: AN INDEX VARIABLE. C L: AN INDEX VARIABLE. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. C ONE: THE VALUE 1.0D0. C P1: THE VALUE 0.1D0. C P2: THE VALUE 0.2D0. C P5: THE VALUE 0.5D0. C PARTMP: THE MODEL PARAMETERS. C PV0: THE ORIGINAL PREDICTED VALUES. C STP: A SMALL VALUE USED TO PERTURB THE PARAMETERS. C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. C WRK7: A WORK ARRAY OF (5 BY NQ) ELEMENTS. C XPLUSD: THE VALUES OF X + DELTA. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DETAF STP = HUNDRD*EPSMAC ETA = EPSMAC DO 40 J=-2,2 IF (J.EQ.0) THEN DO 10 L=1,NQ WRK7(J,L) = PV0(NROW,L) 10 CONTINUE ELSE DO 20 K=1,NP IF (IFIXB(1).LT.0) THEN PARTMP(K) = BETA(K) + J*STP*BETA(K) ELSE IF (IFIXB(K).NE.0) THEN PARTMP(K) = BETA(K) + J*STP*BETA(K) ELSE PARTMP(K) = BETA(K) END IF 20 CONTINUE ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + PARTMP,XPLUSD, + IFIXB,IFIXX,LDIFX, + 003,WRK2,WRK6,WRK1,ISTOP) IF (ISTOP.NE.0) THEN RETURN ELSE NFEV = NFEV + 1 END IF DO 30 L=1,NQ WRK7(J,L) = WRK2(NROW,L) 30 CONTINUE END IF 40 CONTINUE DO 100 L=1,NQ A = ZERO B = ZERO DO 50 J=-2,2 A = A + WRK7(J,L) B = B + J*WRK7(J,L) 50 CONTINUE A = P2*A B = P1*B IF ((WRK7(0,L).NE.ZERO) .AND. + (ABS(WRK7(1,L)+WRK7(-1,L)).GT.HUNDRD*EPSMAC)) THEN FAC = ONE/ABS(WRK7(0,L)) ELSE FAC = ONE END IF DO 60 J=-2,2 WRK7(J,L) = ABS((WRK7(J,L)-(A+J*B))*FAC) ETA = MAX(WRK7(J,L),ETA) 60 CONTINUE 100 CONTINUE NETA = MAX(TWO,P5-LOG10(ETA)) RETURN END *DEVJAC SUBROUTINE DEVJAC + (FCN, + ANAJAC,CDJAC, + N,M,NP,NQ, + BETAC,BETA,STPB, + IFIXB,IFIXX,LDIFX, + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + SSF,TT,LDTT,NETA,FN, + STP,WRK1,WRK2,WRK3,WRK6, + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + NJEV,NFEV,ISTOP,INFO) C***BEGIN PROLOGUE DEVJAC C***REFER TO DODR,DODRC C***ROUTINES CALLED FCN,DDOT,DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA C***END PROLOGUE DEVJAC C...SCALAR ARGUMENTS INTEGER + INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDWE,LDX,LD2WE, + M,N,NETA,NFEV,NJEV,NP,NQ LOGICAL + ANAJAC,CDJAC,ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),BETAC(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + FN(N,NQ),SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + WE1(LDWE,LD2WE,NQ),WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP), + WRK6(N,NP,NQ),X(LDX,M),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS INTEGER + IDEVAL,J,K,K1,L DOUBLE PRECISION + ZERO LOGICAL + ERROR C...EXTERNAL SUBROUTINES EXTERNAL + DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT EXTERNAL + DDOT C...DATA STATEMENTS DATA ZERO + /0.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT C (ANAJAC=TRUE). C BETA: THE FUNCTION PARAMETERS. C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD C DIFFERENCES (CDJAC=FALSE). C DELTA: THE ESTIMATED VALUES OF DELTA. C ERROR: THE VARIABLE DESIGNATING WHETHER ODRPACK DETECTED NONZERO C VALUES IN ARRAY DELTA IN THE OLS CASE, AND THUS WHETHER C THE USER MAY HAVE OVERWRITTEN IMPORTANT INFORMATION C BY COMPUTING FJACD IN THE OLS CASE. C FJACB: THE JACOBIAN WITH RESPECT TO BETA. C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. C FN: THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT POINT. C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE C PERFORMED BY USER-SUPPLIED SUBROUTINE FCN. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF DELTA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C ISTOP: THE VARIABLE DESIGNATING THAT THE USER WISHES THE C COMPUTATIONS STOPPED. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR OLS (ISODR=FALSE). C J: AN INDEXING VARIABLE. C K: AN INDEXING VARIABLE. C K1: AN INDEXING VARIABLE. C L: AN INDEXING VARIABLE. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDWE: THE LEADING DIMENSION OF ARRAYS WE AND WE1. C LDX: THE LEADING DIMENSION OF ARRAY X. C LD2WE: THE SECOND DIMENSION OF ARRAYS WE AND WE1. C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C SSF: THE SCALE USED FOR THE BETA'S. C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO DELTA. C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO BETA. C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO DELTA. C TT: THE SCALING VALUES USED FOR DELTA. C WE1: THE SQUARE ROOTS OF THE EPSILON WEIGHTS IN ARRAY WE. C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK3: A WORK ARRAY OF (NP) ELEMENTS. C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. C X: THE INDEPENDENT VARIABLE. C XPLUSD: THE VALUES OF X + DELTA. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DEVJAC C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA CALL DUNPAC(NP,BETAC,BETA,IFIXB) C COMPUTE XPLUSD = X + DELTA CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND C THE JACOBIAN WRT DELTA (FJACD) ISTOP = 0 IF (ISODR) THEN IDEVAL = 110 ELSE IDEVAL = 010 END IF IF (ANAJAC) THEN CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + IDEVAL,WRK2,FJACB,FJACD, + ISTOP) IF (ISTOP.NE.0) THEN RETURN ELSE NJEV = NJEV+1 END IF C MAKE SURE FIXED ELEMENTS OF FJACD ARE ZERO IF (ISODR) THEN DO 10 L=1,NQ CALL DIFIX(N,M,IFIXX,LDIFX,FJACD(1,1,L),N,FJACD(1,1,L),N) 10 CONTINUE END IF ELSE IF (CDJAC) THEN CALL DJACCD(FCN, + N,M,NP,NQ, + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + STPB,STPD,LDSTPD, + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, + FJACB,ISODR,FJACD,NFEV,ISTOP) ELSE CALL DJACFD(FCN, + N,M,NP,NQ, + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + STPB,STPD,LDSTPD, + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + FJACB,ISODR,FJACD,NFEV,ISTOP) END IF IF (ISTOP.LT.0) THEN RETURN ELSE IF (.NOT.ISODR) THEN C TRY TO DETECT WHETHER THE USER HAS COMPUTED JFACD C WITHIN FCN IN THE OLS CASE ERROR = DDOT(N*M,DELTA,1,DELTA,1).NE.ZERO IF (ERROR) THEN INFO = 50300 RETURN END IF END IF C WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS IF (IFIXB(1).LT.0) THEN DO 20 K=1,NP CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + FJACB(1,K,1),N*NP,FJACB(1,K,1),N*NP) 20 CONTINUE ELSE K1 = 0 DO 30 K=1,NP IF (IFIXB(K).GE.1) THEN K1 = K1 + 1 CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + FJACB(1,K,1),N*NP,FJACB(1,K1,1),N*NP) END IF 30 CONTINUE END IF C WEIGHT THE JACOBIAN'S WRT DELTA AS APPROPRIATE IF (ISODR) THEN DO 40 J=1,M CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, + FJACD(1,J,1),N*M,FJACD(1,J,1),N*M) 40 CONTINUE END IF RETURN END *DFCTR SUBROUTINE DFCTR(OKSEMI,A,LDA,N,INFO) C***BEGIN PROLOGUE DFCTR C***REFER TO DODR,DODRC C***ROUTINES CALLED DDOT C***DATE WRITTEN 910706 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE FACTOR THE POSITIVE (SEMI)DEFINITE MATRIX A USING A C MODIFIED CHOLESKY FACTORIZATION C (ADAPTED FROM LINPACK SUBROUTINE DPOFA) C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***END PROLOGUE DFCTR C...SCALAR ARGUMENTS INTEGER INFO,LDA,N LOGICAL OKSEMI C...ARRAY ARGUMENTS DOUBLE PRECISION A(LDA,N) C...LOCAL SCALARS DOUBLE PRECISION XI,S,T,TEN,ZERO INTEGER J,K C...EXTERNAL FUNCTIONS EXTERNAL DMPREC,DDOT DOUBLE PRECISION DMPREC,DDOT C...INTRINSIC FUNCTIONS INTRINSIC SQRT C...DATA STATEMENTS DATA + ZERO,TEN + /0.0D0,10.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C A: THE ARRAY TO BE FACTORED. UPON RETURN, A CONTAINS THE C UPPER TRIANGULAR MATRIX R SO THAT A = TRANS(R)*R C WHERE THE STRICT LOWER TRIANGLE IS SET TO ZERO C IF INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE. C I: AN INDEXING VARIABLE. C INFO: AN IDICATOR VARIABLE, WHERE IF C INFO = 0 THEN FACTORIZATION WAS COMPLETED C INFO = K SIGNALS AN ERROR CONDITION. THE LEADING MINOR C OF ORDER K IS NOT POSITIVE (SEMI)DEFINITE. C J: AN INDEXING VARIABLE. C LDA: THE LEADING DIMENSION OF ARRAY A. C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY A. C OKSEMI: THE INDICATING WHETHER THE FACTORED ARRAY CAN BE POSITIVE C SEMIDEFINITE (OKSEMI=TRUE) OR WHETHER IT MUST BE FOUND TO C BE POSITIVE DEFINITE (OKSEMI=FALSE). C TEN: THE VALUE 10.0D0. C XI: A VALUE USED TO TEST FOR NON POSITIVE SEMIDEFINITENESS. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DFCTR C SET RELATIVE TOLERANCE FOR DETECTING NON POSITIVE SEMIDEFINITENESS. XI = -TEN*DMPREC() C COMPUTE FACTORIZATION, STORING IN UPPER TRIANGULAR PORTION OF A DO 20 J=1,N INFO = J S = ZERO DO 10 K=1,J-1 IF (A(K,K).EQ.ZERO) THEN T = ZERO ELSE T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1) T = T/A(K,K) END IF A(K,J) = T S = S + T*T 10 CONTINUE S = A(J,J) - S C ......EXIT IF (A(J,J).LT.ZERO .OR. S.LT.XI*ABS(A(J,J))) THEN RETURN ELSE IF (.NOT.OKSEMI .AND. S.LE.ZERO) THEN RETURN ELSE IF (S.LE.ZERO) THEN A(J,J) = ZERO ELSE A(J,J) = SQRT(S) END IF 20 CONTINUE INFO = 0 C ZERO OUT LOWER PORTION OF A DO 40 J=2,N DO 30 K=1,J-1 A(J,K) = ZERO 30 CONTINUE 40 CONTINUE RETURN END *DFCTRW SUBROUTINE DFCTRW + (N,M,NQ,NPP, + ISODR, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + WRK0,WRK4, + WE1,NNZW,INFO) C***BEGIN PROLOGUE DFCTRW C***REFER TO DODR,DODRC C***ROUTINES CALLED DFCTR C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING C NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE C ODRPACK REFERENCE GUIDE C***END PROLOGUE DFCTRW C...SCALAR ARGUMENTS INTEGER + INFO,LDWD,LDWE,LD2WD,LD2WE, + M,N,NNZW,NPP,NQ LOGICAL + ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M), + WRK0(NQ,NQ),WRK4(M,M) C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + I,INF,J,J1,J2,L,L1,L2 LOGICAL + NOTZRO C...EXTERNAL SUBROUTINES EXTERNAL + DFCTR C...DATA STATEMENTS DATA + ZERO + /0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C I: AN INDEXING VARIABLE. C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C J: AN INDEXING VARIABLE. C J1: AN INDEXING VARIABLE. C J2: AN INDEXING VARIABLE. C L: AN INDEXING VARIABLE. C L1: AN INDEXING VARIABLE. C L2: AN INDEXING VARIABLE. C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. C NOTZRO: THE VARIABLE DESIGNATING WHETHER A GIVEN COMPONENT OF THE C WEIGHT ARRAY WE CONTAINS A NONZERO ELEMENT (NOTZRO=FALSE) C OR NOT (NOTZRO=TRUE). C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. C WE: THE (SQUARED) EPSILON WEIGHTS. C WE1: THE FACTORED EPSILON WEIGHTS, S.T. TRANS(WE1)*WE1 = WE. C WD: THE (SQUARED) DELTA WEIGHTS. C WRK0: A WORK ARRAY OF (NQ BY NQ) ELEMENTS. C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DFCTRW C CHECK EPSILON WEIGHTS, AND STORE FACTORIZATION IN WE1 IF (WE(1,1,1).LT.ZERO) THEN C WE CONTAINS A SCALAR WE1(1,1,1) = -SQRT(ABS(WE(1,1,1))) NNZW = N ELSE NNZW = 0 IF (LDWE.EQ.1) THEN IF (LD2WE.EQ.1) THEN C WE CONTAINS A DIAGONAL MATRIX DO 110 L=1,NQ IF (WE(1,1,L).GT.ZERO) THEN NNZW = N WE1(1,1,L) = SQRT(WE(1,1,L)) ELSE IF (WE(1,1,L).LT.ZERO) THEN INFO = 30010 GO TO 300 END IF 110 CONTINUE ELSE C WE CONTAINS A FULL NQ BY NQ SEMIDEFINITE MATRIX DO 130 L1=1,NQ DO 120 L2=L1,NQ WRK0(L1,L2) = WE(1,L1,L2) 120 CONTINUE 130 CONTINUE CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) IF (INF.NE.0) THEN INFO = 30010 GO TO 300 ELSE DO 150 L1=1,NQ DO 140 L2=1,NQ WE1(1,L1,L2) = WRK0(L1,L2) 140 CONTINUE IF (WE1(1,L1,L1).NE.ZERO) THEN NNZW = N END IF 150 CONTINUE END IF END IF ELSE IF (LD2WE.EQ.1) THEN C WE CONTAINS AN ARRAY OF DIAGONAL MATRIX DO 220 I=1,N NOTZRO = .FALSE. DO 210 L=1,NQ IF (WE(I,1,L).GT.ZERO) THEN NOTZRO = .TRUE. WE1(I,1,L) = SQRT(WE(I,1,L)) ELSE IF (WE(I,1,L).LT.ZERO) THEN INFO = 30010 GO TO 300 END IF 210 CONTINUE IF (NOTZRO) THEN NNZW = NNZW + 1 END IF 220 CONTINUE ELSE C WE CONTAINS AN ARRAY OF FULL NQ BY NQ SEMIDEFINITE MATRICES DO 270 I=1,N DO 240 L1=1,NQ DO 230 L2=L1,NQ WRK0(L1,L2) = WE(I,L1,L2) 230 CONTINUE 240 CONTINUE CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) IF (INF.NE.0) THEN INFO = 30010 GO TO 300 ELSE NOTZRO = .FALSE. DO 260 L1=1,NQ DO 250 L2=1,NQ WE1(I,L1,L2) = WRK0(L1,L2) 250 CONTINUE IF (WE1(I,L1,L1).NE.ZERO) THEN NOTZRO = .TRUE. END IF 260 CONTINUE END IF IF (NOTZRO) THEN NNZW = NNZW + 1 END IF 270 CONTINUE END IF END IF END IF C CHECK FOR A SUFFICIENT NUMBER OF NONZERO EPSILON WEIGHTS IF (NNZW.LT.NPP) THEN INFO = 30020 END IF C CHECK DELTA WEIGHTS 300 CONTINUE IF (.NOT.ISODR .OR. WD(1,1,1).LT.ZERO) THEN C PROBLEM IS NOT ODR, OR WD CONTAINS A SCALAR RETURN ELSE IF (LDWD.EQ.1) THEN IF (LD2WD.EQ.1) THEN C WD CONTAINS A DIAGONAL MATRIX DO 310 J=1,M IF (WD(1,1,J).LE.ZERO) THEN INFO = MAX(30001,INFO+1) RETURN END IF 310 CONTINUE ELSE C WD CONTAINS A FULL M BY M POSITIVE DEFINITE MATRIX DO 330 J1=1,M DO 320 J2=J1,M WRK4(J1,J2) = WD(1,J1,J2) 320 CONTINUE 330 CONTINUE CALL DFCTR(.FALSE.,WRK4,M,M,INF) IF (INF.NE.0) THEN INFO = MAX(30001,INFO+1) RETURN END IF END IF ELSE IF (LD2WD.EQ.1) THEN C WD CONTAINS AN ARRAY OF DIAGONAL MATRICES DO 420 I=1,N DO 410 J=1,M IF (WD(I,1,J).LE.ZERO) THEN INFO = MAX(30001,INFO+1) RETURN END IF 410 CONTINUE 420 CONTINUE ELSE C WD CONTAINS AN ARRAY OF FULL M BY M POSITIVE DEFINITE MATRICES DO 470 I=1,N DO 440 J1=1,M DO 430 J2=J1,M WRK4(J1,J2) = WD(I,J1,J2) 430 CONTINUE 440 CONTINUE CALL DFCTR(.FALSE.,WRK4,M,M,INF) IF (INF.NE.0) THEN INFO = MAX(30001,INFO+1) RETURN END IF 470 CONTINUE END IF END IF END IF RETURN END *DFLAGS SUBROUTINE DFLAGS + (JOB,RESTRT,INITD,DOVCV,REDOJ,ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) C***BEGIN PROLOGUE DFLAGS C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB C***END PROLOGUE DFLAGS C...SCALAR ARGUMENTS INTEGER + JOB LOGICAL + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT C...LOCAL SCALARS INTEGER + J C...INTRINSIC FUNCTIONS INTRINSIC + MOD C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD C DIFFERENCES (CDJAC=FALSE). C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT C (CHKJAC=FALSE). C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED C TO ZERO (INITD=TRUE) OR TO THE FIRST N BY M ELEMENTS OF C ARRAY WORK (INITD=FALSE). C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C J: THE VALUE OF A SPECIFIC DIGIT OF JOB. C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C***FIRST EXECUTABLE STATEMENT DFLAGS IF (JOB.GE.0) THEN RESTRT= JOB.GE.10000 INITD = MOD(JOB,10000)/1000.EQ.0 J = MOD(JOB,1000)/100 IF (J.EQ.0) THEN DOVCV = .TRUE. REDOJ = .TRUE. ELSE IF (J.EQ.1) THEN DOVCV = .TRUE. REDOJ = .FALSE. ELSE DOVCV = .FALSE. REDOJ = .FALSE. END IF J = MOD(JOB,100)/10 IF (J.EQ.0) THEN ANAJAC = .FALSE. CDJAC = .FALSE. CHKJAC = .FALSE. ELSE IF (J.EQ.1) THEN ANAJAC = .FALSE. CDJAC = .TRUE. CHKJAC = .FALSE. ELSE IF (J.EQ.2) THEN ANAJAC = .TRUE. CDJAC = .FALSE. CHKJAC = .TRUE. ELSE ANAJAC = .TRUE. CDJAC = .FALSE. CHKJAC = .FALSE. END IF J = MOD(JOB,10) IF (J.EQ.0) THEN ISODR = .TRUE. IMPLCT = .FALSE. ELSE IF (J.EQ.1) THEN ISODR = .TRUE. IMPLCT = .TRUE. ELSE ISODR = .FALSE. IMPLCT = .FALSE. END IF ELSE RESTRT = .FALSE. INITD = .TRUE. DOVCV = .TRUE. REDOJ = .TRUE. ANAJAC = .FALSE. CDJAC = .FALSE. CHKJAC = .FALSE. ISODR = .TRUE. IMPLCT = .FALSE. END IF RETURN END *DHSTEP DOUBLE PRECISION FUNCTION DHSTEP + (ITYPE,NETA,I,J,STP,LDSTP) C***BEGIN PROLOGUE DHSTEP C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SET RELATIVE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES C***END PROLOGUE DHSTEP C...SCALAR ARGUMENTS INTEGER + I,ITYPE,J,LDSTP,NETA C...ARRAY ARGUMENTS DOUBLE PRECISION + STP(LDSTP,J) C...LOCAL SCALARS DOUBLE PRECISION + TEN,THREE,TWO,ZERO C...DATA STATEMENTS DATA + ZERO,TWO,THREE,TEN + /0.0D0,2.0D0,3.0D0,10.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C I: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. C ITYPE: THE FINITE DIFFERENCE METHOD BEING USED, WHERE C ITYPE = 0 INDICATES FORWARD FINITE DIFFERENCES, AND C ITYPE = 1 INDICATES CENTRAL FINITE DIFFERENCES. C J: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. C LDSTP: THE LEADING DIMENSION OF ARRAY STP. C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. C TEN: THE VALUE 10.0D0. C THREE: THE VALUE 3.0D0. C TWO: THE VALUE 2.0D0. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DHSTEP C SET DHSTEP TO RELATIVE FINITE DIFFERENCE STEP SIZE IF (STP(1,1).LE.ZERO) THEN IF (ITYPE.EQ.0) THEN C USE DEFAULT FORWARD FINITE DIFFERENCE STEP SIZE DHSTEP = TEN**(-ABS(NETA)/TWO - TWO) ELSE C USE DEFAULT CENTRAL FINITE DIFFERENCE STEP SIZE DHSTEP = TEN**(-ABS(NETA)/THREE) END IF ELSE IF (LDSTP.EQ.1) THEN DHSTEP = STP(1,J) ELSE DHSTEP = STP(I,J) END IF RETURN END *DIFIX SUBROUTINE DIFIX + (N,M,IFIX,LDIFIX,T,LDT,TFIX,LDTFIX) C***BEGIN PROLOGUE DIFIX C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 910612 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SET ELEMENTS OF T TO ZERO ACCORDING TO IFIX C***END PROLOGUE DIFIX C...SCALAR ARGUMENTS INTEGER + LDIFIX,LDT,LDTFIX,M,N C...ARRAY ARGUMENTS DOUBLE PRECISION + T(LDT,M),TFIX(LDTFIX,M) INTEGER + IFIX(LDIFIX,M) C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + I,J C...INTRINSIC FUNCTIONS INTRINSIC + ABS C...DATA STATEMENTS DATA + ZERO + /0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C I: AN INDEXING VARIABLE. C IFIX: THE ARRAY DESIGNATING WHETHER AN ELEMENT OF T IS TO BE C SET TO ZERO. C J: AN INDEXING VARIABLE. C LDT: THE LEADING DIMENSION OF ARRAY T. C LDIFIX: THE LEADING DIMENSION OF ARRAY IFIX. C LDTFIX: THE LEADING DIMENSION OF ARRAY TFIX. C M: THE NUMBER OF COLUMNS OF DATA IN THE ARRAY. C N: THE NUMBER OF ROWS OF DATA IN THE ARRAY. C T: THE ARRAY BEING SET TO ZERO ACCORDING TO THE ELEMENTS C OF IFIX. C TFIX: THE RESULTING ARRAY. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DIFIX IF (N.EQ.0 .OR. M.EQ.0) RETURN IF (IFIX(1,1).GE.ZERO) THEN IF (LDIFIX.GE.N) THEN DO 20 J=1,M DO 10 I=1,N IF (IFIX(I,J).EQ.0) THEN TFIX(I,J) = ZERO ELSE TFIX(I,J) = T(I,J) END IF 10 CONTINUE 20 CONTINUE ELSE DO 100 J=1,M IF (IFIX(1,J).EQ.0) THEN DO 30 I=1,N TFIX(I,J) = ZERO 30 CONTINUE ELSE DO 90 I=1,N TFIX(I,J) = T(I,J) 90 CONTINUE END IF 100 CONTINUE END IF END IF RETURN END *DINIWK SUBROUTINE DINIWK + (N,M,NP,WORK,LWORK,IWORK,LIWORK, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + BETA,SCLB, + SSTOL,PARTOL,MAXIT,TAUFAC, + JOB,IPRINT,LUNERR,LUNRPT, + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + JOBI,IPRINI,LUNERI,LUNRPI, + SSFI,TTI,LDTTI,DELTAI) C***BEGIN PROLOGUE DINIWK C***REFER TO DODR,DODRC C***ROUTINES CALLED DFLAGS,DMPREC,DSCLB,DSCLD,DZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE INITIALIZE WORK VECTORS AS NECESSARY C***END PROLOGUE DINIWK C...SCALAR ARGUMENTS DOUBLE PRECISION + PARTOL,SSTOL,TAUFAC INTEGER + DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX, + LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M, + MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M) INTEGER + IFIXX(LDIFX,M),IWORK(LIWORK) C...LOCAL SCALARS DOUBLE PRECISION + ONE,THREE,TWO,ZERO INTEGER + I,J LOGICAL + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DMPREC EXTERNAL + DMPREC C...EXTERNAL SUBROUTINES EXTERNAL + DCOPY,DFLAGS,DSCLB,DSCLD,DZERO C...INTRINSIC FUNCTIONS INTRINSIC + MIN,SQRT C...DATA STATEMENTS DATA + ZERO,ONE,TWO,THREE + /0.0D0,1.0D0,2.0D0,3.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT C (ANAJAC=TRUE). C BETA: THE FUNCTION PARAMETERS. C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD C DIFFERENCES (CDJAC=FALSE). C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT C (CHKJAC=FALSE). C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. C I: AN INDEXING VARIABLE. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED C AT THEIR INPUT VALUES OR NOT. C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=FALSE). C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. C IPRINT: THE PRINT CONTROL VARIABLE. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C IWORK: THE INTEGER WORK SPACE. C J: AN INDEXING VARIABLE. C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. C LDTTI: THE LEADING DIMENSION OF ARRAY TT. C LDX: THE LEADING DIMENSION OF ARRAY X. C LIWORK: THE LENGTH OF VECTOR IWORK. C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C LWORK: THE LENGTH OF VECTOR WORK. C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. C N: THE NUMBER OF OBSERVATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C ONE: THE VALUE 1.0D0. C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. C PARTOL: THE PARAMETER CONVERGENCE STOPPING CRITERIA. C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C SCLB: THE SCALING VALUES FOR BETA. C SCLD: THE SCALING VALUES FOR DELTA. C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION C DIAMETER. C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. C THREE: THE VALUE 3.0D0. C TTI: THE STARTING LOCATION IN ARRAY WORK OF THE ARRAY TT. C TWO: THE VALUE 2.0D0. C WORK: THE DOUBLE PRECISION WORK SPACE. C X: THE INDEPENDENT VARIABLE. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DINIWK CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) C STORE VALUE OF MACHINE PRECISION IN WORK VECTOR WORK(EPSMAI) = DMPREC() C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE C PARAMETERS (SEE ALSO SUBPROGRAM DODCNT) IF (PARTOL.LT.ZERO) THEN WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE) ELSE WORK(PARTLI) = MIN(PARTOL, ONE) END IF C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE C SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS IF (SSTOL.LT.ZERO) THEN WORK(SSTOLI) = SQRT(WORK(EPSMAI)) ELSE WORK(SSTOLI) = MIN(SSTOL, ONE) END IF C SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION IF (TAUFAC.LE.ZERO) THEN WORK(TAUFCI) = ONE ELSE WORK(TAUFCI) = MIN(TAUFAC, ONE) END IF C SET MAXIMUM NUMBER OF ITERATIONS IF (MAXIT.LT.0) THEN IWORK(MAXITI) = 50 ELSE IWORK(MAXITI) = MAXIT END IF C STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL C VARIABLE IF (JOB.LE.0) THEN IWORK(JOBI) = 0 ELSE IWORK(JOBI) = JOB END IF C SET PRINT CONTROL IF (IPRINT.LT.0) THEN IWORK(IPRINI) = 2001 ELSE IWORK(IPRINI) = IPRINT END IF C SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES IF (LUNERR.LT.0) THEN IWORK(LUNERI) = 6 ELSE IWORK(LUNERI) = LUNERR END IF C SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS IF (LUNRPT.LT.0) THEN IWORK(LUNRPI) = 6 ELSE IWORK(LUNRPI) = LUNRPT END IF C COMPUTE SCALING FOR BETA'S AND DELTA'S IF (SCLB(1).LE.ZERO) THEN CALL DSCLB(NP,BETA,WORK(SSFI)) ELSE CALL DCOPY(NP,SCLB,1,WORK(SSFI),1) END IF IF (ISODR) THEN IF (SCLD(1,1).LE.ZERO) THEN IWORK(LDTTI) = N CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI)) ELSE IF (LDSCLD.EQ.1) THEN IWORK(LDTTI) = 1 CALL DCOPY(M,SCLD(1,1),1,WORK(TTI),1) ELSE IWORK(LDTTI) = N DO 10 J=1,M CALL DCOPY(N,SCLD(1,J),1, + WORK(TTI+(J-1)*IWORK(LDTTI)),1) 10 CONTINUE END IF END IF END IF C INITIALIZE DELTA'S AS NECESSARY IF (ISODR) THEN IF (INITD) THEN CALL DZERO(N,M,WORK(DELTAI),N) ELSE IF (IFIXX(1,1).GE.0) THEN IF (LDIFX.EQ.1) THEN DO 20 J=1,M IF (IFIXX(1,J).EQ.0) THEN CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N) END IF 20 CONTINUE ELSE DO 40 J=1,M DO 30 I=1,N IF (IFIXX(I,J).EQ.0) THEN WORK(DELTAI-1+I+(J-1)*N) = ZERO END IF 30 CONTINUE 40 CONTINUE END IF END IF END IF ELSE CALL DZERO(N,M,WORK(DELTAI),N) END IF RETURN END *DIWINF SUBROUTINE DIWINF + (M,NP,NQ, + MSGBI,MSGDI,IFIX2I,ISTOPI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) C***BEGIN PROLOGUE DIWINF C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE C***END PROLOGUE DIWINF C...SCALAR ARGUMENTS INTEGER + IDFI,INT2I,IPRINI,IRANKI,ISTOPI,JOBI,IFIX2I,LDTTI,LIWKMN, + LUNERI,LUNRPI,M,MAXITI,MSGBI,MSGDI,NETAI,NFEVI,NITERI,NJEVI, + NNZWI,NP,NPPI,NQ,NROWI,NTOLI C...VARIABLE DEFINITIONS (ALPHABETICALLY) C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. C IFIX2I: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY IFIX2. C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. C MSGBI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. C MSGDI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABEL NITER. C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. C***FIRST EXECUTABLE STATEMENT DIWINF IF (NP.GE.1 .AND. M.GE.1) THEN MSGBI = 1 MSGDI = MSGBI + NQ*NP+1 IFIX2I = MSGDI + NQ*M+1 ISTOPI = IFIX2I + NP NNZWI = ISTOPI + 1 NPPI = NNZWI + 1 IDFI = NPPI + 1 JOBI = IDFI + 1 IPRINI = JOBI + 1 LUNERI = IPRINI + 1 LUNRPI = LUNERI + 1 NROWI = LUNRPI + 1 NTOLI = NROWI + 1 NETAI = NTOLI + 1 MAXITI = NETAI + 1 NITERI = MAXITI + 1 NFEVI = NITERI + 1 NJEVI = NFEVI + 1 INT2I = NJEVI + 1 IRANKI = INT2I + 1 LDTTI = IRANKI + 1 LIWKMN = LDTTI ELSE MSGBI = 1 MSGDI = 1 IFIX2I = 1 ISTOPI = 1 NNZWI = 1 NPPI = 1 IDFI = 1 JOBI = 1 IPRINI = 1 LUNERI = 1 LUNRPI = 1 NROWI = 1 NTOLI = 1 NETAI = 1 MAXITI = 1 NITERI = 1 NFEVI = 1 NJEVI = 1 INT2I = 1 IRANKI = 1 LDTTI = 1 LIWKMN = 1 END IF RETURN END *DJACCD SUBROUTINE DJACCD + (FCN, + N,M,NP,NQ, + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + STPB,STPD,LDSTPD, + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, + FJACB,ISODR,FJACD,NFEV,ISTOP) C***BEGIN PROLOGUE DJACCD C***REFER TO DODR,DODRC C***ROUTINES CALLED FCN,DHSTEP,DZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE COMPUTE CENTRAL DIFFERENCE APPROXIMATIONS TO THE C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS C***END PROLOGUE DJACCD C...SCALAR ARGUMENTS INTEGER + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ LOGICAL + ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + X(LDX,M),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + BETAK,ONE,TYPJ,ZERO INTEGER + I,J,K,L LOGICAL + DOIT,SETZRO C...EXTERNAL SUBROUTINES EXTERNAL + DZERO C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DHSTEP EXTERNAL + DHSTEP C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MAX,SIGN,SQRT C...DATA STATEMENTS DATA + ZERO,ONE + /0.0D0,1.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C BETAK: THE K-TH FUNCTION PARAMETER. C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A GIVEN C BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT C (DOIT=FALSE). C FJACB: THE JACOBIAN WITH RESPECT TO BETA. C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. C I: AN INDEXING VARIABLE. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED C AT THEIR INPUT VALUES OR NOT. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C J: AN INDEXING VARIABLE. C K: AN INDEXING VARIABLE. C L: AN INDEXING VARIABLE. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDX: THE LEADING DIMENSION OF ARRAY X. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C ONE: THE VALUE 1.0D0. C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT C (SETZRO=FALSE). C SSF: THE SCALING VALUES USED FOR BETA. C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO EACH DELTA. C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO EACH BETA. C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO EACH DELTA. C TT: THE SCALING VALUES USED FOR DELTA. C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C X: THE EXPLANATORY VARIABLE. C XPLUSD: THE VALUES OF X + DELTA. C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK3: A WORK ARRAY OF (NP) ELEMENTS. C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DJACCD C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS DO 60 K=1,NP IF (IFIXB(1).GE.0) THEN IF (IFIXB(K).EQ.0) THEN DOIT = .FALSE. ELSE DOIT = .TRUE. END IF ELSE DOIT = .TRUE. END IF IF (.NOT.DOIT) THEN DO 10 L=1,NQ CALL DZERO(N,1,FJACB(1,K,L),N) 10 CONTINUE ELSE BETAK = BETA(K) IF (BETAK.EQ.ZERO) THEN IF (SSF(1).LT.ZERO) THEN TYPJ = ONE/ABS(SSF(1)) ELSE TYPJ = ONE/SSF(K) END IF ELSE TYPJ = ABS(BETAK) END IF WRK3(K) = BETAK + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(1,NETA,1,K,STPB,1) WRK3(K) = WRK3(K) - BETAK BETA(K) = BETAK + WRK3(K) ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + 001,WRK2,WRK6,WRK1, + ISTOP) IF (ISTOP.NE.0) THEN RETURN ELSE NFEV = NFEV + 1 DO 30 L=1,NQ DO 20 I=1,N FJACB(I,K,L) = WRK2(I,L) 20 CONTINUE 30 CONTINUE END IF BETA(K) = BETAK - WRK3(K) ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + 001,WRK2,WRK6,WRK1, + ISTOP) IF (ISTOP.NE.0) THEN RETURN ELSE NFEV = NFEV + 1 END IF DO 50 L=1,NQ DO 40 I=1,N FJACB(I,K,L) = (FJACB(I,K,L)-WRK2(I,L))/(2*WRK3(K)) 40 CONTINUE 50 CONTINUE BETA(K) = BETAK END IF 60 CONTINUE C COMPUTE THE JACOBIAN WRT THE X'S IF (ISODR) THEN DO 220 J=1,M IF (IFIXX(1,1).LT.0) THEN DOIT = .TRUE. SETZRO = .FALSE. ELSE IF (LDIFX.EQ.1) THEN IF (IFIXX(1,J).EQ.0) THEN DOIT = .FALSE. ELSE DOIT = .TRUE. END IF SETZRO = .FALSE. ELSE DOIT = .FALSE. SETZRO = .FALSE. DO 100 I=1,N IF (IFIXX(I,J).NE.0) THEN DOIT = .TRUE. ELSE SETZRO = .TRUE. END IF 100 CONTINUE END IF IF (.NOT.DOIT) THEN DO 110 L=1,NQ CALL DZERO(N,1,FJACD(1,J,L),N) 110 CONTINUE ELSE DO 120 I=1,N IF (XPLUSD(I,J).EQ.ZERO) THEN IF (TT(1,1).LT.ZERO) THEN TYPJ = ONE/ABS(TT(1,1)) ELSE IF (LDTT.EQ.1) THEN TYPJ = ONE/TT(1,J) ELSE TYPJ = ONE/TT(I,J) END IF ELSE TYPJ = ABS(XPLUSD(I,J)) END IF STP(I) = XPLUSD(I,J) + + SIGN(ONE,XPLUSD(I,J)) + *TYPJ*DHSTEP(1,NETA,I,J,STPD,LDSTPD) STP(I) = STP(I) - XPLUSD(I,J) XPLUSD(I,J) = XPLUSD(I,J) + STP(I) 120 CONTINUE ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + 001,WRK2,WRK6,WRK1, + ISTOP) IF (ISTOP.NE.0) THEN RETURN ELSE NFEV = NFEV + 1 DO 140 L=1,NQ DO 130 I=1,N FJACD(I,J,L) = WRK2(I,L) 130 CONTINUE 140 CONTINUE END IF DO 150 I=1,N XPLUSD(I,J) = X(I,J) + DELTA(I,J) - STP(I) 150 CONTINUE ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + 001,WRK2,WRK6,WRK1, + ISTOP) IF (ISTOP.NE.0) THEN RETURN ELSE NFEV = NFEV + 1 END IF IF (SETZRO) THEN DO 180 I=1,N IF (IFIXX(I,J).EQ.0) THEN DO 160 L=1,NQ FJACD(I,J,L) = ZERO 160 CONTINUE ELSE DO 170 L=1,NQ FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + (2*STP(I)) 170 CONTINUE END IF 180 CONTINUE ELSE DO 200 L=1,NQ DO 190 I=1,N FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ + (2*STP(I)) 190 CONTINUE 200 CONTINUE END IF DO 210 I=1,N XPLUSD(I,J) = X(I,J) + DELTA(I,J) 210 CONTINUE END IF 220 CONTINUE END IF RETURN END *DJACFD SUBROUTINE DJACFD + (FCN, + N,M,NP,NQ, + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, + STPB,STPD,LDSTPD, + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, + FJACB,ISODR,FJACD,NFEV,ISTOP) C***BEGIN PROLOGUE DJACFD C***REFER TO DODR,DODRC C***ROUTINES CALLED FCN,DHSTEP,DZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE COMPUTE FORWARD DIFFERENCE APPROXIMATIONS TO THE C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS C***END PROLOGUE DJACFD C...SCALAR ARGUMENTS INTEGER + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ LOGICAL + ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ), + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), + X(LDX,M),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + BETAK,ONE,TYPJ,ZERO INTEGER + I,J,K,L LOGICAL + DOIT,SETZRO C...EXTERNAL SUBROUTINES EXTERNAL + DZERO C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DHSTEP EXTERNAL + DHSTEP C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MAX,SIGN,SQRT C...DATA STATEMENTS DATA + ZERO,ONE + /0.0D0,1.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C BETAK: THE K-TH FUNCTION PARAMETER. C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A C GIVEN BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) C OR NOT (DOIT=FALSE). C FJACB: THE JACOBIAN WITH RESPECT TO BETA. C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. C I: AN INDEXING VARIABLE. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C J: AN INDEXING VARIABLE. C K: AN INDEXING VARIABLE. C L: AN INDEXING VARIABLE. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDX: THE LEADING DIMENSION OF ARRAY X. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C ONE: THE VALUE 1.0D0. C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT C (SETZRO=FALSE). C SSF: THE SCALE USED FOR THE BETA'S. C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO DELTA. C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO BETA. C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO DELTA. C TT: THE SCALING VALUES USED FOR DELTA. C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C X: THE EXPLANATORY VARIABLE. C XPLUSD: THE VALUES OF X + DELTA. C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK3: A WORK ARRAY OF (NP) ELEMENTS. C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DJACFD C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS DO 40 K=1,NP IF (IFIXB(1).GE.0) THEN IF (IFIXB(K).EQ.0) THEN DOIT = .FALSE. ELSE DOIT = .TRUE. END IF ELSE DOIT = .TRUE. END IF IF (.NOT.DOIT) THEN DO 10 L=1,NQ CALL DZERO(N,1,FJACB(1,K,L),N) 10 CONTINUE ELSE BETAK = BETA(K) IF (BETAK.EQ.ZERO) THEN IF (SSF(1).LT.ZERO) THEN TYPJ = ONE/ABS(SSF(1)) ELSE TYPJ = ONE/SSF(K) END IF ELSE TYPJ = ABS(BETAK) END IF WRK3(K) = BETAK + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(0,NETA,1,K,STPB,1) WRK3(K) = WRK3(K) - BETAK BETA(K) = BETAK + WRK3(K) ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + 001,WRK2,WRK6,WRK1, + ISTOP) IF (ISTOP.NE.0) THEN RETURN ELSE NFEV = NFEV + 1 END IF DO 30 L=1,NQ DO 20 I=1,N FJACB(I,K,L) = (WRK2(I,L)-FN(I,L))/WRK3(K) 20 CONTINUE 30 CONTINUE BETA(K) = BETAK END IF 40 CONTINUE C COMPUTE THE JACOBIAN WRT THE X'S IF (ISODR) THEN DO 220 J=1,M IF (IFIXX(1,1).LT.0) THEN DOIT = .TRUE. SETZRO = .FALSE. ELSE IF (LDIFX.EQ.1) THEN IF (IFIXX(1,J).EQ.0) THEN DOIT = .FALSE. ELSE DOIT = .TRUE. END IF SETZRO = .FALSE. ELSE DOIT = .FALSE. SETZRO = .FALSE. DO 100 I=1,N IF (IFIXX(I,J).NE.0) THEN DOIT = .TRUE. ELSE SETZRO = .TRUE. END IF 100 CONTINUE END IF IF (.NOT.DOIT) THEN DO 110 L=1,NQ CALL DZERO(N,1,FJACD(1,J,L),N) 110 CONTINUE ELSE DO 120 I=1,N IF (XPLUSD(I,J).EQ.ZERO) THEN IF (TT(1,1).LT.ZERO) THEN TYPJ = ONE/ABS(TT(1,1)) ELSE IF (LDTT.EQ.1) THEN TYPJ = ONE/TT(1,J) ELSE TYPJ = ONE/TT(I,J) END IF ELSE TYPJ = ABS(XPLUSD(I,J)) END IF STP(I) = XPLUSD(I,J) + + SIGN(ONE,XPLUSD(I,J)) + *TYPJ*DHSTEP(0,NETA,I,J,STPD,LDSTPD) STP(I) = STP(I) - XPLUSD(I,J) XPLUSD(I,J) = XPLUSD(I,J) + STP(I) 120 CONTINUE ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + 001,WRK2,WRK6,WRK1, + ISTOP) IF (ISTOP.NE.0) THEN RETURN ELSE NFEV = NFEV + 1 DO 140 L=1,NQ DO 130 I=1,N FJACD(I,J,L) = WRK2(I,L) 130 CONTINUE 140 CONTINUE END IF IF (SETZRO) THEN DO 180 I=1,N IF (IFIXX(I,J).EQ.0) THEN DO 160 L=1,NQ FJACD(I,J,L) = ZERO 160 CONTINUE ELSE DO 170 L=1,NQ FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) 170 CONTINUE END IF 180 CONTINUE ELSE DO 200 L=1,NQ DO 190 I=1,N FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) 190 CONTINUE 200 CONTINUE END IF DO 210 I=1,N XPLUSD(I,J) = X(I,J) + DELTA(I,J) 210 CONTINUE END IF 220 CONTINUE END IF RETURN END *DJCK SUBROUTINE DJCK + (FCN, + N,M,NP,NQ, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + SSF,TT,LDTT, + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + PV0,FJACB,FJACD, + MSGB,MSGD,DIFF,ISTOP,NFEV,NJEV, + WRK1,WRK2,WRK6) C***BEGIN PROLOGUE DJCK C***REFER TO DODR,DODRC C***ROUTINES CALLED FCN,DHSTEP,DJCKM C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS C (ADAPTED FROM STARPAC SUBROUTINE DCKCNT) C***END PROLOGUE DJCK C...SCALAR ARGUMENTS DOUBLE PRECISION + EPSMAC,ETA INTEGER + ISTOP,LDIFX,LDSTPD,LDTT, + M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL LOGICAL + ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ), + PV0(N,NQ),SSF(NP),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSGB(1+NQ*NP),MSGD(1+NQ*M) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO INTEGER + IDEVAL,J,LQ,MSGB1,MSGD1 LOGICAL + ISFIXD,ISWRTB C...EXTERNAL SUBROUTINES EXTERNAL + DJCKM C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DHSTEP EXTERNAL + DHSTEP C...INTRINSIC FUNCTIONS INTRINSIC + ABS,INT,LOG10 C...DATA STATEMENTS DATA + ZERO,P5,ONE + /0.0D0,0.5D0,1.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING C CHECKED. C EPSMAC: THE VALUE OF MACHINE PRECISION. C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. C FJACB: THE JACOBIAN WITH RESPECT TO BETA. C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE C PERFORMED BY USER SUPPLIED SUBROUTINE FCN. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C ISFIXD: THE VARIABLE DESIGNATING WHETHER THE PARAMETER IS FIXED C (ISFIXD=TRUE) OR NOT (ISFIXD=FALSE). C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA C (ISWRTB=TRUE) OR DELTA (ISWRTB=FALSE) ARE BEING CHECKED. C J: AN INDEX VARIABLE. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER C SET BY THE USER OR COMPUTED BY DETAF. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH C THE DERIVATIVE IS CHECKED. C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. C ONE: THE VALUE 1.0D0. C P5: THE VALUE 0.5D0. C PV: THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C PV0: THE PREDICTED VALUES USING THE CURRENT PARAMETER ESTIMATES. C SSF: THE SCALING VALUES USED FOR BETA. C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. C TOL: THE AGREEMENT TOLERANCE. C TT: THE SCALING VALUES USED FOR DELTA. C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. C XPLUSD: THE VALUES OF X + DELTA. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DJCK C SET TOLERANCE FOR CHECKING DERIVATIVES TOL = ETA**(0.25D0) NTOL = MAX(ONE,P5-LOG10(TOL)) C COMPUTE USER SUPPLIED DERIVATIVE VALUES ISTOP = 0 IF (ISODR) THEN IDEVAL = 110 ELSE IDEVAL = 010 END IF CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + IDEVAL,WRK2,FJACB,FJACD, + ISTOP) IF (ISTOP.NE.0) THEN RETURN ELSE NJEV = NJEV + 1 END IF C CHECK DERIVATIVES WRT BETA FOR EACH RESPONSE OF OBSERVATION NROW MSGB1 = 0 MSGD1 = 0 DO 30 LQ=1,NQ C SET PREDICTED VALUE OF MODEL AT CURRENT PARAMETER ESTIMATES PV = PV0(NROW,LQ) ISWRTB = .TRUE. DO 10 J=1,NP IF (IFIXB(1).LT.0) THEN ISFIXD = .FALSE. ELSE IF (IFIXB(J).EQ.0) THEN ISFIXD = .TRUE. ELSE ISFIXD = .FALSE. END IF IF (ISFIXD) THEN MSGB(1+LQ+(J-1)*NQ) = -1 ELSE IF (BETA(J).EQ.ZERO) THEN IF (SSF(1).LT.ZERO) THEN TYPJ = ONE/ABS(SSF(1)) ELSE TYPJ = ONE/SSF(J) END IF ELSE TYPJ = ABS(BETA(J)) END IF H0 = DHSTEP(0,NETA,1,J,STPB,1) HC0 = H0 C CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW CALL DJCKM(FCN, + N,M,NP,NQ, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + ISWRTB,PV,FJACB(NROW,J,LQ), + DIFFJ,MSGB1,MSGB(2),ISTOP,NFEV, + WRK1,WRK2,WRK6) IF (ISTOP.NE.0) THEN MSGB(1) = -1 RETURN ELSE DIFF(LQ,J) = DIFFJ END IF END IF 10 CONTINUE C CHECK DERIVATIVES WRT X FOR EACH RESPONSE OF OBSERVATION NROW IF (ISODR) THEN ISWRTB = .FALSE. DO 20 J=1,M IF (IFIXX(1,1).LT.0) THEN ISFIXD = .FALSE. ELSE IF (LDIFX.EQ.1) THEN IF (IFIXX(1,J).EQ.0) THEN ISFIXD = .TRUE. ELSE ISFIXD = .FALSE. END IF ELSE ISFIXD = .FALSE. END IF IF (ISFIXD) THEN MSGD(1+LQ+(J-1)*NQ) = -1 ELSE IF (XPLUSD(NROW,J).EQ.ZERO) THEN IF (TT(1,1).LT.ZERO) THEN TYPJ = ONE/ABS(TT(1,1)) ELSE IF (LDTT.EQ.1) THEN TYPJ = ONE/TT(1,J) ELSE TYPJ = ONE/TT(NROW,J) END IF ELSE TYPJ = ABS(XPLUSD(NROW,J)) END IF H0 = DHSTEP(0,NETA,NROW,J,STPD,LDSTPD) HC0 = DHSTEP(1,NETA,NROW,J,STPD,LDSTPD) C CHECK DERIVATIVE WRT THE J-TH COLUMN OF DELTA AT ROW NROW CALL DJCKM(FCN, + N,M,NP,NQ, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + ISWRTB,PV,FJACD(NROW,J,LQ), + DIFFJ,MSGD1,MSGD(2),ISTOP,NFEV, + WRK1,WRK2,WRK6) IF (ISTOP.NE.0) THEN MSGD(1) = -1 RETURN ELSE DIFF(LQ,NP+J) = DIFFJ END IF END IF 20 CONTINUE END IF 30 CONTINUE MSGB(1) = MSGB1 MSGD(1) = MSGD1 RETURN END *DJCKC SUBROUTINE DJCKC + (FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + FD,TYPJ,PVPSTP,STP0, + PV,D, + DIFFJ,MSG,ISTOP,NFEV, + WRK1,WRK2,WRK6) C***BEGIN PROLOGUE DJCKC C***REFER TO DODR,DODRC C***ROUTINES CALLED DJCKF,DPVB,DPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE C DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES C (ADAPTED FROM STARPAC SUBROUTINE DCKCRV) C***END PROLOGUE DJCKC C...SCALAR ARGUMENTS DOUBLE PRECISION + D,DIFFJ,EPSMAC,ETA,FD,HC,PV,PVPSTP,STP0,TOL,TYPJ INTEGER + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW LOGICAL + ISWRTB C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO C...EXTERNAL SUBROUTINES EXTERNAL + DJCKF,DPVB,DPVD C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SIGN C...DATA STATEMENTS DATA + P01,ONE,TWO,TEN + /0.01D0,1.0D0,2.0D0,10.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING C CHECKED. C EPSMAC: THE VALUE OF MACHINE PRECISION. C ETA: THE RELATIVE NOISE IN THE MODEL C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. C HC: THE RELATIVE STEP SIZE FOR CENTRAL FINITE DIFFERENCES. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MSG: THE ERROR CHECKING RESULTS. C N: THE NUMBER OF OBSERVATIONS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH C THE DERIVATIVE IS TO BE CHECKED. C ONE: THE VALUE 1.0D0. C PV: THE PREDICTED VALUE OF THE MODEL FOR ROW NROW . C PVMCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE C JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV. C PVPCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE C JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV. C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. C P01: THE VALUE 0.01D0. C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. C STP: A STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. C STPCRV: THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL. C TEN: THE VALUE 10.0D0. C TOL: THE AGREEMENT TOLERANCE. C TWO: THE VALUE 2.0D0. C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. C XPLUSD: THE VALUES OF X + DELTA. C***FIRST EXECUTABLE STATEMENT DJCKC IF (ISWRTB) THEN C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT BETA STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) CALL DPVB(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,STPCRV, + ISTOP,NFEV,PVPCRV, + WRK1,WRK2,WRK6) IF (ISTOP.NE.0) THEN RETURN END IF CALL DPVB(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,-STPCRV, + ISTOP,NFEV,PVMCRV, + WRK1,WRK2,WRK6) IF (ISTOP.NE.0) THEN RETURN END IF ELSE C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT DELTA STPCRV = (HC*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - + XPLUSD(NROW,J) CALL DPVD(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,STPCRV, + ISTOP,NFEV,PVPCRV, + WRK1,WRK2,WRK6) IF (ISTOP.NE.0) THEN RETURN END IF CALL DPVD(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,-STPCRV, + ISTOP,NFEV,PVMCRV, + WRK1,WRK2,WRK6) IF (ISTOP.NE.0) THEN RETURN END IF END IF C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL CURVE = ABS((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV) CURVE = CURVE + + ETA*(ABS(PVPCRV)+ABS(PVMCRV)+TWO*ABS(PV)) / (STPCRV**2) C CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT. CALL DJCKF(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + ETA,TOL,NROW,J,LQ,ISWRTB, + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + DIFFJ,MSG,ISTOP,NFEV, + WRK1,WRK2,WRK6) IF (ISTOP.NE.0) THEN RETURN END IF IF (MSG(LQ,J).EQ.0) THEN RETURN END IF C CHECK IF HIGH CURVATURE COULD BE THE PROBLEM. STP = TWO*MAX(TOL*ABS(D)/CURVE,EPSMAC) IF (STP.LT.ABS(TEN*STP0)) THEN STP = MIN(STP,P01*ABS(STP0)) END IF IF (ISWRTB) THEN C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA STP = (STP*SIGN(ONE,BETA(J)) + BETA(J)) - BETA(J) CALL DPVB(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,STP, + ISTOP,NFEV,PVPSTP, + WRK1,WRK2,WRK6) IF (ISTOP.NE.0) THEN RETURN END IF ELSE C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + XPLUSD(NROW,J) CALL DPVD(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,STP, + ISTOP,NFEV,PVPSTP, + WRK1,WRK2,WRK6) IF (ISTOP.NE.0) THEN RETURN END IF END IF C COMPUTE THE NEW NUMERICAL DERIVATIVE FD = (PVPSTP-PV)/STP DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) C CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK IF (ABS(FD-D).LE.TOL*ABS(D)) THEN MSG(LQ,J) = 0 C CHECK IF FINITE PRECISION MAY BE THE CULPRIT (FUDGE FACTOR = 2) ELSE IF (ABS(STP*(FD-D)).LT.TWO*ETA*(ABS(PV)+ABS(PVPSTP)) + + CURVE*(EPSMAC*TYPJ)**2) THEN MSG(LQ,J) = 5 END IF RETURN END *DJCKF SUBROUTINE DJCKF + (FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + ETA,TOL,NROW,J,LQ,ISWRTB, + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, + DIFFJ,MSG,ISTOP,NFEV, + WRK1,WRK2,WRK6) C***BEGIN PROLOGUE DJCKF C***REFER TO DODR,DODRC C***ROUTINES CALLED DPVB,DPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE C CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES C (ADAPTED FROM STARPAC SUBROUTINE DCKFPA) C***END PROLOGUE DJCKF C...SCALAR ARGUMENTS DOUBLE PRECISION + CURVE,D,DIFFJ,ETA,FD,PV,PVPSTP,STP0,TOL,TYPJ INTEGER + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW LOGICAL + ISWRTB C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + HUNDRD,ONE,P1,STP,TWO LOGICAL + LARGE C...EXTERNAL SUBROUTINES EXTERNAL + DPVB,DPVD C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SIGN C...DATA STATEMENTS DATA + P1,ONE,TWO,HUNDRD + /0.1D0,1.0D0,2.0D0,100.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING C CHECKED. C ETA: THE RELATIVE NOISE IN THE MODEL C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. C HUNDRD: THE VALUE 100.0D0. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C LARGE: THE VALUE DESIGNATING WHETHER THE RECOMMENDED INCREASE IN C THE STEP SIZE WOULD BE GREATER THAN TYPJ. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MSG: THE ERROR CHECKING RESULTS. C N: THE NUMBER OF OBSERVATIONS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH C THE DERIVATIVE IS TO BE CHECKED. C ONE: THE VALUE 1.0D0. C PV: THE PREDICTED VALUE FOR ROW NROW . C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. C P1: THE VALUE 0.1D0. C STP0: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. C TOL: THE AGREEMENT TOLERANCE. C TWO: THE VALUE 2.0D0. C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. C XPLUSD: THE VALUES OF X + DELTA. C***FIRST EXECUTABLE STATEMENT DJCKF C FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM. C TRY A LARGER STEP SIZE BASED ON ESTIMATE OF CONDITION ERROR STP = ETA*(ABS(PV)+ABS(PVPSTP))/(TOL*ABS(D)) IF (STP.GT.ABS(P1*STP0)) THEN STP = MAX(STP,HUNDRD*ABS(STP0)) END IF IF (STP.GT.TYPJ) THEN STP = TYPJ LARGE = .TRUE. ELSE LARGE = .FALSE. END IF IF (ISWRTB) THEN C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA STP = (STP*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) CALL DPVB(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,STP, + ISTOP,NFEV,PVPSTP, + WRK1,WRK2,WRK6) ELSE C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - + XPLUSD(NROW,J) CALL DPVD(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,STP, + ISTOP,NFEV,PVPSTP, + WRK1,WRK2,WRK6) END IF IF (ISTOP.NE.0) THEN RETURN END IF FD = (PVPSTP-PV)/STP DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) C CHECK FOR AGREEMENT IF ((ABS(FD-D)).LE.TOL*ABS(D)) THEN C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE. MSG(LQ,J) = 0 ELSE IF ((ABS(FD-D).LE.ABS(TWO*CURVE*STP)) .OR. LARGE) THEN C CURVATURE MAY BE THE CULPRIT (FUDGE FACTOR = 2) IF (LARGE) THEN MSG(LQ,J) = 4 ELSE MSG(LQ,J) = 5 END IF END IF RETURN END *DJCKM SUBROUTINE DJCKM + (FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, + ISWRTB,PV,D, + DIFFJ,MSG1,MSG,ISTOP,NFEV, + WRK1,WRK2,WRK6) C***BEGIN PROLOGUE DJCKM C***REFER TO DODR,DODRC C***ROUTINES CALLED DJCKC,DJCKZ,DPVB,DPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE CHECK USER SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL C DERIVATIVES C (ADAPTED FROM STARPAC SUBROUTINE DCKMN) C***END PROLOGUE DJCKM C...SCALAR ARGUMENTS DOUBLE PRECISION + D,DIFFJ,EPSMAC,ETA,H0,HC0,PV,TOL,TYPJ INTEGER + ISTOP,J,LDIFX,LQ,M,MSG1,N,NFEV,NP,NQ,NROW LOGICAL + ISWRTB C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0, + TEN,THREE,TOL2,TWO,ZERO INTEGER + I C...EXTERNAL SUBROUTINES EXTERNAL + DJCKC,DJCKZ,DPVB,DPVD C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MAX,SIGN,SQRT C...DATA STATEMENTS DATA + ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD + /0.0D0,0.01D0,0.1D0,1.0D0,2.0D0,3.0D0,1.0D1,1.0D2/ DATA + BIG,TOL2 + /1.0D19,5.0D-2/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C BIG: A BIG VALUE, USED TO INITIALIZE DIFFJ. C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING C CHECKED. C EPSMAC: THE VALUE OF MACHINE PRECISION. C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. C H: THE RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. C H1: THE DEFAULT RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. C HC: THE RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. C HC1: THE DEFAULT RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. C HUNDRD: THE VALUE 100.0D0. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA C (ISWRTB=TRUE) OR DELTAS (ISWRTB=FALSE) ARE BEING CHECKED. C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MSG: THE ERROR CHECKING RESULTS. C MSG1: THE ERROR CHECKING RESULTS SUMMARY. C N: THE NUMBER OF OBSERVATIONS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH C THE DERIVATIVE IS TO BE CHECKED. C ONE: THE VALUE 1.0D0. C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE JTH C PARAMETER VALUE, WHICH IS BETA(J) + STP0. C P01: THE VALUE 0.01D0. C P1: THE VALUE 0.1D0. C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. C TEN: THE VALUE 10.0D0. C THREE: THE VALUE 3.0D0. C TWO: THE VALUE 2.0D0. C TOL: THE AGREEMENT TOLERANCE. C TOL2: A MINIMUM AGREEMENT TOLERANCE. C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. C XPLUSD: THE VALUES OF X + DELTA. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DJCKM C CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE C QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES H1 = SQRT(ETA) HC1 = ETA**(ONE/THREE) MSG(LQ,J) = 7 DIFFJ = BIG DO 10 I=1,3 IF (I.EQ.1) THEN C TRY INITIAL RELATIVE STEP SIZE H = H0 HC = HC0 ELSE IF (I.EQ.2) THEN C TRY LARGER RELATIVE STEP SIZE H = MAX(TEN*H1, MIN(HUNDRD*H0, ONE)) HC = MAX(TEN*HC1,MIN(HUNDRD*HC0,ONE)) ELSE IF (I.EQ.3) THEN C TRY SMALLER RELATIVE STEP SIZE H = MIN(P1*H1, MAX(P01*H,TWO*EPSMAC)) HC = MIN(P1*HC1,MAX(P01*HC,TWO*EPSMAC)) END IF IF (ISWRTB) THEN C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA STP0 = (H*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) CALL DPVB(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,STP0, + ISTOP,NFEV,PVPSTP, + WRK1,WRK2,WRK6) ELSE C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA STP0 = (H*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) + - XPLUSD(NROW,J) CALL DPVD(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,STP0, + ISTOP,NFEV,PVPSTP, + WRK1,WRK2,WRK6) END IF IF (ISTOP.NE.0) THEN RETURN END IF FD = (PVPSTP-PV)/STP0 C CHECK FOR AGREEMENT IF (ABS(FD-D).LE.TOL*ABS(D)) THEN C NUMERICAL AND ANALYTIC DERIVATIVES AGREE C SET RELATIVE DIFFERENCE FOR DERIVATIVE CHECKING REPORT IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN DIFFJ = ABS(FD-D) ELSE DIFFJ = ABS(FD-D)/ABS(D) END IF C SET MSG FLAG. IF (D.EQ.ZERO) THEN C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH ZERO. MSG(LQ,J) = 1 ELSE C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH NONZERO. MSG(LQ,J) = 0 END IF ELSE C NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE. CHECK WHY IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN CALL DJCKZ(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,EPSMAC,J,LQ,ISWRTB, + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + DIFFJ,MSG,ISTOP,NFEV, + WRK1,WRK2,WRK6) ELSE CALL DJCKC(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, + FD,TYPJ,PVPSTP,STP0,PV,D, + DIFFJ,MSG,ISTOP,NFEV, + WRK1,WRK2,WRK6) END IF IF (MSG(LQ,J).LE.2) THEN GO TO 20 END IF END IF 10 CONTINUE C SET SUMMARY FLAG TO INDICATE QUESTIONABLE RESULTS 20 CONTINUE IF ((MSG(LQ,J).GE.7) .AND. (DIFFJ.LE.TOL2)) MSG(LQ,J) = 6 IF ((MSG(LQ,J).GE.1) .AND. (MSG(LQ,J).LE.6)) THEN MSG1 = MAX(MSG1,1) ELSE IF (MSG(LQ,J).GE.7) THEN MSG1 = 2 END IF RETURN END *DJCKZ SUBROUTINE DJCKZ + (FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,EPSMAC,J,LQ,ISWRTB, + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, + DIFFJ,MSG,ISTOP,NFEV, + WRK1,WRK2,WRK6) C***BEGIN PROLOGUE DJCKZ C***REFER TO DODR,DODRC C***ROUTINES CALLED DPVB,DPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE C DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC C DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO C (ADAPTED FROM STARPAC SUBROUTINE DCKZRO) C***END PROLOGUE DJCKZ C...SCALAR ARGUMENTS DOUBLE PRECISION + D,DIFFJ,EPSMAC,FD,PV,PVPSTP,STP0,TOL,TYPJ INTEGER + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW LOGICAL + ISWRTB C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + CD,ONE,PVMSTP,THREE,TWO,ZERO C...EXTERNAL SUBROUTINES EXTERNAL + DPVB,DPVD C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MIN C...DATA STATEMENTS DATA + ZERO,ONE,TWO,THREE + /0.0D0,1.0D0,2.0D0,3.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C CD: THE CENTRAL DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING C CHECKED. C EPSMAC: THE VALUE OF MACHINE PRECISION. C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA C (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED. C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MSG: THE ERROR CHECKING RESULTS. C N: THE NUMBER OF OBSERVATIONS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH C THE DERIVATIVE IS TO BE CHECKED. C ONE: THE VALUE 1.0D0. C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . C PVMSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE C JTH PARAMETER VALUE, WHICH IS BETA(J) - STP0. C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. C THREE: THE VALUE 3.0D0. C TWO: THE VALUE 2.0D0. C TOL: THE AGREEMENT TOLERANCE. C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. C XPLUSD: THE VALUES OF X + DELTA. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DJCKZ C RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP C SIZE OF 2*STP0 IF (ISWRTB) THEN C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA CALL DPVB(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,-STP0, + ISTOP,NFEV,PVMSTP, + WRK1,WRK2,WRK6) ELSE C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA CALL DPVD(FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,-STP0, + ISTOP,NFEV,PVMSTP, + WRK1,WRK2,WRK6) END IF IF (ISTOP.NE.0) THEN RETURN END IF CD = (PVPSTP-PVMSTP)/(TWO*STP0) DIFFJ = MIN(ABS(CD-D),ABS(FD-D)) C CHECK FOR AGREEMENT IF (DIFFJ.LE.TOL*ABS(D)) THEN C FINITE DIFFERENCE AND ANALYTIC DERIVATIVES NOW AGREE. IF (D.EQ.ZERO) THEN MSG(LQ,J) = 1 ELSE MSG(LQ,J) = 0 END IF ELSE IF (DIFFJ*TYPJ.LE.ABS(PV*EPSMAC**(ONE/THREE))) THEN C DERIVATIVES ARE BOTH CLOSE TO ZERO MSG(LQ,J) = 2 ELSE C DERIVATIVES ARE NOT BOTH CLOSE TO ZERO MSG(LQ,J) = 3 END IF RETURN END *DODCHK SUBROUTINE DODCHK + (N,M,NP,NQ, + ISODR,ANAJAC,IMPLCT, + IFIXB, + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + LDY, + LWORK,LWKMN,LIWORK,LIWKMN, + SCLB,SCLD,STPB,STPD, + INFO) C***BEGIN PROLOGUE DODCHK C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING C NONZERO VALUES OF ARGUMENT INFO C***END PROLOGUE DODCHK C...SCALAR ARGUMENTS INTEGER + INFO,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + LIWKMN,LIWORK,LWKMN,LWORK,M,N,NP,NQ LOGICAL + ANAJAC,IMPLCT,ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M) INTEGER + IFIXB(NP) C...LOCAL SCALARS INTEGER + I,J,K,LAST,NPP C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT C (ANAJAC=TRUE). C I: AN INDEXING VARIABLE. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C J: AN INDEXING VARIABLE. C K: AN INDEXING VARIABLE. C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LDX: THE LEADING DIMENSION OF ARRAY X. C LDY: THE LEADING DIMENSION OF ARRAY X. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C LIWORK: THE LENGTH OF VECTOR IWORK. C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C LWORK: THE LENGTH OF VECTOR WORK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. C SCLB: THE SCALING VALUES FOR BETA. C SCLD: THE SCALING VALUE FOR DELTA. C STPB: THE STEP FOR THE FINITE DIFFERENCE DERIVATIVE WRT BETA. C STPD: THE STEP FOR THE FINITE DIFFERENCE DERIVATIVE WRT DELTA. C***FIRST EXECUTABLE STATEMENT DODCHK C FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN NPP = NP ELSE NPP = 0 DO 10 K=1,NP IF (IFIXB(K).NE.0) THEN NPP = NPP + 1 END IF 10 CONTINUE END IF C CHECK PROBLEM SPECIFICATION PARAMETERS IF (N.LE.0 .OR. + M.LE.0 .OR. + (NPP.LE.0 .OR. NPP.GT.N) .OR. + (NQ.LE.0)) THEN INFO = 10000 IF (N.LE.0) THEN INFO = INFO + 1000 END IF IF (M.LE.0) THEN INFO = INFO + 100 END IF IF (NPP.LE.0 .OR. NPP.GT.N) THEN INFO = INFO + 10 END IF IF (NQ.LE.0) THEN INFO = INFO + 1 END IF RETURN END IF C CHECK DIMENSION SPECIFICATION PARAMETERS IF ((.NOT.IMPLCT .AND. LDY.LT.N) .OR. + (LDX.LT.N) .OR. + (LDWE.NE.1 .AND. LDWE.LT.N) .OR. + (LD2WE.NE.1 .AND. LD2WE.LT.NQ) .OR. + (ISODR .AND. (LDWD.NE.1 .AND. LDWD.LT.N)) .OR. + (ISODR .AND. (LD2WD.NE.1 .AND. LD2WD.LT.M)) .OR. + (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) .OR. + (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) .OR. + (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) .OR. + (LWORK.LT.LWKMN) .OR. + (LIWORK.LT.LIWKMN)) THEN INFO = 20000 IF (.NOT.IMPLCT .AND. LDY.LT.N) THEN INFO = INFO + 1000 END IF IF (LDX.LT.N) THEN INFO = INFO + 2000 END IF IF ((LDWE.NE.1 .AND. LDWE.LT.N) .OR. + (LD2WE.NE.1 .AND. LD2WE.LT.NQ)) THEN INFO = INFO + 100 END IF IF (ISODR .AND. ((LDWD.NE.1 .AND. LDWD.LT.N) .OR. + (LD2WD.NE.1 .AND. LD2WD.LT.M))) THEN INFO = INFO + 200 END IF IF (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) THEN INFO = INFO + 10 END IF IF (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) THEN INFO = INFO + 20 END IF IF (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) THEN INFO = INFO + 40 END IF IF (LWORK.LT.LWKMN) THEN INFO = INFO + 1 END IF IF (LIWORK.LT.LIWKMN) THEN INFO = INFO + 2 END IF RETURN END IF C CHECK DELTA SCALING IF (ISODR .AND. SCLD(1,1).GT.0) THEN IF (LDSCLD.GE.N) THEN LAST = N ELSE LAST = 1 END IF DO 120 J=1,M DO 110 I=1,LAST IF (SCLD(I,J).LE.0) THEN INFO = 30200 GO TO 130 END IF 110 CONTINUE 120 CONTINUE END IF 130 CONTINUE C CHECK BETA SCALING IF (SCLB(1).GT.0) THEN DO 210 K=1,NP IF (SCLB(K).LE.0) THEN IF (INFO.EQ.0) THEN INFO = 30100 ELSE INFO = INFO + 100 END IF GO TO 220 END IF 210 CONTINUE END IF 220 CONTINUE C CHECK DELTA FINITE DIFFERENCE STEP SIZES IF (ANAJAC .AND. ISODR .AND. STPD(1,1).GT.0) THEN IF (LDSTPD.GE.N) THEN LAST = N ELSE LAST = 1 END IF DO 320 J=1,M DO 310 I=1,LAST IF (STPD(I,J).LE.0) THEN IF (INFO.EQ.0) THEN INFO = 32000 ELSE INFO = INFO + 2000 END IF GO TO 330 END IF 310 CONTINUE 320 CONTINUE END IF 330 CONTINUE C CHECK BETA FINITE DIFFERENCE STEP SIZES IF (ANAJAC .AND. STPB(1).GT.0) THEN DO 410 K=1,NP IF (STPB(K).LE.0) THEN IF (INFO.EQ.0) THEN INFO = 31000 ELSE INFO = INFO + 1000 END IF GO TO 420 END IF 410 CONTINUE END IF 420 CONTINUE RETURN END *DODCNT SUBROUTINE DODCNT + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, IPRINT,LUNERR,LUNRPT, + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + WORK,LWORK,IWORK,LIWORK, + INFO) C***BEGIN PROLOGUE DODCNT C***REFER TO DODR,DODRC C***ROUTINES CALLED DODDRV C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST C SQUARES (OLS) SOLUTION C***END PROLOGUE DODCNT C...SCALAR ARGUMENTS DOUBLE PRECISION + PARTOL,SSTOL,TAUFAC INTEGER + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ LOGICAL + SHORT C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), + X(LDX,M),Y(LDY,NQ) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + CNVTOL,ONE,PCHECK,PFAC,PSTART,THREE,TSTIMP,ZERO INTEGER + IPRNTI,IPR1,IPR2,IPR2F,IPR3,JOBI,JOB1,JOB2,JOB3,JOB4,JOB5, + MAXITI,MAXIT1 LOGICAL + DONE,FSTITR,HEAD,IMPLCT,PRTPEN C...LOCAL ARRAYS DOUBLE PRECISION + PNLTY(1,1,1) C...EXTERNAL SUBROUTINES EXTERNAL + DODDRV C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DMPREC EXTERNAL + DMPREC C...DATA STATEMENTS DATA + PCHECK,PSTART,PFAC,ZERO,ONE,THREE + /1.0D3,1.0D1,1.0D1,0.0D0,1.0D0,3.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C CNVTOL: THE CONVERGENCE TOLERANCE FOR IMPLICIT MODELS. C DONE: THE VARIABLE DESIGNATING WHETHER THE INPLICIT SOLUTION HAS C BEEN FOUND (DONE=TRUE) OR NOT (DONE=FALSE). C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C IPRINT: THE PRINT CONTROL VARIABLES. C IPRNTI: THE PRINT CONTROL VARIABLES. C IPR1: THE 1ST DIGIT OF THE PRINT CONTROL VARIABLE. C IPR2: THE 2ND DIGIT OF THE PRINT CONTROL VARIABLE. C IPR3: THE 3RD DIGIT OF THE PRINT CONTROL VARIABLE. C IPR4: THE 4TH DIGIT OF THE PRINT CONTROL VARIABLE. C IWORK: THE INTEGER WORK SPACE. C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C JOBI: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C JOB1: THE 1ST DIGIT OF THE VARIABLE CONTROLLING PROBLEM C INITIALIZATION AND COMPUTATIONAL METHOD. C JOB2: THE 2ND DIGIT OF THE VARIABLE CONTROLLING PROBLEM C INITIALIZATION AND COMPUTATIONAL METHOD. C JOB3: THE 3RD DIGIT OF THE VARIABLE CONTROLLING PROBLEM C INITIALIZATION AND COMPUTATIONAL METHOD. C JOB4: THE 4TH DIGIT OF THE VARIABLE CONTROLLING PROBLEM C INITIALIZATION AND COMPUTATIONAL METHOD. C JOB5: THE 5TH DIGIT OF THE VARIABLE CONTROLLING PROBLEM C INITIALIZATION AND COMPUTATIONAL METHOD. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LDX: THE LEADING DIMENSION OF ARRAY X. C LDY: THE LEADING DIMENSION OF ARRAY Y. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C LIWORK: THE LENGTH OF VECTOR IWORK. C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C LWORK: THE LENGTH OF VECTOR WORK. C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C MAXITI: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR C THE CURRENT PENALTY PARAMETER VALUE. C MAXIT1: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR C THE NEXT PENALTY PARAMETER VALUE. C N: THE NUMBER OF OBSERVATIONS. C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C ONE: THE VALUE 1.0D0. C PARTOL: THE USER SUPPLIED PARAMETER CONVERGENCE STOPPING TOLERANCE. C PCHECK: THE VALUE DESIGNATING THE MINIMUM PENALTY PARAMETER ALLOWED C BEFORE THE IMPLICIT PROBLEM CAN BE CONSIDERED SOLVED. C PFAC: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO BE C PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT C (PRTPEN=FALSE). C PSTART: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. C SCLB: THE SCALING VALUES FOR BETA. C SCLD: THE SCALING VALUES FOR DELTA. C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO BETA. C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO DELTA. C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL C (SHORT=.FALSE.). C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION C DIAMETER. C THREE: THE VALUE 3.0D0. C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL C VALUES AND THE SOLUTION. C WD: THE DELTA WEIGHTS. C WE: THE EPSILON WEIGHTS. C WORK: THE DOUBLE PRECISION WORK SPACE. C X: THE INDEPENDENT VARIABLE. C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DODCNT IMPLCT = MOD(JOB,10).EQ.1 FSTITR = .TRUE. HEAD = .TRUE. PRTPEN = .FALSE. IF (IMPLCT) THEN C SET UP FOR IMPLICIT PROBLEM IF (IPRINT.GE.0) THEN IPR1 = MOD(IPRINT,10000)/1000 IPR2 = MOD(IPRINT,1000)/100 IPR2F = MOD(IPRINT,100)/10 IPR3 = MOD(IPRINT,10) ELSE IPR1 = 2 IPR2 = 0 IPR2F = 0 IPR3 = 1 END IF IPRNTI = IPR1*1000 + IPR2*100 + IPR2F*10 JOB5 = MOD(JOB,100000)/10000 JOB4 = MOD(JOB,10000)/1000 JOB3 = MOD(JOB,1000)/100 JOB2 = MOD(JOB,100)/10 JOB1 = MOD(JOB,10) JOBI = JOB5*10000 + JOB4*1000 + JOB3*100 + JOB2*10 + JOB1 IF (WE(1,1,1).LE.ZERO) THEN PNLTY(1,1,1) = -PSTART ELSE PNLTY(1,1,1) = -WE(1,1,1) END IF IF (PARTOL.LT.ZERO) THEN CNVTOL = DMPREC()**(ONE/THREE) ELSE CNVTOL = MIN(PARTOL,ONE) END IF IF (MAXIT.GE.1) THEN MAXITI = MAXIT ELSE MAXITI = 100 END IF DONE = MAXITI.EQ.0 PRTPEN = .TRUE. 10 CONTINUE CALL DODDRV + (SHORT,HEAD,FSTITR,PRTPEN, + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + PNLTY,1,1,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + JOBI,NDIGIT,TAUFAC, SSTOL,CNVTOL,MAXITI, + IPRNTI,LUNERR,LUNRPT, + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + WORK,LWORK,IWORK,LIWORK, + MAXIT1,TSTIMP, INFO) IF (DONE) THEN RETURN ELSE DONE = MAXIT1.LE.0 .OR. + (ABS(PNLTY(1,1,1)).GE.PCHECK .AND. + TSTIMP.LE.CNVTOL) END IF IF (DONE) THEN IF (TSTIMP.LE.CNVTOL) THEN INFO = (INFO/10)*10 + 2 ELSE INFO = (INFO/10)*10 + 4 END IF JOBI = 10000 + 1000 + JOB3*100 + JOB2*10 + JOB1 MAXITI = 0 IPRNTI = IPR3 ELSE PRTPEN = .TRUE. PNLTY(1,1,1) = PFAC*PNLTY(1,1,1) JOBI = 10000 + 1000 + 000 + JOB2*10 + JOB1 MAXITI = MAXIT1 IPRNTI = 0000 + IPR2*100 + IPR2F*10 END IF GO TO 10 ELSE CALL DODDRV + (SHORT,HEAD,FSTITR,PRTPEN, + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + WORK,LWORK,IWORK,LIWORK, + MAXIT1,TSTIMP, INFO) END IF RETURN END *DODDRV SUBROUTINE DODDRV + (SHORT,HEAD,FSTITR,PRTPEN, + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, + WORK,LWORK,IWORK,LIWORK, + MAXIT1,TSTIMP, INFO) C***BEGIN PROLOGUE DODDRV C***REFER TO DODR,DODRC C***ROUTINES CALLED FCN,DCOPY,DDOT,DETAF,DFCTRW,DFLAGS, C DINIWK,DIWINF,DJCK,DNRM2,DODCHK,DODMN, C DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN C PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION C (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) C***END PROLOGUE DODDRV C...SCALAR ARGUMENTS DOUBLE PRECISION + PARTOL,SSTOL,TAUFAC,TSTIMP INTEGER + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,MAXIT1, + N,NDIGIT,NP,NQ LOGICAL + FSTITR,HEAD,PRTPEN,SHORT C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), + WE(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),WORK(LWORK), + X(LDX,M),Y(LDY,NQ) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + EPSMAC,ETA,P5,ONE,TEN,ZERO INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + DIFFI,EPSMAI,ETAI,FI,FJACBI,FJACDI,FNI,FSI,I,IDFI,INT2I,IPRINI, + IRANKI,ISTOP,ISTOPI,JOBI,JPVTI,K,LDTT,LDTTI,LIWKMN, + LUNERI,LUNRPI,LWKMN,LWRK,MAXITI,MSGB,MSGD,NETA,NETAI, + NFEV,NFEVI,NITERI,NJEV,NJEVI,NNZW,NNZWI,NPP,NPPI,NROW,NROWI, + NTOL,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,WRK, + WSSI,WSSDEI,WSSEPI,XPLUSI LOGICAL + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT,DNRM2 EXTERNAL + DDOT,DNRM2 C...EXTERNAL SUBROUTINES EXTERNAL + DCOPY,DETAF,DFCTRW,DFLAGS,DINIWK,DIWINF,DJCK,DODCHK, + DODMN,DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY C...DATA STATEMENTS DATA + ZERO,P5,ONE,TEN + /0.0D0,0.5D0,1.0D0,10.0D0/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT C (ANAJAC=TRUE). C BETA: THE FUNCTION PARAMETERS. C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD C DIFFERENCES (CDJAC=FALSE). C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT C (CHKJAC=FALSE). C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. C FI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY F. C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). C I: AN INDEX VARIABLE. C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=FALSE). C INT2I: THE IN ARRAY IWORK OF VARIABLE INT2. C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. C IPRINT: THE PRINT CONTROL VARIABLE. C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. C IWORK: THE INTEGER WORK SPACE. C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY JPVT. C K: AN INDEX VARIABLE. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LDX: THE LEADING DIMENSION OF ARRAY X. C LDY: THE LEADING DIMENSION OF ARRAY Y. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C LIWORK: THE LENGTH OF VECTOR IWORK. C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C LWORK: THE LENGTH OF VECTOR WORK. C LWRK: THE LENGTH OF VECTOR WRK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C MAXIT1: FOR IMPLICIT MODELS, THE ITERATIONS ALLOWED FOR THE NEXT C PENALTY PARAMETER VALUE. C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. C N: THE NUMBER OF OBSERVATIONS. C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C SET BY DJCK. C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. C ONE: THE VALUE 1.0D0. C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT C (PRTPEN=FALSE). C P5: THE VALUE 0.5D0. C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. C SCLB: THE SCALING VALUES FOR BETA. C SCLD: THE SCALING VALUES FOR DELTA. C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-CALL C (SHORT=FALSE). C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION C DIAMETER. C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. C TEN: THE VALUE 10.0D0. C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL C VALUES AND THE SOLUTION. C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. C WD: THE DELTA WEIGHTS. C WE: THE EPSILON WEIGHTS. C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. C WORK: THE DOUBLE PRECISION WORK SPACE. C WRK: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK, C EQUIVALENCED TO WRK1 AND WRK2. C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. C X: THE EXPLANATORY VARIABLE. C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DODDRV C INITIALIZE NECESSARY VARIABLES CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) C SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE C (INVALID VALUES OF M, NP AND/OR NQ ARE HANDLED REASONABLY BY DIWINF) CALL DIWINF(M,NP,NQ, + MSGB,MSGD,JPVTI,ISTOPI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) C SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE C (INVALID VALUES OF N, M, NP, NQ, LDWE AND/OR LD2WE C ARE HANDLED REASONABLY BY DWINF) CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, + DELTAI,FI,XPLUSI,FNI,SDI,VCVI, + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + PARTLI,SSTOLI,TAUFCI,EPSMAI, + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + FSI,FJACBI,WE1I,DIFFI, + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + LWKMN) IF (ISODR) THEN WRK = WRK1I LWRK = N*M*NQ + N*NQ ELSE WRK = WRK2I LWRK = N*NQ END IF C UPDATE THE PENALTY PARAMETERS C (WE(1,1,1) IS NOT A USER SUPPLIED ARRAY IN THIS CASE) IF (RESTRT .AND. IMPLCT) THEN WE(1,1,1) = MAX(WORK(WE1I)**2,ABS(WE(1,1,1))) WORK(WE1I) = -SQRT(ABS(WE(1,1,1))) END IF IF (RESTRT) THEN C RESET MAXIMUM NUMBER OF ITERATIONS IF (MAXIT.GE.0) THEN IWORK(MAXITI) = IWORK(NITERI) + MAXIT ELSE IWORK(MAXITI) = IWORK(NITERI) + 10 END IF IF (IWORK(NITERI).LT.IWORK(MAXITI)) THEN INFO = 0 END IF IF (JOB.GE.0) IWORK(JOBI) = JOB IF (IPRINT.GE.0) IWORK(IPRINI) = IPRINT IF (PARTOL.GE.ZERO .AND. PARTOL.LT.ONE) WORK(PARTLI) = PARTOL IF (SSTOL.GE.ZERO .AND. SSTOL.LT.ONE) WORK(SSTOLI) = SSTOL WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI) IF (IMPLCT) THEN CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) ELSE CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) END IF CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) ELSE C PERFORM ERROR CHECKING INFO = 0 CALL DODCHK(N,M,NP,NQ, + ISODR,ANAJAC,IMPLCT, + IFIXB, + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + LDY, + LWORK,LWKMN,LIWORK,LIWKMN, + SCLB,SCLD,STPB,STPD, + INFO) IF (INFO.GT.0) THEN GO TO 50 END IF C INITIALIZE WORK VECTORS AS NECESSARY DO 10 I=N*M+N*NQ+1,LWORK WORK(I) = ZERO 10 CONTINUE DO 20 I=1,LIWORK IWORK(I) = 0 20 CONTINUE CALL DINIWK(N,M,NP, + WORK,LWORK,IWORK,LIWORK, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + BETA,SCLB, + SSTOL,PARTOL,MAXIT,TAUFAC, + JOB,IPRINT,LUNERR,LUNRPT, + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + JOBI,IPRINI,LUNERI,LUNRPI, + SSFI,TTI,LDTTI,DELTAI) IWORK(MSGB) = -1 IWORK(MSGD) = -1 WORK(TAUI) = -WORK(TAUFCI) C SET UP FOR PARAMETER ESTIMATION - C PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES C AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB) CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB) NPP = IWORK(NPPI) C CHECK THAT WD IS POSITIVE DEFINITE AND WE IS POSITIVE SEMIDEFINITE, C SAVING FACTORIZATION OF WE, AND COUNTING NUMBER OF NONZERO WEIGHTS CALL DFCTRW(N,M,NQ,NPP, + ISODR, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + WORK(WRK2I),WORK(WRK4I), + WORK(WE1I),NNZW,INFO) IWORK(NNZWI) = NNZW IF (INFO.NE.0) THEN GO TO 50 END IF C EVALUATE THE PREDICTED VALUES AND C WEIGHTED EPSILONS AT THE STARTING POINT CALL DUNPAC(NP,WORK(BETACI),BETA,IFIXB) CALL DXPY(N,M,X,LDX,WORK(DELTAI),N,WORK(XPLUSI),N) ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,WORK(XPLUSI), + IFIXB,IFIXX,LDIFX, + 002,WORK(FNI),WORK(WRK6I),WORK(WRK1I), + ISTOP) IWORK(ISTOPI) = ISTOP IF (ISTOP.EQ.0) THEN IWORK(NFEVI) = IWORK(NFEVI) + 1 IF (IMPLCT) THEN CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) ELSE CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) END IF CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) ELSE INFO = 52000 GO TO 50 END IF C COMPUTE NORM OF THE INITIAL ESTIMATES CALL DWGHT(NPP,1,WORK(SSI),NPP,1,WORK(BETACI),NPP, + WORK(WRK),NPP) IF (ISODR) THEN CALL DWGHT(N,M,WORK(TTI),IWORK(LDTTI),1,WORK(DELTAI),N, + WORK(WRK+NPP),N) WORK(PNORMI) = DNRM2(NPP+N*M,WORK(WRK),1) ELSE WORK(PNORMI) = DNRM2(NPP,WORK(WRK),1) END IF C COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) IF (ISODR) THEN CALL DWGHT(N,M,WD,LDWD,LD2WD,WORK(DELTAI),N,WORK(WRK),N) WORK(WSSDEI) = DDOT(N*M,WORK(DELTAI),1,WORK(WRK),1) ELSE WORK(WSSDEI) = ZERO END IF WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) C SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS NROW = -1 CALL DSETN(N,M,WORK(XPLUSI),N,NROW) IWORK(NROWI) = NROW C SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS EPSMAC = WORK(EPSMAI) IF (NDIGIT.LT.2) THEN IWORK(NETAI) = -1 NFEV = IWORK(NFEVI) CALL DETAF(FCN, + N,M,NP,NQ, + WORK(XPLUSI),BETA,EPSMAC,NROW, + WORK(BETANI),WORK(FNI), + IFIXB,IFIXX,LDIFX, + ISTOP,NFEV,ETA,NETA, + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I),WORK(WRK7I)) IWORK(ISTOPI) = ISTOP IWORK(NFEVI) = NFEV IF (ISTOP.NE.0) THEN INFO = 53000 IWORK(NETAI) = 0 WORK(ETAI) = ZERO GO TO 50 ELSE IWORK(NETAI) = -NETA WORK(ETAI) = ETA END IF ELSE IWORK(NETAI) = MIN(NDIGIT,INT(P5-LOG10(EPSMAC))) WORK(ETAI) = MAX(EPSMAC,TEN**(-NDIGIT)) END IF C CHECK DERIVATIVES IF NECESSARY IF (CHKJAC .AND. ANAJAC) THEN NTOL = -1 NFEV = IWORK(NFEVI) NJEV = IWORK(NJEVI) NETA = IWORK(NETAI) LDTT = IWORK(LDTTI) ETA = WORK(ETAI) EPSMAC = WORK(EPSMAI) CALL DJCK(FCN, + N,M,NP,NQ, + BETA,WORK(XPLUSI), + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, + WORK(SSFI),WORK(TTI),LDTT, + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, + WORK(FNI),WORK(FJACBI),WORK(FJACDI), + IWORK(MSGB),IWORK(MSGD),WORK(DIFFI), + ISTOP,NFEV,NJEV, + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I)) IWORK(ISTOPI) = ISTOP IWORK(NFEVI) = NFEV IWORK(NJEVI) = NJEV IWORK(NTOLI) = NTOL IF (ISTOP.NE.0) THEN INFO = 54000 ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGD).NE.0) THEN INFO = 40000 END IF ELSE C INDICATE USER SUPPLIED DERIVATIVES WERE NOT CHECKED IWORK(MSGB) = -1 IWORK(MSGD) = -1 END IF C PRINT APPROPRIATE ERROR MESSAGES 50 IF ((INFO.NE.0) .OR. (IWORK(MSGB).NE.-1)) THEN IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN CALL DODPER + (INFO,LUNERR,SHORT, + N,M,NP,NQ, + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + LWKMN,LIWKMN, + WORK(FJACBI),WORK(FJACDI), + WORK(DIFFI),IWORK(MSGB),ISODR,IWORK(MSGD), + WORK(XPLUSI),IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI)) END IF C SET INFO TO REFLECT ERRORS IN THE USER SUPPLIED JACOBIANS IF (INFO.EQ.40000) THEN IF (IWORK(MSGB).EQ.2 .OR. IWORK(MSGD).EQ.2) THEN IF (IWORK(MSGB).EQ.2) THEN INFO = INFO + 1000 END IF IF (IWORK(MSGD).EQ.2) THEN INFO = INFO + 100 END IF ELSE INFO = 0 END IF END IF IF (INFO.NE.0) THEN RETURN END IF END IF END IF C SAVE THE INITIAL VALUES OF BETA CALL DCOPY(NP,BETA,1,WORK(BETA0I),1) C FIND LEAST SQUARES SOLUTION CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FSI),1) LDTT = IWORK(LDTTI) CALL DODMN(HEAD,FSTITR,PRTPEN, + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + WE,WORK(WE1I),LDWE,LD2WE,WD,LDWD,LD2WD, + IFIXB,IFIXX,LDIFX, + WORK(BETACI),WORK(BETANI),WORK(BETASI),WORK(SI), + WORK(DELTAI),WORK(DELTNI),WORK(DELTSI), + WORK(TI),WORK(FI),WORK(FNI),WORK(FSI), + WORK(FJACBI),IWORK(MSGB),WORK(FJACDI),IWORK(MSGD), + WORK(SSFI),WORK(SSI),WORK(TTI),LDTT, + STPB,STPD,LDSTPD, + WORK(XPLUSI),WORK(WRK),LWRK, + WORK,LWORK,IWORK,LIWORK,INFO) MAXIT1 = IWORK(MAXITI) - IWORK(NITERI) TSTIMP = ZERO DO 100 K=1,NP IF (BETA(K).EQ.ZERO) THEN TSTIMP = MAX(TSTIMP, + ABS(BETA(K)-WORK(BETA0I-1+K))/WORK(SSFI-1+K)) ELSE TSTIMP = MAX(TSTIMP, + ABS(BETA(K)-WORK(BETA0I-1+K))/ABS(BETA(K))) END IF 100 CONTINUE RETURN END *DODLM SUBROUTINE DODLM + (N,M,NP,NQ,NPP, + F,FJACB,FJACD, + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + ALPHA2,TAU,EPSFCN,ISODR, + TFJACB,OMEGA,U,QRAUX,JPVT, + S,T,NLMS,RCOND,IRANK, + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) C***BEGIN PROLOGUE DODLM C***REFER TO DODR,DODRC C***ROUTINES CALLED DDOT,DNRM2,DODSTP,DSCALE,DWGHT C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T C USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT C ALGORITHM C***END PROLOGUE DODLM C...SCALAR ARGUMENTS DOUBLE PRECISION + ALPHA2,EPSFCN,RCOND,TAU INTEGER + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ LOGICAL + ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + WRK(LWRK),WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M) INTEGER + JPVT(NP) C...LOCAL SCALARS DOUBLE PRECISION + ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO INTEGER + I,IWRK,J,K,L LOGICAL + FORVCV C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT,DNRM2 EXTERNAL + DDOT,DNRM2 C...EXTERNAL SUBROUTINES EXTERNAL + DODSTP,DSCALE,DWGHT C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MAX,MIN,SQRT C...DATA STATEMENTS DATA + ZERO,P001,P1 + /0.0D0,0.001D0,0.1D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ALPHAN: THE NEW LEVENBERG-MARQUARDT PARAMETER. C ALPHA1: THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER. C ALPHA2: THE CURRENT LEVENBERG-MARQUARDT PARAMETER. C BOT: THE LOWER LIMIT FOR SETTING ALPHA. C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C EPSFCN: THE FUNCTION'S PRECISION. C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C FJACB: THE JACOBIAN WITH RESPECT TO BETA. C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). C I: AN INDEXING VARIABLE. C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE C STOPED DUE TO SOME NUMERICAL ERROR DETECTED WITHIN C SUBROUTINE DODSTP. C IWRK: AN INDEXING VARIABLE. C J: AN INDEXING VARIABLE. C K: AN INDEXING VARIABLE. C L: AN INDEXING VARIABLE. C JPVT: THE PIVOT VECTOR. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LWRK: THE LENGTH OF VECTOR WRK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C OMEGA: THE ARRAY (I-FJACD*INV(P)*TRANS(FJACD))**(-1/2) WHERE C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 C P001: THE VALUE 0.001D0 C P1: THE VALUE 0.1D0 C PHI1: THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP C AND THE TRUST REGION DIAMETER. C PHI2: THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP C AND THE TRUST REGION DIAMETER. C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C S: THE STEP FOR BETA. C SA: THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2). C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. C T: THE STEP FOR DELTA. C TAU: THE TRUST REGION DIAMETER. C TFJACB: THE ARRAY OMEGA*FJACB. C TOP: THE UPPER LIMIT FOR SETTING ALPHA. C TT: THE SCALE USED FOR THE DELTA'S. C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. C WD: THE DELTA WEIGHTS. C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, C EQUIVALENCED TO WRK1 AND WRK2. C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK3: A WORK ARRAY OF (NP) ELEMENTS. C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. C WRK5: A WORK ARRAY OF (M) ELEMENTS. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DODLM FORVCV = .FALSE. ISTOPC = 0 C COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0) ALPHA1 = ZERO CALL DODSTP(N,M,NP,NQ,NPP, + F,FJACB,FJACD, + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + ALPHA1,EPSFCN,ISODR, + TFJACB,OMEGA,U,QRAUX,JPVT, + S,T,PHI1,IRANK,RCOND,FORVCV, + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) IF (ISTOPC.NE.0) THEN RETURN END IF C INITIALIZE TAU IF NECESSARY IF (TAU.LT.ZERO) THEN TAU = ABS(TAU)*PHI1 END IF C CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL IF ((PHI1-TAU).LE.P1*TAU) THEN NLMS = 1 ALPHA2 = ZERO RETURN END IF C FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION - C FIND LOCALLY CONSTRAINED OPTIMAL STEP PHI1 = PHI1 - TAU C INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA BOT = ZERO DO 30 K=1,NPP DO 20 L=1,NQ DO 10 I=1,N TFJACB(I,L,K) = FJACB(I,K,L) 10 CONTINUE 20 CONTINUE WRK(K) = DDOT(N*NQ,TFJACB(1,1,K),1,F(1,1),1) 30 CONTINUE CALL DSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP) IF (ISODR) THEN CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(NPP+1),N) IWRK = NPP DO 50 J=1,M DO 40 I=1,N IWRK = IWRK + 1 WRK(IWRK) = WRK(IWRK) + + DDOT(NQ,FJACD(I,J,1),N*M,F(I,1),N) 40 CONTINUE 50 CONTINUE CALL DSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N) TOP = DNRM2(NPP+N*M,WRK,1)/TAU ELSE TOP = DNRM2(NPP,WRK,1)/TAU END IF IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN ALPHA2 = P001*TOP END IF C MAIN LOOP DO 60 I=1,10 C COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR C CURRENT VALUE OF ALPHA CALL DODSTP(N,M,NP,NQ,NPP, + F,FJACB,FJACD, + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + ALPHA2,EPSFCN,ISODR, + TFJACB,OMEGA,U,QRAUX,JPVT, + S,T,PHI2,IRANK,RCOND,FORVCV, + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) IF (ISTOPC.NE.0) THEN RETURN END IF PHI2 = PHI2-TAU C CHECK WHETHER CURRENT STEP IS OPTIMAL IF (ABS(PHI2).LE.P1*TAU .OR. + (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN NLMS = I+1 RETURN END IF C CURRENT STEP IS NOT OPTIMAL C UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA IF (PHI1-PHI2.EQ.ZERO) THEN NLMS = 12 RETURN END IF SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2) IF (PHI2.LT.ZERO) THEN TOP = MIN(TOP,ALPHA2) ELSE BOT = MAX(BOT,ALPHA2) END IF IF (PHI1*PHI2.GT.ZERO) THEN BOT = MAX(BOT,ALPHA2-SA) ELSE TOP = MIN(TOP,ALPHA2-SA) END IF ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT)) END IF C GET READY FOR NEXT ITERATION ALPHA1 = ALPHA2 ALPHA2 = ALPHAN PHI1 = PHI2 60 CONTINUE C SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS NLMS = 12 RETURN END *DODMN SUBROUTINE DODMN + (HEAD,FSTITR,PRTPEN, + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, + WE,WE1,LDWE,LD2WE,WD,LDWD,LD2WD, + IFIXB,IFIXX,LDIFX, + BETAC,BETAN,BETAS,S,DELTA,DELTAN,DELTAS, + T,F,FN,FS,FJACB,MSGB,FJACD,MSGD, + SSF,SS,TT,LDTT,STPB,STPD,LDSTPD, + XPLUSD,WRK,LWRK,WORK,LWORK,IWORK,LIWORK,INFO) C***BEGIN PROLOGUE DODMN C***REFER TO DODR,DODRC C***ROUTINES CALLED FCN,DACCES,DCOPY,DDOT,DEVJAC,DFLAGS,DNRM2,DODLM, C DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE ITERATIVELY COMPUTE LEAST SQUARES SOLUTION C***END PROLOGUE DODMN C...SCALAR ARGUMENTS INTEGER + INFO,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + LIWORK,LWORK,LWRK,M,N,NP,NQ C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP), + DELTA(N,M),DELTAN(N,M),DELTAS(N,M), + F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),FS(N,NQ), + S(NP),SS(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M), + T(N,M),TT(LDTT,M), + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ), + WORK(LWORK),X(LDX,M),XPLUSD(N,M),WRK(LWRK),Y(LDY,NQ) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK), + MSGB(NQ*NP+1),MSGD(NQ*M+1) LOGICAL + FSTITR,HEAD,PRTPEN C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + ACTRED,ACTRS,ALPHA,DIRDER,ETA,OLMAVG,ONE, + P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS, + RATIO,RCOND,RNORM,RNORMN,RNORMS,RSS,RVAR,SSTOL,TAU,TAUFAC, + TEMP,TEMP1,TEMP2,TSNORM,ZERO INTEGER + I,IDF,IFLAG,INT2,IPR,IPR1,IPR2,IPR2F,IPR3,IRANK, + ISTOP,ISTOPC,IWRK,J,JPVT,L,LOOPED,LUDFLT,LUNR,LUNRPT, + MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW,NPP,NPR,OMEGA,QRAUX, + SD,U,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 LOGICAL + ACCESS,ANAJAC,CDJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV, + IMPLCT,INITD,INTDBL,ISODR,LSTEP,REDOJ,RESTRT C...LOCAL ARRAYS DOUBLE PRECISION + WSS(3) C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT,DNRM2 EXTERNAL + DDOT,DNRM2 C...EXTERNAL SUBROUTINES EXTERNAL + DACCES,DCOPY,DEVJAC,DFLAGS, + DODLM,DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MIN,MOD,SQRT C...DATA STATEMENTS DATA + ZERO,P0001,P1,P25,P5,P75,ONE + /0.0D0,0.00010D0,0.10D0,0.250D0, + 0.50D0,0.750D0,1.0D0/ DATA + LUDFLT + /6/ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN C THEM (ACCESS=FALSE). C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). C BETA: THE FUNCTION PARAMETERS. C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. C BETAN: THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C BETAS: THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD C DIFFERENCES (CDJAC=FALSE). C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT C (CHKJAC=FALSE). C CNVPAR: THE VARIABLE DESIGNATING WHETHER PARAMETER CONVERGENCE WAS C ATTAINED (CNVPAR=TRUE) OR NOT (CNVPAR=FALSE). C CNVSS: THE VARIABLE DESIGNATING WHETHER SUM-OF-SQUARES CONVERGENCE C WAS ATTAINED (CNVSS=TRUE) OR NOT (CNVSS=FALSE). C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C DELTAN: THE NEW ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C DELTAS: THE SAVED ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). C DIRDER: THE DIRECTIONAL DERIVATIVE. C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX C SHOULD TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C FJACB: THE JACOBIAN WITH RESPECT TO BETA. C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. C FS: THE SAVED PREDICTED VALUES FROM THE FUNCTION. C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). C I: AN INDEXING VARIABLE. C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFLAG: THE VARIABLE DESIGNATING WHICH REPORT IS TO BE PRINTED. C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=FALSE). C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN. C INTDBL: THE VARIABLE DESIGNATING WHETHER INTERNAL DOUBLING IS TO BE C USED (INTDBL=TRUE) OR NOT (INTDBL=FALSE). C IPR: THE VALUES DESIGNATING THE LENGTH OF THE PRINTED REPORT. C IPR1: THE VALUE OF THE 4TH DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE INITIAL SUMMARY REPORT. C IPR2: THE VALUE OF THE 3RD DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE ITERATION REPORT. C IPR2F: THE VALUE OF THE 2ND DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. C IPR3: THE VALUE OF THE 1ST DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FINAL SUMMARY REPORT. C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR OLS (ISODR=FALSE). C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE C STOPED DUE TO SOME NUMERICAL ERROR WITHIN ROUTINE DODSTP. C IWORK: THE INTEGER WORK SPACE. C IWRK: AN INDEX VARIABLE. C J: AN INDEX VARIABLE. C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C JPVT: THE STARTING LOCATION IN IWORK OF ARRAY JPVT. C L: AN INDEX VARIABLE. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE AND WE1. C LDX: THE LEADING DIMENSION OF ARRAY X. C LDY: THE LEADING DIMENSION OF ARRAY Y. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE AND WE1. C LIWORK: THE LENGTH OF VECTOR IWORK. C LOOPED: A COUNTER USED TO DETERMINE HOW MANY TIMES THE SUBLOOP C HAS BEEN EXECUTED, WHERE IF THE COUNT BECOMES LARGE C ENOUGH THE COMPUTATIONS WILL BE STOPPED. C LSTEP: THE VARIABLE DESIGNATING WHETHER A SUCCESSFUL STEP HAS C BEEN FOUND (LSTEP=TRUE) OR NOT (LSTEP=FALSE). C LUDFLT: THE DEFAULT LOGICAL UNIT NUMBER, USED FOR COMPUTATION C REPORTS TO THE SCREEN. C LUNR: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C LWORK: THE LENGTH OF VECTOR WORK. C LWRK: THE LENGTH OF VECTOR WRK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NITER: THE NUMBER OF ITERATIONS TAKEN. C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. C NPR: THE NUMBER OF TIMES THE REPORT IS TO BE WRITTEN. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER C ITERATION. C OMEGA: THE STARTING LOCATION IN WORK OF ARRAY OMEGA. C ONE: THE VALUE 1.0D0. C P0001: THE VALUE 0.0001D0. C P1: THE VALUE 0.1D0. C P25: THE VALUE 0.25D0. C P5: THE VALUE 0.5D0. C P75: THE VALUE 0.75D0. C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C PRERS: THE OLD PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO C BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT C (PRTPEN=FALSE). C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. C RATIO: THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED C RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C RNORM: THE NORM OF THE WEIGHTED ERRORS. C RNORMN: THE NEW NORM OF THE WEIGHTED ERRORS. C RNORMS: THE SAVED NORM OF THE WEIGHTED ERRORS. C RSS: THE RESIDUAL SUM OF SQUARES. C RVAR: THE RESIDUAL VARIANCE. C S: THE STEP FOR BETA. C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. C SSF: THE SCALING VALUES USED FOR BETA. C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO EACH BETA. C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO DELTA. C T: THE STEP FOR DELTA. C TAU: THE TRUST REGION DIAMETER. C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION C DIAMETER. C TEMP: A TEMPORARY STORAGE LOCATION. C TEMP1: A TEMPORARY STORAGE LOCATION. C TEMP2: A TEMPORARY STORAGE LOCATION. C TSNORM: THE NORM OF THE SCALED STEP. C TT: THE SCALING VALUES USED FOR DELTA. C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. C WE: THE EPSILON WEIGHTS. C WE1: THE SQUARE ROOT OF THE EPSILON WEIGHTS. C WD: THE DELTA WEIGHTS. C WORK: THE DOUBLE PRECISION WORK SPACE. C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. C WRK: A WORK ARRAY, EQUIVALENCED TO WRK1 AND WRK2 C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. C X: THE EXPLANATORY VARIABLE. C XPLUSD: THE VALUES OF X + DELTA. C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DODMN C INITIALIZE NECESSARY VARIABLES CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) ACCESS = .TRUE. CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + WORK,LWORK,IWORK,LIWORK, + ACCESS,ISODR, + JPVT,OMEGA,U,QRAUX,SD,VCV, + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + NNZW,NPP, + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + WSS,RVAR,IDF, + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) RNORM = SQRT(WSS(1)) DIDVCV = .FALSE. INTDBL = .FALSE. LSTEP = .TRUE. C PRINT INITIAL SUMMARY IF DESIRED IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN IFLAG = 1 IF (IPR1.GE.3 .AND. LUNRPT.NE.LUDFLT) THEN NPR = 2 ELSE NPR = 1 END IF IF (IPR1.GE.6) THEN IPR = 2 ELSE IPR = 2 - MOD(IPR1,2) END IF LUNR = LUNRPT DO 10 I=1,NPR CALL DODPCR(IPR,LUNR, + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + N,M,NP,NQ,NPP,NNZW, + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + IFIXB,IFIXX,LDIFX, + SSF,TT,LDTT,STPB,STPD,LDSTPD, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,RVAR,IDF,WORK(SD), + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) IF (IPR1.GE.5) THEN IPR = 2 ELSE IPR = 1 END IF LUNR = LUDFLT 10 CONTINUE END IF C STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION IF (RNORM.EQ.ZERO) THEN INFO = 1 OLMAVG = ZERO ISTOP = 0 GO TO 150 END IF C STOP IF NUMBER OF ITERATIONS ALREADY EQUALS MAXIMUM PERMITTED IF (RESTRT .AND. (NITER.GE.MAXIT)) THEN ISTOP = 0 GO TO 150 ELSE IF (NITER.GE.MAXIT) THEN INFO = 4 ISTOP = 0 GO TO 150 END IF C MAIN LOOP 100 CONTINUE NITER = NITER + 1 RNORMS = RNORM LOOPED = 0 C EVALUATE JACOBIAN USING BEST ESTIMATE OF FUNCTION (FS) IF ((NITER.EQ.1) .AND. (ANAJAC.AND.CHKJAC)) THEN ISTOP = 0 ELSE CALL DEVJAC(FCN, + ANAJAC,CDJAC, + N,M,NP,NQ, + BETAC,BETA,STPB, + IFIXB,IFIXX,LDIFX, + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + SSF,TT,LDTT,NETA,FS, + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + NJEV,NFEV,ISTOP,INFO) END IF IF (ISTOP.NE.0) THEN INFO = 51000 GO TO 200 ELSE IF (INFO.EQ.50300) THEN GO TO 200 END IF C SUB LOOP FOR C INTERNAL DOUBLING OR C COMPUTING NEW STEP WHEN OLD FAILED 110 CONTINUE C COMPUTE STEPS S AND T IF (LOOPED.GT.100) THEN INFO = 60000 GO TO 200 ELSE LOOPED = LOOPED + 1 CALL DODLM(N,M,NP,NQ,NPP, + F,FJACB,FJACD, + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + ALPHA,TAU,ETA,ISODR, + WORK(WRK6),WORK(OMEGA), + WORK(U),WORK(QRAUX),IWORK(JPVT), + S,T,NLMS,RCOND,IRANK, + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + WORK(WRK5),WRK,LWRK,ISTOPC) END IF IF (ISTOPC.NE.0) THEN INFO = ISTOPC GO TO 200 END IF OLMAVG = OLMAVG+NLMS C COMPUTE BETAN = BETAC + S C DELTAN = DELTA + T CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP) IF (ISODR) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N) C COMPUTE NORM OF SCALED STEPS S AND T (TSNORM) CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) IF (ISODR) THEN CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) TSNORM = DNRM2(NPP+N*M,WRK,1) ELSE TSNORM = DNRM2(NPP,WRK,1) END IF C COMPUTE SCALED PREDICTED REDUCTION IWRK = 0 DO 130 L=1,NQ DO 120 I=1,N IWRK = IWRK + 1 WRK(IWRK) = DDOT(NPP,FJACB(I,1,L),N,S,1) IF (ISODR) WRK(IWRK) = WRK(IWRK) + + DDOT(M,FJACD(I,1,L),N,T(I,1),N) 120 CONTINUE 130 CONTINUE IF (ISODR) THEN CALL DWGHT(N,M,WD,LDWD,LD2WD,T,N,WRK(N*NQ+1),N) TEMP1 = DDOT(N*NQ,WRK,1,WRK,1) + DDOT(N*M,T,1,WRK(N*NQ+1),1) TEMP1 = SQRT(TEMP1)/RNORM ELSE TEMP1 = DNRM2(N*NQ,WRK,1)/RNORM END IF TEMP2 = SQRT(ALPHA)*TSNORM/RNORM PRERED = TEMP1**2+TEMP2**2/P5 DIRDER = -(TEMP1**2+TEMP2**2) C EVALUATE PREDICTED VALUES AT NEW POINT CALL DUNPAC(NP,BETAN,BETA,IFIXB) CALL DXPY(N,M,X,LDX,DELTAN,N,XPLUSD,N) ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + 002,FN,WORK(WRK6),WORK(WRK1), + ISTOP) IF (ISTOP.EQ.0) THEN NFEV = NFEV + 1 END IF IF (ISTOP.LT.0) THEN C SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FCN INFO = 51000 GO TO 200 ELSE IF (ISTOP.GT.0) THEN C SET NORM TO INDICATE STEP SHOULD BE REJECTED RNORMN = RNORM/(P1*P75) ELSE C COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN) IF (IMPLCT) THEN CALL DCOPY(N*NQ,FN,1,WRK,1) ELSE CALL DXMY(N,NQ,FN,N,Y,LDY,WRK,N) END IF CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,WRK,N,WRK,N) IF (ISODR) THEN CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTAN,N,WRK(N*NQ+1),N) RNORMN = SQRT(DDOT(N*NQ,WRK,1,WRK,1) + + DDOT(N*M,DELTAN,1,WRK(N*NQ+1),1)) ELSE RNORMN = DNRM2(N*NQ,WRK,1) END IF END IF C COMPUTE SCALED ACTUAL REDUCTION IF (P1*RNORMN.LT.RNORM) THEN ACTRED = ONE - (RNORMN/RNORM)**2 ELSE ACTRED = -ONE END IF C COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION IF(PRERED .EQ. ZERO) THEN RATIO = ZERO ELSE RATIO = ACTRED/PRERED END IF C CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN ISTOP = 0 TAU = TAU*P5 ALPHA = ALPHA/P5 CALL DCOPY(NPP,BETAS,1,BETAN,1) CALL DCOPY(N*M,DELTAS,1,DELTAN,1) CALL DCOPY(N*NQ,FS,1,FN,1) ACTRED = ACTRS PRERED = PRERS RNORMN = RNORMS RATIO = P5 END IF C UPDATE STEP BOUND INTDBL = .FALSE. IF (RATIO.LT.P25) THEN IF (ACTRED.GE.ZERO) THEN TEMP = P5 ELSE TEMP = P5*DIRDER/(DIRDER+P5*ACTRED) END IF IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN TEMP = P1 END IF TAU = TEMP*MIN(TAU,TSNORM/P1) ALPHA = ALPHA/TEMP ELSE IF (ALPHA.EQ.ZERO) THEN TAU = TSNORM/P5 ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN C STEP QUALIFIES FOR INTERNAL DOUBLING C - UPDATE TAU AND ALPHA C - SAVE INFORMATION FOR CURRENT POINT INTDBL = .TRUE. TAU = TSNORM/P5 ALPHA = ALPHA*P5 CALL DCOPY(NPP,BETAN,1,BETAS,1) CALL DCOPY(N*M,DELTAN,1,DELTAS,1) CALL DCOPY(N*NQ,FN,1,FS,1) ACTRS = ACTRED PRERS = PRERED RNORMS = RNORMN END IF C IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS IF (INTDBL .AND. TAU.GT.ZERO) THEN INT2 = INT2+1 GO TO 110 END IF C CHECK ACCEPTANCE IF (RATIO.GE.P0001) THEN CALL DCOPY(N*NQ,FN,1,FS,1) IF (IMPLCT) THEN CALL DCOPY(N*NQ,FS,1,F,1) ELSE CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) END IF CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,F,N) CALL DCOPY(NPP,BETAN,1,BETAC,1) CALL DCOPY(N*M,DELTAN,1,DELTA,1) RNORM = RNORMN CALL DWGHT(NPP,1,SS,NPP,1,BETAC,NPP,WRK,NPP) IF (ISODR) THEN CALL DWGHT(N,M,TT,LDTT,1,DELTA,N,WRK(NPP+1),N) PNORM = DNRM2(NPP+N*M,WRK,1) ELSE PNORM = DNRM2(NPP,WRK,1) END IF LSTEP = .TRUE. ELSE LSTEP = .FALSE. END IF C TEST CONVERGENCE INFO = 0 CNVSS = RNORM.EQ.ZERO + .OR. + (ABS(ACTRED).LE.SSTOL .AND. + PRERED.LE.SSTOL .AND. + P5*RATIO.LE.ONE) CNVPAR = (TAU.LE.PARTOL*PNORM) .AND. (.NOT.IMPLCT) IF (CNVSS) INFO = 1 IF (CNVPAR) INFO = 2 IF (CNVSS .AND. CNVPAR) INFO = 3 C PRINT ITERATION REPORT IF (INFO.NE.0 .OR. LSTEP) THEN IF (IPR2.NE.0 .AND. IPR2F.NE.0 .AND. LUNRPT.NE.0) THEN IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN IFLAG = 2 CALL DUNPAC(NP,BETAC,BETA,IFIXB) WSS(1) = RNORM*RNORM IF (IPR2.GE.3. AND. LUNRPT.NE.LUDFLT) THEN NPR = 2 ELSE NPR = 1 END IF IF (IPR2.GE.6) THEN IPR = 2 ELSE IPR = 2 - MOD(IPR2,2) END IF LUNR = LUNRPT DO 140 I=1,NPR CALL DODPCR(IPR,LUNR, + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + N,M,NP,NQ,NPP,NNZW, + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + IFIXB,IFIXX,LDIFX, + SSF,TT,LDTT,STPB,STPD,LDSTPD, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,RVAR,IDF,WORK(SD), + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) IF (IPR2.GE.5) THEN IPR = 2 ELSE IPR = 1 END IF LUNR = LUDFLT 140 CONTINUE FSTITR = .FALSE. PRTPEN = .FALSE. END IF END IF END IF C CHECK IF FINISHED IF (INFO.EQ.0) THEN IF (LSTEP) THEN C BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET IF (NITER.GE.MAXIT) THEN INFO = 4 ELSE GO TO 100 END IF ELSE C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET GO TO 110 END IF END IF 150 CONTINUE IF (ISTOP.GT.0) INFO = INFO + 100 C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER IF (IMPLCT) THEN CALL DCOPY(N*NQ,FS,1,F,1) ELSE CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) END IF CALL DUNPAC(NP,BETAC,BETA,IFIXB) CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED IF (DOVCV .AND. ISTOP.EQ.0) THEN C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED C TO COMPUTE COVARIANCE MATRIX IF (REDOJ) THEN CALL DEVJAC(FCN, + ANAJAC,CDJAC, + N,M,NP,NQ, + BETAC,BETA,STPB, + IFIXB,IFIXX,LDIFX, + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, + SSF,TT,LDTT,NETA,FS, + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, + NJEV,NFEV,ISTOP,INFO) IF (ISTOP.NE.0) THEN INFO = 51000 GO TO 200 ELSE IF (INFO.EQ.50300) THEN GO TO 200 END IF END IF IF (IMPLCT) THEN CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) RSS = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) ELSE RSS = RNORM*RNORM END IF IF (REDOJ .OR. NITER.GE.1) THEN CALL DODVCV(N,M,NP,NQ,NPP, + F,FJACB,FJACD, + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + ETA,ISODR, + WORK(VCV),WORK(SD), + WORK(WRK6),WORK(OMEGA), + WORK(U),WORK(QRAUX),IWORK(JPVT), + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), + WORK(WRK5),WRK,LWRK,ISTOPC) IF (ISTOPC.NE.0) THEN INFO = ISTOPC GO TO 200 END IF DIDVCV = .TRUE. END IF END IF C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS 200 DO 210 I=0,NP-1 WORK(WRK3+I) = IWORK(JPVT+I) IWORK(JPVT+I) = -2 210 CONTINUE IF (REDOJ .OR. NITER.GE.1) THEN DO 220 I=0,NPP-1 J = WORK(WRK3+I) - 1 IF (I.LE.NPP-IRANK-1) THEN IWORK(JPVT+J) = 1 ELSE IWORK(JPVT+J) = -1 END IF 220 CONTINUE IF (NPP.LT.NP) THEN J = NPP-1 DO 230 I=NP-1,0,-1 IF (IFIXB(I+1).EQ.0) THEN IWORK(JPVT+I) = 0 ELSE IWORK(JPVT+I) = IWORK(JPVT+J) J = J - 1 END IF 230 CONTINUE END IF END IF C STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER IF (NITER.GE.1) THEN OLMAVG = OLMAVG/NITER ELSE OLMAVG = ZERO END IF C COMPUTE WEIGHTED SUMS OF SQUARES FOR RETURN TO USER CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,WRK,N) WSS(3) = DDOT(N*NQ,WRK,1,WRK,1) IF (ISODR) THEN CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) WSS(2) = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) ELSE WSS(2) = ZERO END IF WSS(1) = WSS(2) + WSS(3) ACCESS = .FALSE. CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, + WORK,LWORK,IWORK,LIWORK, + ACCESS,ISODR, + JPVT,OMEGA,U,QRAUX,SD,VCV, + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, + NNZW,NPP, + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + WSS,RVAR,IDF, + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) C ENCODE EXISTENCE OF QUESTIONABLE RESULTS INTO INFO IF (INFO.LE.9 .OR. INFO.GE.60000) THEN IF (MSGB(1).EQ.1 .OR. MSGD(1).EQ.1) THEN INFO = INFO + 1000 END IF IF (ISTOP.NE.0) THEN INFO = INFO + 100 END IF IF (IRANK.GE.1) THEN IF (NPP.GT.IRANK) THEN INFO = INFO + 10 ELSE INFO = INFO + 20 END IF END IF END IF C PRINT FINAL SUMMARY IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN IFLAG = 3 IF (IPR3.GE.3. AND. LUNRPT.NE.LUDFLT) THEN NPR = 2 ELSE NPR = 1 END IF IF (IPR3.GE.6) THEN IPR = 2 ELSE IPR = 2 - MOD(IPR3,2) END IF LUNR = LUNRPT DO 240 I=1,NPR CALL DODPCR(IPR,LUNR, + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + N,M,NP,NQ,NPP,NNZW, + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + IWORK(JPVT),IFIXX,LDIFX, + SSF,TT,LDTT,STPB,STPD,LDSTPD, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,RVAR,IDF,WORK(SD), + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) IF (IPR3.GE.5) THEN IPR = 2 ELSE IPR = 1 END IF LUNR = LUDFLT 240 CONTINUE END IF RETURN END *DODPC1 SUBROUTINE DODPC1 + (IPR,LUNRPT, + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + MSGB1,MSGB,MSGD1,MSGD, + N,M,NP,NQ,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + Y,LDY,WE,LDWE,LD2WE,PNLTY, + BETA,IFIXB,SSF,STPB, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS) C***BEGIN PROLOGUE DODPC1 C***REFER TO DODR,DODRC C***ROUTINES CALLED DHSTEP C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE GENERATE INITIAL SUMMARY REPORT C***END PROLOGUE DODPC1 C...SCALAR ARGUMENTS DOUBLE PRECISION + PARTOL,PNLTY,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS INTEGER + IPR,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, + LUNRPT,M,MAXIT,MSGB1,MSGD1,N,NETA,NNZW,NP,NPP,NQ LOGICAL + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),DELTA(N,M),SSF(NP),STPB(NP),STPD(LDSTPD,M), + TT(LDTT,M),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),X(LDX,M), + Y(LDY,NQ) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ,NP),MSGD(NQ,M) C...LOCAL SCALARS DOUBLE PRECISION + TEMP1,TEMP2,TEMP3,ZERO INTEGER + I,ITEMP,J,JOB1,JOB2,JOB3,JOB4,JOB5,L C...LOCAL ARRAYS CHARACTER TEMPC0*2,TEMPC1*5,TEMPC2*13 C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DHSTEP EXTERNAL + DHSTEP C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MIN C...DATA STATEMENTS DATA + ZERO + /0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). C BETA: THE FUNCTION PARAMETERS. C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD DIFFERENCES C (CDJAC=FALSE). C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT C (CHKJAC=FALSE). C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). C I: AN INDEXING VARIABLE. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=FALSE). C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C ITEMP: A TEMPORARY INTEGER VALUE. C J: AN INDEXING VARIABLE. C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C JOB1: THE 1ST DIGIT (FROM THE LEFT) OF VARIABLE JOB. C JOB2: THE 2ND DIGIT (FROM THE LEFT) OF VARIABLE JOB. C JOB3: THE 3RD DIGIT (FROM THE LEFT) OF VARIABLE JOB. C JOB4: THE 4TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. C JOB5: THE 5TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. C L: AN INDEXING VARIABLE. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LDX: THE LEADING DIMENSION OF ARRAY X. C LDY: THE LEADING DIMENSION OF ARRAY Y. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C LUNRPT: THE LOGICAL UNIT NUMBER FOR THE COMPUTATION REPORTS. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C A NEGATIVE VALUE INDICATES THAT NETA WAS ESTIMATED BY C ODRPACK. A POSITIVE VALUE INDICTES THE VALUE WAS SUPPLIED C BY THE USER. C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C SSF: THE SCALING VALUES FOR BETA. C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO BETA. C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO DELTA. C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION C DIAMETER. C TEMPC0: A TEMPORARY CHARACTER*2 VALUE. C TEMPC1: A TEMPORARY CHARACTER*5 VALUE. C TEMPC2: A TEMPORARY CHARACTER*13 VALUE. C TEMP1: A TEMPORARY DOUBLE PRECISION VALUE. C TEMP2: A TEMPORARY DOUBLE PRECISION VALUE. C TEMP3: A TEMPORARY DOUBLE PRECISION VALUE. C TT: THE SCALING VALUES FOR DELTA. C WD: THE DELTA WEIGHTS. C WE: THE EPSILON WEIGHTS. C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. C X: THE EXPLANATORY VARIABLE. C Y: THE RESPONSE VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DODPC1 C PRINT PROBLEM SIZE SPECIFICATION WRITE (LUNRPT,1000) N,NNZW,NQ,M,NP,NPP C PRINT CONTROL VALUES JOB1 = JOB/10000 JOB2 = MOD(JOB,10000)/1000 JOB3 = MOD(JOB,1000)/100 JOB4 = MOD(JOB,100)/10 JOB5 = MOD(JOB,10) WRITE (LUNRPT,1100) JOB IF (RESTRT) THEN WRITE (LUNRPT,1110) JOB1 ELSE WRITE (LUNRPT,1111) JOB1 END IF IF (ISODR) THEN IF (INITD) THEN WRITE (LUNRPT,1120) JOB2 ELSE WRITE (LUNRPT,1121) JOB2 END IF ELSE WRITE (LUNRPT,1122) JOB2,JOB5 END IF IF (DOVCV) THEN WRITE (LUNRPT,1130) JOB3 IF (REDOJ) THEN WRITE (LUNRPT,1131) ELSE WRITE (LUNRPT,1132) END IF ELSE WRITE (LUNRPT,1133) JOB3 END IF IF (ANAJAC) THEN WRITE (LUNRPT,1140) JOB4 IF (CHKJAC) THEN IF (MSGB1.GE.1 .OR. MSGD1.GE.1) THEN WRITE (LUNRPT,1141) ELSE WRITE (LUNRPT,1142) END IF ELSE WRITE (LUNRPT,1143) END IF ELSE IF (CDJAC) THEN WRITE (LUNRPT,1144) JOB4 ELSE WRITE (LUNRPT,1145) JOB4 END IF IF (ISODR) THEN IF (IMPLCT) THEN WRITE (LUNRPT,1150) JOB5 ELSE WRITE (LUNRPT,1151) JOB5 END IF ELSE WRITE (LUNRPT,1152) JOB5 END IF IF (NETA.LT.0) THEN WRITE (LUNRPT,1200) -NETA ELSE WRITE (LUNRPT,1210) NETA END IF WRITE (LUNRPT,1300) TAUFAC C PRINT STOPPING CRITERIA WRITE (LUNRPT,1400) SSTOL,PARTOL,MAXIT C PRINT INITIAL SUM OF SQUARES IF (IMPLCT) THEN WRITE (LUNRPT,1500) WSSDEL IF (ISODR) THEN WRITE (LUNRPT,1510) WSS,WSSEPS,PNLTY END IF ELSE WRITE (LUNRPT,1600) WSS IF (ISODR) THEN WRITE (LUNRPT,1610) WSSDEL,WSSEPS END IF END IF IF (IPR.GE.2) THEN C PRINT FUNCTION PARAMETER DATA WRITE (LUNRPT,4000) IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN WRITE (LUNRPT,4110) ELSE IF (ANAJAC) THEN WRITE (LUNRPT,4120) ELSE WRITE (LUNRPT,4200) END IF DO 130 J=1,NP IF (IFIXB(1).LT.0) THEN TEMPC1 = ' NO' ELSE IF (IFIXB(J).NE.0) THEN TEMPC1 = ' NO' ELSE TEMPC1 = ' YES' END IF END IF IF (ANAJAC) THEN IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN ITEMP = -1 DO 110 L=1,NQ ITEMP = MAX(ITEMP,MSGB(L,J)) 110 CONTINUE IF (ITEMP.LE.-1) THEN TEMPC2 = ' UNCHECKED' ELSE IF (ITEMP.EQ.0) THEN TEMPC2 = ' VERIFIED' ELSE IF (ITEMP.GE.1) THEN TEMPC2 = ' QUESTIONABLE' END IF ELSE TEMPC2 = ' ' END IF ELSE TEMPC2 = ' ' END IF IF (SSF(1).LT.ZERO) THEN TEMP1 = ABS(SSF(1)) ELSE TEMP1 = SSF(J) END IF IF (ANAJAC) THEN WRITE (LUNRPT,4310) J,BETA(J),TEMPC1,TEMP1,TEMPC2 ELSE IF (CDJAC) THEN TEMP2 = DHSTEP(1,NETA,1,J,STPB,1) ELSE TEMP2 = DHSTEP(0,NETA,1,J,STPB,1) END IF WRITE (LUNRPT,4320) J,BETA(J),TEMPC1,TEMP1,TEMP2 END IF 130 CONTINUE C PRINT EXPLANATORY VARIABLE DATA IF (ISODR) THEN WRITE (LUNRPT,2010) IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN WRITE (LUNRPT,2110) ELSE IF (ANAJAC) THEN WRITE (LUNRPT,2120) ELSE WRITE (LUNRPT,2130) END IF ELSE WRITE (LUNRPT,2020) WRITE (LUNRPT,2140) END IF IF (ISODR) THEN DO 240 J = 1,M TEMPC0 = '1,' DO 230 I=1,N,N-1 IF (IFIXX(1,1).LT.0) THEN TEMPC1 = ' NO' ELSE IF (LDIFX.EQ.1) THEN IF (IFIXX(1,J).EQ.0) THEN TEMPC1 = ' YES' ELSE TEMPC1 = ' NO' END IF ELSE IF (IFIXX(I,J).EQ.0) THEN TEMPC1 = ' YES' ELSE TEMPC1 = ' NO' END IF END IF END IF IF (TT(1,1).LT.ZERO) THEN TEMP1 = ABS(TT(1,1)) ELSE IF (LDTT.EQ.1) THEN TEMP1 = TT(1,J) ELSE TEMP1 = TT(I,J) END IF END IF IF (WD(1,1,1).LT.ZERO) THEN TEMP2 = ABS(WD(1,1,1)) ELSE IF (LDWD.EQ.1) THEN IF (LD2WD.EQ.1) THEN TEMP2 = WD(1,1,J) ELSE TEMP2 = WD(1,J,J) END IF ELSE IF (LD2WD.EQ.1) THEN TEMP2 = WD(I,1,J) ELSE TEMP2 = WD(I,J,J) END IF END IF END IF IF (ANAJAC) THEN IF (CHKJAC .AND. + (((MSGB1.GE.1) .OR. (MSGD1.GE.1)) .AND. + (I.EQ.1))) THEN ITEMP = -1 DO 210 L=1,NQ ITEMP = MAX(ITEMP,MSGD(L,J)) 210 CONTINUE IF (ITEMP.LE.-1) THEN TEMPC2 = ' UNCHECKED' ELSE IF (ITEMP.EQ.0) THEN TEMPC2 = ' VERIFIED' ELSE IF (ITEMP.GE.1) THEN TEMPC2 = ' QUESTIONABLE' END IF ELSE TEMPC2 = ' ' END IF IF (M.LE.9) THEN WRITE (LUNRPT,5110) + TEMPC0,J,X(I,J), + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 ELSE WRITE (LUNRPT,5120) + TEMPC0,J,X(I,J), + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 END IF ELSE TEMPC2 = ' ' IF (CDJAC) THEN TEMP3 = DHSTEP(1,NETA,I,J,STPD,LDSTPD) ELSE TEMP3 = DHSTEP(0,NETA,I,J,STPD,LDSTPD) END IF IF (M.LE.9) THEN WRITE (LUNRPT,5210) + TEMPC0,J,X(I,J), + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 ELSE WRITE (LUNRPT,5220) + TEMPC0,J,X(I,J), + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 END IF END IF TEMPC0 = 'N,' 230 CONTINUE IF (J.LT.M) WRITE (LUNRPT,6000) 240 CONTINUE ELSE DO 260 J = 1,M TEMPC0 = '1,' DO 250 I=1,N,N-1 IF (M.LE.9) THEN WRITE (LUNRPT,5110) + TEMPC0,J,X(I,J) ELSE WRITE (LUNRPT,5120) + TEMPC0,J,X(I,J) END IF TEMPC0 = 'N,' 250 CONTINUE IF (J.LT.M) WRITE (LUNRPT,6000) 260 CONTINUE END IF C PRINT RESPONSE VARIABLE DATA AND OBSERVATION ERROR WEIGHTS IF (.NOT.IMPLCT) THEN WRITE (LUNRPT,3000) WRITE (LUNRPT,3100) DO 310 L=1,NQ TEMPC0 = '1,' DO 300 I=1,N,N-1 IF (WE(1,1,1).LT.ZERO) THEN TEMP1 = ABS(WE(1,1,1)) ELSE IF (LDWE.EQ.1) THEN IF (LD2WE.EQ.1) THEN TEMP1 = WE(1,1,L) ELSE TEMP1 = WE(1,L,L) END IF ELSE IF (LD2WE.EQ.1) THEN TEMP1 = WE(I,1,L) ELSE TEMP1 = WE(I,L,L) END IF END IF IF (NQ.LE.9) THEN WRITE (LUNRPT,5110) + TEMPC0,L,Y(I,L),TEMP1 ELSE WRITE (LUNRPT,5120) + TEMPC0,L,Y(I,L),TEMP1 END IF TEMPC0 = 'N,' 300 CONTINUE IF (L.LT.NQ) WRITE (LUNRPT,6000) 310 CONTINUE END IF END IF RETURN C FORMAT STATEMENTS 1000 FORMAT + (/' --- PROBLEM SIZE:'/ + ' N = ',I5, + ' (NUMBER WITH NONZERO WEIGHT = ',I5,')'/ + ' NQ = ',I5/ + ' M = ',I5/ + ' NP = ',I5, + ' (NUMBER UNFIXED = ',I5,')') 1100 FORMAT + (/' --- CONTROL VALUES:'/ + ' JOB = ',I5.5/ + ' = ABCDE, WHERE') 1110 FORMAT + (' A=',I1,' ==> FIT IS A RESTART.') 1111 FORMAT + (' A=',I1,' ==> FIT IS NOT A RESTART.') 1120 FORMAT + (' B=',I1,' ==> DELTAS ARE INITIALIZED', + ' TO ZERO.') 1121 FORMAT + (' B=',I1,' ==> DELTAS ARE INITIALIZED', + ' BY USER.') 1122 FORMAT + (' B=',I1,' ==> DELTAS ARE FIXED AT', + ' ZERO SINCE E=',I1,'.') 1130 FORMAT + (' C=',I1,' ==> COVARIANCE MATRIX WILL', + ' BE COMPUTED USING') 1131 FORMAT + (' DERIVATIVES RE-', + 'EVALUATED AT THE SOLUTION.') 1132 FORMAT + (' DERIVATIVES FROM THE', + ' LAST ITERATION.') 1133 FORMAT + (' C=',I1,' ==> COVARIANCE MATRIX WILL', + ' NOT BE COMPUTED.') 1140 FORMAT + (' D=',I1,' ==> DERIVATIVES ARE', + ' SUPPLIED BY USER.') 1141 FORMAT + (' DERIVATIVES WERE CHECKED.'/ + ' RESULTS APPEAR QUESTIONABLE.') 1142 FORMAT + (' DERIVATIVES WERE CHECKED.'/ + ' RESULTS APPEAR CORRECT.') 1143 FORMAT + (' DERIVATIVES WERE NOT', + ' CHECKED.') 1144 FORMAT + (' D=',I1,' ==> DERIVATIVES ARE', + ' ESTIMATED BY CENTRAL', + ' DIFFERENCES.') 1145 FORMAT + (' D=',I1,' ==> DERIVATIVES ARE', + ' ESTIMATED BY FORWARD', + ' DIFFERENCES.') 1150 FORMAT + (' E=',I1,' ==> METHOD IS IMPLICIT ODR.') 1151 FORMAT + (' E=',I1,' ==> METHOD IS EXPLICIT ODR.') 1152 FORMAT + (' E=',I1,' ==> METHOD IS EXPLICIT OLS.') 1200 FORMAT + (' NDIGIT = ',I5,' (ESTIMATED BY ODRPACK)') 1210 FORMAT + (' NDIGIT = ',I5,' (SUPPLIED BY USER)') 1300 FORMAT + (' TAUFAC = ',1P,D12.2) 1400 FORMAT + (/' --- STOPPING CRITERIA:'/ + ' SSTOL = ',1P,D12.2, + ' (SUM OF SQUARES STOPPING TOLERANCE)'/ + ' PARTOL = ',1P,D12.2, + ' (PARAMETER STOPPING TOLERANCE)'/ + ' MAXIT = ',I5, + ' (MAXIMUM NUMBER OF ITERATIONS)') 1500 FORMAT + (/' --- INITIAL SUM OF SQUARED WEIGHTED DELTAS =', + 17X,1P,D17.8) 1510 FORMAT + ( ' INITIAL PENALTY FUNCTION VALUE =',1P,D17.8/ + ' PENALTY TERM =',1P,D17.8/ + ' PENALTY PARAMETER =',1P,D10.1) 1600 FORMAT + (/' --- INITIAL WEIGHTED SUM OF SQUARES =', + 17X,1P,D17.8) 1610 FORMAT + ( ' SUM OF SQUARED WEIGHTED DELTAS =',1P,D17.8/ + ' SUM OF SQUARED WEIGHTED EPSILONS =',1P,D17.8) 2010 FORMAT + (/' --- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:') 2020 FORMAT + (/' --- EXPLANATORY VARIABLE SUMMARY:') 2110 FORMAT + (/' INDEX X(I,J) DELTA(I,J) FIXED', + ' SCALE WEIGHT DERIVATIVE'/ + ' ', + ' ASSESSMENT'/, + ' (I,J) (IFIXX)', + ' (SCLD) (WD) '/) 2120 FORMAT + (/' INDEX X(I,J) DELTA(I,J) FIXED', + ' SCALE WEIGHT '/ + ' ', + ' '/, + ' (I,J) (IFIXX)', + ' (SCLD) (WD) '/) 2130 FORMAT + (/' INDEX X(I,J) DELTA(I,J) FIXED', + ' SCALE WEIGHT DERIVATIVE'/ + ' ', + ' STEP SIZE'/, + ' (I,J) (IFIXX)', + ' (SCLD) (WD) (STPD)'/) 2140 FORMAT + (/' INDEX X(I,J)'/ + ' (I,J) '/) 3000 FORMAT + (/' --- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT', + ' SUMMARY:') 3100 FORMAT + (/' INDEX Y(I,L) WEIGHT'/ + ' (I,L) (WE)'/) 4000 FORMAT + (/' --- FUNCTION PARAMETER SUMMARY:') 4110 FORMAT + (/' INDEX BETA(K) FIXED SCALE', + ' DERIVATIVE'/ + ' ', + ' ASSESSMENT'/, + ' (K) (IFIXB) (SCLB)', + ' '/) 4120 FORMAT + (/' INDEX BETA(K) FIXED SCALE', + ' '/ + ' ', + ' '/, + ' (K) (IFIXB) (SCLB)', + ' '/) 4200 FORMAT + (/' INDEX BETA(K) FIXED SCALE', + ' DERIVATIVE'/ + ' ', + ' STEP SIZE'/, + ' (K) (IFIXB) (SCLB)', + ' (STPB)'/) 4310 FORMAT + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,A13) 4320 FORMAT + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,D13.5) 5110 FORMAT + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,A13) 5120 FORMAT + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,A13) 5210 FORMAT + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) 5220 FORMAT + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) 6000 FORMAT + (' ') END *DODPC2 SUBROUTINE DODPC2 + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + PNLTY, + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) C***BEGIN PROLOGUE DODPC2 C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE GENERATE ITERATION REPORTS C***END PROLOGUE DODPC2 C...SCALAR ARGUMENTS DOUBLE PRECISION + ACTRED,ALPHA,PNLTY,PNORM,PRERED,TAU,WSS INTEGER + IPR,LUNRPT,NFEV,NITER,NP LOGICAL + FSTITR,IMPLCT,PRTPEN C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP) C...LOCAL SCALARS DOUBLE PRECISION + RATIO,ZERO INTEGER + J,K,L CHARACTER GN*3 C...INTRINSIC FUNCTIONS INTRINSIC + MIN C...DATA STATEMENTS DATA + ZERO + /0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. C BETA: THE FUNCTION PARAMETERS. C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST C ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). C GN: THE CHARACTER*3 VARIABLE INDICATING WHETHER A GAUSS-NEWTON C STEP WAS TAKEN. C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. C J: AN INDEXING VARIABLE. C K: AN INDEXING VARIABLE. C L: AN INDEXING VARIABLE. C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NITER: THE NUMBER OF ITERATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT C (PRTPEN=FALSE). C RATIO: THE RATIO OF TAU TO PNORM. C TAU: THE TRUST REGION DIAMETER. C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DODPC2 IF (FSTITR) THEN IF (IPR.EQ.1) THEN IF (IMPLCT) THEN WRITE (LUNRPT,1121) ELSE WRITE (LUNRPT,1122) END IF ELSE IF (IMPLCT) THEN WRITE (LUNRPT,1131) ELSE WRITE (LUNRPT,1132) END IF END IF END IF IF (PRTPEN) THEN WRITE (LUNRPT,1133) PNLTY END IF IF (ALPHA.EQ.ZERO) THEN GN = 'YES' ELSE GN = ' NO' END IF IF (PNORM.NE.ZERO) THEN RATIO = TAU/PNORM ELSE RATIO = ZERO END IF IF (IPR.EQ.1) THEN WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + RATIO,GN ELSE J = 1 K = MIN(3,NP) IF (J.EQ.K) THEN WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + RATIO,GN,J,BETA(J) ELSE WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED, + RATIO,GN,J,K,(BETA(L),L=J,K) END IF IF (NP.GT.3) THEN DO 10 J=4,NP,3 K = MIN(J+2,NP) IF (J.EQ.K) THEN WRITE (LUNRPT,1151) J,BETA(J) ELSE WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K) END IF 10 CONTINUE END IF END IF RETURN C FORMAT STATEMENTS 1121 FORMAT + (// + ' CUM. PENALTY ACT. REL. PRED. REL.'/ + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', + ' G-N'/ + ' NUM. EVALS VALUE REDUCTION REDUCTION', + ' TAU/PNORM STEP'/ + ' ---- ------ ----------- ----------- -----------', + ' --------- ----') 1122 FORMAT + (// + ' CUM. ACT. REL. PRED. REL.'/ + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + ' G-N'/ + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + ' TAU/PNORM STEP'/ + ' ---- ------ ----------- ----------- -----------', + ' --------- ----'/) 1131 FORMAT + (// + ' CUM. PENALTY ACT. REL. PRED. REL.'/ + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', + ' G-N BETA -------------->'/ + ' NUM. EVALS VALUE REDUCTION REDUCTION', + ' TAU/PNORM STEP INDEX VALUE'/ + ' ---- ------ ----------- ----------- -----------', + ' --------- ---- ----- -----') 1132 FORMAT + (// + ' CUM. ACT. REL. PRED. REL.'/ + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + ' G-N BETA -------------->'/ + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + ' TAU/PNORM STEP INDEX VALUE'/ + ' ---- ------ ----------- ----------- -----------', + ' --------- ---- ----- -----'/) 1133 FORMAT + (/' PENALTY PARAMETER VALUE = ', 1P,E10.1) 1141 FORMAT + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8) 1142 FORMAT + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8) 1151 FORMAT + (76X,I3,1P,D16.8) 1152 FORMAT + (70X,I3,' TO',I3,1P,3D16.8) END *DODPC3 SUBROUTINE DODPC3 + (IPR,LUNRPT, + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + N,M,NP,NQ,NPP, + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + WSS,WSSDEL,WSSEPS,PNLTY,RVAR,IDF, + BETA,SDBETA,IFIXB2,F,DELTA) C***BEGIN PROLOGUE DODPC3 C***REFER TO DODR,DODRC C***ROUTINES CALLED DPPT C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE GENERATE FINAL SUMMARY REPORT C***END PROLOGUE DODPC3 C...SCALAR ARGUMENTS DOUBLE PRECISION + PNLTY,RCOND,RVAR,WSS,WSSDEL,WSSEPS INTEGER + IDF,INFO,IPR,IRANK,ISTOP,LUNRPT,M, + N,NFEV,NITER,NJEV,NP,NPP,NQ LOGICAL + ANAJAC,DIDVCV,DOVCV,IMPLCT,ISODR,REDOJ C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP) INTEGER + IFIXB2(NP) C...LOCAL SCALARS DOUBLE PRECISION + TVAL INTEGER + D1,D2,D3,D4,D5,I,J,K,L,NPLM1 CHARACTER FMT1*90 C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DPPT EXTERNAL + DPPT C...INTRINSIC FUNCTIONS INTRINSIC + MIN,MOD C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). C BETA: THE FUNCTION PARAMETERS. C D1: THE FIRST DIGIT OF INFO. C D2: THE SECOND DIGIT OF INFO. C D3: THE THIRD DIGIT OF INFO. C D4: THE FOURTH DIGIT OF INFO. C D5: THE FIFTH DIGIT OF INFO. C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). C F: THE ESTIMATED VALUES OF EPSILON. C FMT1: A CHARACTER*90 VARIABLE USED FOR FORMATS. C I: AN INDEXING VARIABLE. C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C IFIXB2: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA WERE C ESTIMATED, FIXED, OR DROPPED BECAUSE THEY CAUSED RANK C DEFICIENCY, CORRESPONDING TO VALUES OF IFIXB2 EQUALING 1, C 0, AND -1, RESPECTIVELY. IF IFIXB2 IS -2, THEN NO ATTEMPT C WAS MADE TO ESTIMATE THE PARAMETERS BECAUSE MAXIT = 0. C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C IPR: THE VARIABLE INDICATING WHAT IS TO BE PRINTED. C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C J: AN INDEXING VARIABLE. C K: AN INDEXING VARIABLE. C L: AN INDEXING VARIABLE. C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NITER: THE NUMBER OF ITERATIONS. C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NPLM1: THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE. C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS C TO BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE C MATRIX (REDOJ=TRUE) OR NOT (REDOJ=FALSE). C RVAR: THE RESIDUAL VARIANCE. C SDBETA: THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS. C TVAL: THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE C T DISTRIBUTION. C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. C***FIRST EXECUTABLE STATEMENT DODPC3 D1 = INFO/10000 D2 = MOD(INFO,10000)/1000 D3 = MOD(INFO,1000)/100 D4 = MOD(INFO,100)/10 D5 = MOD(INFO,10) C PRINT STOPPING CONDITIONS WRITE (LUNRPT,1000) IF (INFO.LE.9) THEN IF (INFO.EQ.1) THEN WRITE (LUNRPT,1011) INFO ELSE IF (INFO.EQ.2) THEN WRITE (LUNRPT,1012) INFO ELSE IF (INFO.EQ.3) THEN WRITE (LUNRPT,1013) INFO ELSE IF (INFO.EQ.4) THEN WRITE (LUNRPT,1014) INFO ELSE IF (INFO.LE.9) THEN WRITE (LUNRPT,1015) INFO END IF ELSE IF (INFO.LE.9999) THEN C PRINT WARNING DIAGNOSTICS WRITE (LUNRPT,1020) INFO IF (D2.EQ.1) WRITE (LUNRPT,1021) IF (D3.EQ.1) WRITE (LUNRPT,1022) IF (D4.EQ.1) WRITE (LUNRPT,1023) IF (D4.EQ.2) WRITE (LUNRPT,1024) IF (D5.EQ.1) THEN WRITE (LUNRPT,1031) ELSE IF (D5.EQ.2) THEN WRITE (LUNRPT,1032) ELSE IF (D5.EQ.3) THEN WRITE (LUNRPT,1033) ELSE IF (D5.EQ.4) THEN WRITE (LUNRPT,1034) ELSE IF (D5.LE.9) THEN WRITE (LUNRPT,1035) D5 END IF ELSE C PRINT ERROR MESSAGES WRITE (LUNRPT,1040) INFO IF (D1.EQ.5) THEN WRITE (LUNRPT,1042) IF (D2.NE.0) WRITE (LUNRPT,1043) D2 IF (D3.EQ.3) THEN WRITE (LUNRPT,1044) D3 ELSE IF (D3.NE.0) THEN WRITE (LUNRPT,1045) D3 END IF ELSE IF (D1.EQ.6) THEN WRITE (LUNRPT,1050) ELSE WRITE (LUNRPT,1060) D1 END IF END IF C PRINT MISC. STOPPING INFO WRITE (LUNRPT,1300) NITER WRITE (LUNRPT,1310) NFEV IF (ANAJAC) WRITE (LUNRPT,1320) NJEV WRITE (LUNRPT,1330) IRANK WRITE (LUNRPT,1340) RCOND WRITE (LUNRPT,1350) ISTOP C PRINT FINAL SUM OF SQUARES IF (IMPLCT) THEN WRITE (LUNRPT,2000) WSSDEL IF (ISODR) THEN WRITE (LUNRPT,2010) WSS,WSSEPS,PNLTY END IF ELSE WRITE (LUNRPT,2100) WSS IF (ISODR) THEN WRITE (LUNRPT,2110) WSSDEL,WSSEPS END IF END IF IF (DIDVCV) THEN WRITE (LUNRPT,2200) SQRT(RVAR),IDF END IF NPLM1 = 3 C PRINT ESTIMATED BETA'S, AND, C IF, FULL RANK, THEIR STANDARD ERRORS WRITE (LUNRPT,3000) IF (DIDVCV) THEN WRITE (LUNRPT,7300) TVAL = DPPT(0.975D0,IDF) DO 10 J=1,NP IF (IFIXB2(J).GE.1) THEN WRITE (LUNRPT,8400) J,BETA(J),SDBETA(J), + BETA(J)-TVAL*SDBETA(J), + BETA(J)+TVAL*SDBETA(J) ELSE IF (IFIXB2(J).EQ.0) THEN WRITE (LUNRPT,8600) J,BETA(J) ELSE WRITE (LUNRPT,8700) J,BETA(J) END IF 10 CONTINUE IF (.NOT.REDOJ) WRITE (LUNRPT,7310) ELSE IF (DOVCV) THEN IF (D1.LE.5) THEN WRITE (LUNRPT,7410) ELSE WRITE (LUNRPT,7420) END IF END IF IF ((IRANK.EQ.0 .AND. NPP.EQ.NP) .OR. NITER.EQ.0) THEN IF (NP.EQ.1) THEN WRITE (LUNRPT,7100) ELSE WRITE (LUNRPT,7200) END IF DO 20 J=1,NP,NPLM1+1 K = MIN(J+NPLM1,NP) IF (K.EQ.J) THEN WRITE (LUNRPT,8100) J,BETA(J) ELSE WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K) END IF 20 CONTINUE IF (NITER.GE.1) THEN WRITE (LUNRPT,8800) ELSE WRITE (LUNRPT,8900) END IF ELSE WRITE (LUNRPT,7500) DO 30 J=1,NP IF (IFIXB2(J).GE.1) THEN WRITE (LUNRPT,8500) J,BETA(J) ELSE IF (IFIXB2(J).EQ.0) THEN WRITE (LUNRPT,8600) J,BETA(J) ELSE WRITE (LUNRPT,8700) J,BETA(J) END IF 30 CONTINUE END IF END IF IF (IPR.EQ.1) RETURN C PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF C COLUMNS OF DATA IN EPSILON AND DELTA IS LESS THAN OR EQUAL TO THREE. IF (IMPLCT .AND. (M.LE.4)) THEN WRITE (LUNRPT,4100) WRITE (FMT1,9110) M WRITE (LUNRPT,FMT1) (J,J=1,M) DO 40 I=1,N WRITE (LUNRPT,4130) I,(DELTA(I,J),J=1,M) 40 CONTINUE ELSE IF (ISODR .AND. (NQ+M.LE.4)) THEN WRITE (LUNRPT,4110) WRITE (FMT1,9120) NQ,M WRITE (LUNRPT,FMT1) (L,L=1,NQ),(J,J=1,M) DO 50 I=1,N WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ),(DELTA(I,J),J=1,M) 50 CONTINUE ELSE IF (.NOT.ISODR .AND. ((NQ.GE.2) .AND. (NQ.LE.4))) THEN WRITE (LUNRPT,4120) WRITE (FMT1,9130) NQ WRITE (LUNRPT,FMT1) (L,L=1,NQ) DO 60 I=1,N WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ) 60 CONTINUE ELSE C PRINT EPSILON'S AND DELTA'S SEPARATELY IF (.NOT.IMPLCT) THEN C PRINT EPSILON'S DO 80 J=1,NQ WRITE (LUNRPT,4200) J IF (N.EQ.1) THEN WRITE (LUNRPT,7100) ELSE WRITE (LUNRPT,7200) END IF DO 70 I=1,N,NPLM1+1 K = MIN(I+NPLM1,N) IF (I.EQ.K) THEN WRITE (LUNRPT,8100) I,F(I,J) ELSE WRITE (LUNRPT,8200) I,K,(F(L,J),L=I,K) END IF 70 CONTINUE 80 CONTINUE END IF C PRINT DELTA'S IF (ISODR) THEN DO 100 J=1,M WRITE (LUNRPT,4300) J IF (N.EQ.1) THEN WRITE (LUNRPT,7100) ELSE WRITE (LUNRPT,7200) END IF DO 90 I=1,N,NPLM1+1 K = MIN(I+NPLM1,N) IF (I.EQ.K) THEN WRITE (LUNRPT,8100) I,DELTA(I,J) ELSE WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K) END IF 90 CONTINUE 100 CONTINUE END IF END IF RETURN C FORMAT STATEMENTS 1000 FORMAT + (/' --- STOPPING CONDITIONS:') 1011 FORMAT + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE.') 1012 FORMAT + (' INFO = ',I5,' ==> PARAMETER CONVERGENCE.') 1013 FORMAT + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE AND', + ' PARAMETER CONVERGENCE.') 1014 FORMAT + (' INFO = ',I5,' ==> ITERATION LIMIT REACHED.') 1015 FORMAT + (' INFO = ',I5,' ==> UNEXPECTED VALUE,', + ' PROBABLY INDICATING'/ + ' INCORRECTLY SPECIFIED', + ' USER INPUT.') 1020 FORMAT + (' INFO = ',I5.4/ + ' = ABCD, WHERE A NONZERO VALUE FOR DIGIT A,', + ' B, OR C INDICATES WHY'/ + ' THE RESULTS MIGHT BE QUESTIONABLE,', + ' AND DIGIT D INDICATES'/ + ' THE ACTUAL STOPPING CONDITION.') 1021 FORMAT + (' A=1 ==> DERIVATIVES ARE', + ' QUESTIONABLE.') 1022 FORMAT + (' B=1 ==> USER SET ISTOP TO', + ' NONZERO VALUE DURING LAST'/ + ' CALL TO SUBROUTINE FCN.') 1023 FORMAT + (' C=1 ==> DERIVATIVES ARE NOT', + ' FULL RANK AT THE SOLUTION.') 1024 FORMAT + (' C=2 ==> DERIVATIVES ARE ZERO', + ' RANK AT THE SOLUTION.') 1031 FORMAT + (' D=1 ==> SUM OF SQUARES CONVERGENCE.') 1032 FORMAT + (' D=2 ==> PARAMETER CONVERGENCE.') 1033 FORMAT + (' D=3 ==> SUM OF SQUARES CONVERGENCE', + ' AND PARAMETER CONVERGENCE.') 1034 FORMAT + (' D=4 ==> ITERATION LIMIT REACHED.') 1035 FORMAT + (' D=',I1,' ==> UNEXPECTED VALUE,', + ' PROBABLY INDICATING'/ + ' INCORRECTLY SPECIFIED', + ' USER INPUT.') 1040 FORMAT + (' INFO = ',I5.5/ + ' = ABCDE, WHERE A NONZERO VALUE FOR A GIVEN', + ' DIGIT INDICATES AN'/ + ' ABNORMAL STOPPING CONDITION.') 1042 FORMAT + (' A=5 ==> USER STOPPED COMPUTATIONS', + ' IN SUBROUTINE FCN.') 1043 FORMAT + (' B=',I1,' ==> COMPUTATIONS WERE', + ' STOPPED DURING THE'/ + ' FUNCTION EVALUATION.') 1044 FORMAT + (' C=',I1,' ==> COMPUTATIONS WERE', + ' STOPPED BECAUSE'/ + ' DERIVATIVES WITH', + ' RESPECT TO DELTA WERE'/ + ' COMPUTED BY', + ' SUBROUTINE FCN WHEN'/ + ' FIT IS OLS.') 1045 FORMAT + (' C=',I1,' ==> COMPUTATIONS WERE', + ' STOPPED DURING THE'/ + ' JACOBIAN EVALUATION.') 1050 FORMAT + (' A=6 ==> NUMERICAL INSTABILITIES', + ' HAVE BEEN DETECTED,'/ + ' POSSIBLY INDICATING', + ' A DISCONTINUITY IN THE'/ + ' DERIVATIVES OR A POOR', + ' POOR CHOICE OF PROBLEM'/ + ' SCALE OR WEIGHTS.') 1060 FORMAT + (' A=',I1,' ==> UNEXPECTED VALUE,', + ' PROBABLY INDICATING'/ + ' INCORRECTLY SPECIFIED', + ' USER INPUT.') 1300 FORMAT + (' NITER = ',I5, + ' (NUMBER OF ITERATIONS)') 1310 FORMAT + (' NFEV = ',I5, + ' (NUMBER OF FUNCTION EVALUATIONS)') 1320 FORMAT + (' NJEV = ',I5, + ' (NUMBER OF JACOBIAN EVALUATIONS)') 1330 FORMAT + (' IRANK = ',I5, + ' (RANK DEFICIENCY)') 1340 FORMAT + (' RCOND = ',1P,D12.2, + ' (INVERSE CONDITION NUMBER)') *1341 FORMAT * + (' ==> POSSIBLY FEWER THAN 2 SIGNIFICANT', * + ' DIGITS IN RESULTS;'/ * + ' SEE ODRPACK REFERENCE', * + ' GUIDE, SECTION 4.C.') 1350 FORMAT + (' ISTOP = ',I5, + ' (RETURNED BY USER FROM', + ' SUBROUTINE FCN)') 2000 FORMAT + (/' --- FINAL SUM OF SQUARED WEIGHTED DELTAS = ', + 17X,1P,D17.8) 2010 FORMAT + ( ' FINAL PENALTY FUNCTION VALUE = ',1P,D17.8/ + ' PENALTY TERM = ',1P,D17.8/ + ' PENALTY PARAMETER = ',1P,D10.1) 2100 FORMAT + (/' --- FINAL WEIGHTED SUMS OF SQUARES = ',17X,1P,D17.8) 2110 FORMAT + ( ' SUM OF SQUARED WEIGHTED DELTAS = ',1P,D17.8/ + ' SUM OF SQUARED WEIGHTED EPSILONS = ',1P,D17.8) 2200 FORMAT + (/' --- RESIDUAL STANDARD DEVIATION = ', + 17X,1P,D17.8/ + ' DEGREES OF FREEDOM =',I5) 3000 FORMAT + (/' --- ESTIMATED BETA(J), J = 1, ..., NP:') 4100 FORMAT + (/' --- ESTIMATED DELTA(I,*), I = 1, ..., N:') 4110 FORMAT + (/' --- ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:') 4120 FORMAT + (/' --- ESTIMATED EPSILON(I), I = 1, ..., N:') 4130 FORMAT(5X,I5,1P,5D16.8) 4200 FORMAT + (/' --- ESTIMATED EPSILON(I,',I3,'), I = 1, ..., N:') 4300 FORMAT + (/' --- ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:') 7100 FORMAT + (/' INDEX VALUE'/) 7200 FORMAT + (/' INDEX VALUE -------------->'/) 7300 FORMAT + (/' BETA S.D. BETA', + ' ---- 95% CONFIDENCE INTERVAL ----'/) 7310 FORMAT + (/' N.B. STANDARD ERRORS AND CONFIDENCE INTERVALS ARE', + ' COMPUTED USING'/ + ' DERIVATIVES CALCULATED AT THE BEGINNING', + ' OF THE LAST ITERATION,'/ + ' AND NOT USING DERIVATIVES RE-EVALUATED AT THE', + ' FINAL SOLUTION.') 7410 FORMAT + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', + ' NOT COMPUTED BECAUSE'/ + ' THE DERIVATIVES WERE NOT AVAILABLE. EITHER MAXIT', + ' IS 0 AND THE THIRD'/ + ' DIGIT OF JOB IS GREATER THAN 1, OR THE MOST', + ' RECENTLY TRIED VALUES OF'/ + ' BETA AND/OR X+DELTA WERE IDENTIFIED AS', + ' UNACCEPTABLE BY USER SUPPLIED'/ + ' SUBROUTINE FCN.') 7420 FORMAT + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', + ' NOT COMPUTED.'/ + ' (SEE INFO ABOVE.)') 7500 FORMAT + (/' BETA STATUS') 8100 FORMAT + (11X,I5,1P,D16.8) 8200 FORMAT + (3X,I5,' TO',I5,1P,7D16.8) 8400 FORMAT + (3X,I5,1X,1P,D16.8,3X,D12.4,3X,D16.8,1X,'TO',D16.8) 8500 FORMAT + (3X,I5,1X,1P,D16.8,6X,'ESTIMATED') 8600 FORMAT + (3X,I5,1X,1P,D16.8,6X,' FIXED') 8700 FORMAT + (3X,I5,1X,1P,D16.8,6X,' DROPPED') 8800 FORMAT + (/' N.B. NO PARAMETERS WERE FIXED BY THE USER OR', + ' DROPPED AT THE LAST'/ + ' ITERATION BECAUSE THEY CAUSED THE MODEL TO BE', + ' RANK DEFICIENT.') 8900 FORMAT + (/' N.B. NO CHANGE WAS MADE TO THE USER SUPPLIED PARAMETER', + ' VALUES BECAUSE'/ + ' MAXIT=0.') 9110 FORMAT + ('(/'' I'',', + I2,'('' DELTA(I,'',I1,'')'')/)') 9120 FORMAT + ('(/'' I'',', + I2,'('' EPSILON(I,'',I1,'')''),', + I2,'('' DELTA(I,'',I1,'')'')/)') 9130 FORMAT + ('(/'' I'',', + I2,'('' EPSILON(I,'',I1,'')'')/)') END *DODPCR SUBROUTINE DODPCR + (IPR,LUNRPT, + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, + N,M,NP,NQ,NPP,NNZW, + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, + WE,LDWE,LD2WE,WD,LDWD,LD2WD, + IFIXB,IFIXX,LDIFX, + SSF,TT,LDTT,STPB,STPD,LDSTPD, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,RVAR,IDF,SDBETA, + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) C***BEGIN PROLOGUE DODPCR C***REFER TO DODR,DODRC C***ROUTINES CALLED DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE GENERATE COMPUTATION REPORTS C***END PROLOGUE DODPCR C...SCALAR ARGUMENTS DOUBLE PRECISION + ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR, + SSTOL,TAU,TAUFAC INTEGER + IDF,IFLAG,INFO,IPR,IRANK,ISTOP,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE, + LDX,LDY,LD2WD,LD2WE,LUNRPT,M,MAXIT,N,NETA,NFEV, + NITER,NJEV,NNZW,NP,NPP,NQ LOGICAL + DIDVCV,FSTITR,HEAD,PRTPEN C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP),SSF(NP), + STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WSS(3),X(LDX,M),Y(LDY,NQ) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ*NP+1),MSGD(NQ*M+1) C...LOCAL SCALARS DOUBLE PRECISION + PNLTY LOGICAL + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT CHARACTER TYP*3 C...EXTERNAL SUBROUTINES EXTERNAL + DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). C BETA: THE FUNCTION PARAMETERS. C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD C DIFFERENCES (CDJAC=FALSE). C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT C (CHKJAC=FALSE). C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFLAG: THE VARIABLE DESIGNATING WHAT IS TO BE PRINTED. C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=FALSE). C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND C COMPUTATIONAL METHOD. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LDX: THE LEADING DIMENSION OF ARRAY X. C LDY: THE LEADING DIMENSION OF ARRAY Y. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NITER: THE NUMBER OF ITERATIONS. C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT C (PRTPEN=FALSE). C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C RVAR: THE RESIDUAL VARIANCE. C SDBETA: THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S. C SSF: THE SCALING VALUES FOR BETA. C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO BETA. C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE C DERIVATIVES WITH RESPECT TO DELTA. C TAU: THE TRUST REGION DIAMETER. C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION C DIAMETER. C TT: THE SCALING VALUES FOR DELTA. C TYP: THE CHARACTER*3 STRING "ODR" OR "OLS". C WE: THE EPSILON WEIGHTS. C WD: THE DELTA WEIGHTS. C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. C X: THE EXPLANATORY VARIABLE. C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. C***FIRST EXECUTABLE STATEMENT DODPCR CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) PNLTY = ABS(WE(1,1,1)) IF (HEAD) THEN CALL DODPHD(HEAD,LUNRPT) END IF IF (ISODR) THEN TYP = 'ODR' ELSE TYP = 'OLS' END IF C PRINT INITIAL SUMMARY IF (IFLAG.EQ.1) THEN WRITE (LUNRPT,1200) TYP CALL DODPC1 + (IPR,LUNRPT, + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, + MSGB(1),MSGB(2),MSGD(1),MSGD(2), + N,M,NP,NQ,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, + Y,LDY,WE,LDWE,LD2WE,PNLTY, + BETA,IFIXB,SSF,STPB, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS(1),WSS(2),WSS(3)) C PRINT ITERATION REPORTS ELSE IF (IFLAG.EQ.2) THEN IF (FSTITR) THEN WRITE (LUNRPT,1300) TYP END IF CALL DODPC2 + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, + PNLTY, + NITER,NFEV,WSS(1),ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) C PRINT FINAL SUMMARY ELSE IF (IFLAG.EQ.3) THEN WRITE (LUNRPT,1400) TYP CALL DODPC3 + (IPR,LUNRPT, + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, + N,M,NP,NQ,NPP, + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, + WSS(1),WSS(2),WSS(3),PNLTY,RVAR,IDF, + BETA,SDBETA,IFIXB,F,DELTA) END IF RETURN C FORMAT STATEMENTS 1200 FORMAT + (/' *** INITIAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') 1300 FORMAT + (/' *** ITERATION REPORTS FOR FIT BY METHOD OF ',A3, ' ***') 1400 FORMAT + (/' *** FINAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') END *DODPE1 SUBROUTINE DODPE1 + (UNIT,D1,D2,D3,D4,D5, + N,M,NQ, + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + LWKMN,LIWKMN) C***BEGIN PROLOGUE DODPE1 C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE PRINT ERROR REPORTS C***END PROLOGUE DODPE1 C...SCALAR ARGUMENTS INTEGER + D1,D2,D3,D4,D5,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE, + LIWKMN,LWKMN,M,N,NQ,UNIT C...VARIABLE DEFINITIONS (ALPHABETICALLY) C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C***FIRST EXECUTABLE STATEMENT DODPE1 C PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION C PARAMETERS IF (D1.EQ.1) THEN IF (D2.NE.0) THEN WRITE(UNIT,1100) END IF IF (D3.NE.0) THEN WRITE(UNIT,1200) END IF IF (D4.NE.0) THEN WRITE(UNIT,1300) END IF IF (D5.NE.0) THEN WRITE(UNIT,1400) END IF C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION C PARAMETERS ELSE IF (D1.EQ.2) THEN IF (D2.NE.0) THEN IF (D2.EQ.1 .OR. D2.EQ.3) THEN WRITE(UNIT,2110) END IF IF (D2.EQ.2 .OR. D2.EQ.3) THEN WRITE(UNIT,2120) END IF END IF IF (D3.NE.0) THEN IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN WRITE(UNIT,2210) END IF IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN WRITE(UNIT,2220) END IF IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN WRITE(UNIT,2230) END IF END IF IF (D4.NE.0) THEN IF (D4.EQ.1 .OR. D4.EQ.3) THEN WRITE(UNIT,2310) END IF IF (D4.EQ.2 .OR. D4.EQ.3) THEN WRITE(UNIT,2320) END IF END IF IF (D5.NE.0) THEN IF (D5.EQ.1 .OR. D5.EQ.3) THEN WRITE(UNIT,2410) LWKMN END IF IF (D5.EQ.2 .OR. D5.EQ.3) THEN WRITE(UNIT,2420) LIWKMN END IF END IF ELSE IF (D1.EQ.3) THEN C PRINT APPROPRIATE MESSAGES FOR ERRORS IN SCALE VALUES IF (D2.NE.0) THEN IF (D2.EQ.1 .OR. D2.EQ.3) THEN IF (LDSCLD.GE.N) THEN WRITE(UNIT,3110) ELSE WRITE(UNIT,3120) END IF END IF IF (D2.EQ.2 .OR. D2.EQ.3) THEN WRITE(UNIT,3130) END IF END IF C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DERIVATIVE STEP VALUES IF (D3.NE.0) THEN IF (D3.EQ.1 .OR. D3.EQ.3) THEN IF (LDSTPD.GE.N) THEN WRITE(UNIT,3210) ELSE WRITE(UNIT,3220) END IF END IF IF (D3.EQ.2 .OR. D3.EQ.3) THEN WRITE(UNIT,3230) END IF END IF C PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS IF (D4.NE.0) THEN IF (D4.EQ.1) THEN IF (LDWE.GE.N) THEN IF (LD2WE.GE.NQ) THEN WRITE(UNIT,3310) ELSE WRITE(UNIT,3320) END IF ELSE IF (LD2WE.GE.NQ) THEN WRITE(UNIT,3410) ELSE WRITE(UNIT,3420) END IF END IF END IF IF (D4.EQ.2) THEN WRITE(UNIT,3500) END IF END IF C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS IF (D5.NE.0) THEN IF (LDWD.GE.N) THEN IF (LD2WD.GE.M) THEN WRITE(UNIT,4310) ELSE WRITE(UNIT,4320) END IF ELSE IF (LD2WD.GE.M) THEN WRITE(UNIT,4410) ELSE WRITE(UNIT,4420) END IF END IF END IF END IF C FORMAT STATEMENTS 1100 FORMAT + (/' ERROR : N IS LESS THAN ONE.') 1200 FORMAT + (/' ERROR : M IS LESS THAN ONE.') 1300 FORMAT + (/' ERROR : NP IS LESS THAN ONE'/ + ' OR NP IS GREATER THAN N.') 1400 FORMAT + (/' ERROR : NQ IS LESS THAN ONE.') 2110 FORMAT + (/' ERROR : LDX IS LESS THAN N.') 2120 FORMAT + (/' ERROR : LDY IS LESS THAN N.') 2210 FORMAT + (/' ERROR : LDIFX IS LESS THAN N'/ + ' AND LDIFX IS NOT EQUAL TO ONE.') 2220 FORMAT + (/' ERROR : LDSCLD IS LESS THAN N'/ + ' AND LDSCLD IS NOT EQUAL TO ONE.') 2230 FORMAT + (/' ERROR : LDSTPD IS LESS THAN N'/ + ' AND LDSTPD IS NOT EQUAL TO ONE.') 2310 FORMAT + (/' ERROR : LDWE IS LESS THAN N'/ + ' AND LDWE IS NOT EQUAL TO ONE OR'/ + ' OR'/ + ' LD2WE IS LESS THAN NQ'/ + ' AND LD2WE IS NOT EQUAL TO ONE.') 2320 FORMAT + (/' ERROR : LDWD IS LESS THAN N'/ + ' AND LDWD IS NOT EQUAL TO ONE.') 2410 FORMAT + (/' ERROR : LWORK IS LESS THAN ',I7, ','/ + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.') 2420 FORMAT + (/' ERROR : LIWORK IS LESS THAN ',I7, ','/ + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY', + ' IWORK.') 3110 FORMAT + (/' ERROR : SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + ' AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN'/ + ' EACH OF THE N BY M ELEMENTS OF'/ + ' SCLD MUST BE GREATER THAN ZERO.') 3120 FORMAT + (/' ERROR : SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME J = 1, ..., M.'// + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + ' AND LDSCLD IS EQUAL TO ONE THEN'/ + ' EACH OF THE 1 BY M ELEMENTS OF'/ + ' SCLD MUST BE GREATER THAN ZERO.') 3130 FORMAT + (/' ERROR : SCLB(K) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME K = 1, ..., NP.'// + ' ALL NP ELEMENTS OF', + ' SCLB MUST BE GREATER THAN ZERO.') 3210 FORMAT + (/' ERROR : STPD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ + ' AND LDSTPD IS GREATER THAN OR EQUAL TO N THEN'/ + ' EACH OF THE N BY M ELEMENTS OF'/ + ' STPD MUST BE GREATER THAN ZERO.') 3220 FORMAT + (/' ERROR : STPD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME J = 1, ..., M.'// + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ + ' AND LDSTPD IS EQUAL TO ONE THEN'/ + ' EACH OF THE 1 BY M ELEMENTS OF'/ + ' STPD MUST BE GREATER THAN ZERO.') 3230 FORMAT + (/' ERROR : STPB(K) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME K = 1, ..., NP.'// + ' ALL NP ELEMENTS OF', + ' STPB MUST BE GREATER THAN ZERO.') 3310 FORMAT + (/' ERROR : AT LEAST ONE OF THE (NQ BY NQ) ARRAYS STARTING'/ + ' IN WE(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ + ' SEMIDEFINITE. WHEN WE(1,1,1) IS GREATER THAN'/ + ' OR EQUAL TO ZERO, AND LDWE IS GREATER THAN OR'/ + ' EQUAL TO N, AND LD2WE IS GREATER THAN OR EQUAL'/ + ' TO NQ, THEN EACH OF THE (NQ BY NQ) ARRAYS IN WE'/ + ' MUST BE POSITIVE SEMIDEFINITE.') 3320 FORMAT + (/' ERROR : AT LEAST ONE OF THE (1 BY NQ) ARRAYS STARTING'/ + ' IN WE(I,1,1), I = 1, ..., N, HAS A NEGATIVE'/ + ' ELEMENT. WHEN WE(1,1,1) IS GREATER THAN OR'/ + ' EQUAL TO ZERO, AND LDWE IS GREATER THAN OR EQUAL'/ + ' TO N, AND LD2WE IS EQUAL TO 1, THEN EACH OF THE'/ + ' (1 BY NQ) ARRAYS IN WE MUST HAVE ONLY NON-'/ + ' NEGATIVE ELEMENTS.') 3410 FORMAT + (/' ERROR : THE (NQ BY NQ) ARRAY STARTING IN WE(1,1,1) IS'/ + ' NOT POSITIVE SEMIDEFINITE. WHEN WE(1,1,1) IS'/ + ' GREATER THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL'/ + ' TO 1, AND LD2WE IS GREATER THAN OR EQUAL TO NQ,'/ + ' THEN THE (NQ BY NQ) ARRAY IN WE MUST BE POSITIVE'/ + ' SEMIDEFINITE.') 3420 FORMAT + (/' ERROR : THE (1 BY NQ) ARRAY STARTING IN WE(1,1,1) HAS'/ + ' A NEGATIVE ELEMENT. WHEN WE(1,1,1) IS GREATER'/ + ' THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL TO 1,'/ + ' AND LD2WE IS EQUAL TO 1, THEN THE (1 BY NQ)'/ + ' ARRAY IN WE MUST HAVE ONLY NONNEGATIVE ELEMENTS.') 3500 FORMAT + (/' ERROR : THE NUMBER OF NONZERO ARRAYS IN ARRAY WE IS'/ + ' LESS THAN NP.') 4310 FORMAT + (/' ERROR : AT LEAST ONE OF THE (M BY M) ARRAYS STARTING'/ + ' IN WD(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ + ' DEFINITE. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN EACH'/ + ' OF THE (M BY M) ARRAYS IN WD MUST BE POSITIVE'/ + ' DEFINITE.') 4320 FORMAT + (/' ERROR : AT LEAST ONE OF THE (1 BY M) ARRAYS STARTING'/ + ' IN WD(I,1,1), I = 1, ..., N, HAS A NONPOSITIVE'/ + ' ELEMENT. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ + ' LD2WD IS EQUAL TO 1, THEN EACH OF THE (1 BY M)'/ + ' ARRAYS IN WD MUST HAVE ONLY POSITIVE ELEMENTS.') 4410 FORMAT + (/' ERROR : THE (M BY M) ARRAY STARTING IN WD(1,1,1) IS'/ + ' NOT POSITIVE DEFINITE. WHEN WD(1,1,1) IS'/ + ' GREATER THAN ZERO, AND LDWD IS EQUAL TO 1, AND'/ + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN THE'/ + ' (M BY M) ARRAY IN WD MUST BE POSITIVE DEFINITE.') 4420 FORMAT + (/' ERROR : THE (1 BY M) ARRAY STARTING IN WD(1,1,1) HAS A'/ + ' NONPOSITIVE ELEMENT. WHEN WD(1,1,1) IS GREATER'/ + ' THAN ZERO, AND LDWD IS EQUAL TO 1, AND LD2WD IS'/ + ' EQUAL TO 1, THEN THE (1 BY M) ARRAY IN WD MUST'/ + ' HAVE ONLY POSITIVE ELEMENTS.') END *DODPE2 SUBROUTINE DODPE2 + (UNIT, + N,M,NP,NQ, + FJACB,FJACD, + DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD, + XPLUSD,NROW,NETA,NTOL) C***BEGIN PROLOGUE DODPE2 C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE GENERATE THE DERIVATIVE CHECKING REPORT C***END PROLOGUE DODPE2 C...SCALAR ARGUMENTS INTEGER + M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT LOGICAL + ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) INTEGER + MSGB(NQ,NP),MSGD(NQ,M) C...LOCAL SCALARS INTEGER + I,J,K,L CHARACTER FLAG*1,TYP*3 C...LOCAL ARRAYS LOGICAL + FTNOTE(0:7) C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. C FJACB: THE JACOBIAN WITH RESPECT TO BETA. C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. C FLAG: THE CHARACTER STRING INDICATING HIGHLY QUESTIONABLE RESULTS. C FTNOTE: THE ARRAY CONTROLLING FOOTNOTES. C I: AN INDEX VARIABLE. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C J: AN INDEX VARIABLE. C K: AN INDEX VARIABLE. C L: AN INDEX VARIABLE. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. C TYP: THE CHARACTER STRING INDICATING SOLUTION TYPE, ODR OR OLS. C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C XPLUSD: THE VALUES OF X + DELTA. C***FIRST EXECUTABLE STATEMENT DODPE2 C SET UP FOR FOOTNOTES DO 10 I=0,7 FTNOTE(I) = .FALSE. 10 CONTINUE DO 40 L=1,NQ IF (MSGB1.GE.1) THEN DO 20 I=1,NP IF (MSGB(L,I).GE.1) THEN FTNOTE(0) = .TRUE. FTNOTE(MSGB(L,I)) = .TRUE. END IF 20 CONTINUE END IF IF (MSGD1.GE.1) THEN DO 30 I=1,M IF (MSGD(L,I).GE.1) THEN FTNOTE(0) = .TRUE. FTNOTE(MSGD(L,I)) = .TRUE. END IF 30 CONTINUE END IF 40 CONTINUE C PRINT REPORT IF (ISODR) THEN TYP = 'ODR' ELSE TYP = 'OLS' END IF WRITE (UNIT,1000) TYP DO 70 L=1,NQ WRITE (UNIT,2100) L,NROW WRITE (UNIT,2200) DO 50 I=1,NP K = MSGB(L,I) IF (K.GE.7) THEN FLAG = '*' ELSE FLAG = ' ' END IF IF (K.LE.-1) THEN WRITE (UNIT,3100) I ELSE IF (K.EQ.0) THEN WRITE (UNIT,3200) I,FJACB(NROW,I,L),DIFF(L,I),FLAG ELSE IF (K.GE.1) THEN WRITE (UNIT,3300) I,FJACB(NROW,I,L),DIFF(L,I),FLAG,K END IF 50 CONTINUE IF (ISODR) THEN DO 60 I=1,M K = MSGD(L,I) IF (K.GE.7) THEN FLAG = '*' ELSE FLAG = ' ' END IF IF (K.LE.-1) THEN WRITE (UNIT,4100) NROW,I ELSE IF (K.EQ.0) THEN WRITE (UNIT,4200) NROW,I, + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG ELSE IF (K.GE.1) THEN WRITE (UNIT,4300) NROW,I, + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG,K END IF 60 CONTINUE END IF 70 CONTINUE C PRINT FOOTNOTES IF (FTNOTE(0)) THEN WRITE (UNIT,5000) IF (FTNOTE(1)) WRITE (UNIT,5100) IF (FTNOTE(2)) WRITE (UNIT,5200) IF (FTNOTE(3)) WRITE (UNIT,5300) IF (FTNOTE(4)) WRITE (UNIT,5400) IF (FTNOTE(5)) WRITE (UNIT,5500) IF (FTNOTE(6)) WRITE (UNIT,5600) IF (FTNOTE(7)) WRITE (UNIT,5700) END IF IF (NETA.LT.0) THEN WRITE (UNIT,6000) -NETA ELSE WRITE (UNIT,6100) NETA END IF WRITE (UNIT,7000) NTOL C PRINT OUT ROW OF EXPLANATORY VARIABLE WHICH WAS CHECKED. WRITE (UNIT,8100) NROW DO 80 J=1,M WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J) 80 CONTINUE RETURN C FORMAT STATEMENTS 1000 FORMAT + (//' *** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3, + ' ***'/) 2100 FORMAT (/' FOR RESPONSE ',I2,' OF OBSERVATION ', I5/) 2200 FORMAT (' ',' USER', + ' ',' '/ + ' ',' SUPPLIED', + ' RELATIVE',' DERIVATIVE '/ + ' DERIVATIVE WRT',' VALUE', + ' DIFFERENCE',' ASSESSMENT '/) 3100 FORMAT (' BETA(',I3,')', ' --- ', + ' --- ',' UNCHECKED') 3200 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, + 'VERIFIED') 3300 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, + 'QUESTIONABLE (SEE NOTE ',I1,')') 4100 FORMAT (' DELTA(',I2,',',I2,')', ' --- ', + ' --- ',' UNCHECKED') 4200 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, + 'VERIFIED') 4300 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, + 'QUESTIONABLE (SEE NOTE ',I1,')') 5000 FORMAT + (/' NOTES:') 5100 FORMAT + (/' (1) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + ' AGREE, BUT'/ + ' RESULTS ARE QUESTIONABLE BECAUSE BOTH ARE ZERO.') 5200 FORMAT + (/' (2) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + ' AGREE, BUT'/ + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', + ' IDENTICALLY ZERO'/ + ' AND THE OTHER IS ONLY APPROXIMATELY ZERO.') 5300 FORMAT + (/' (3) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + ' DISAGREE, BUT'/ + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', + ' IDENTICALLY ZERO'/ + ' AND THE OTHER IS NOT.') 5400 FORMAT + (/' (4) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + ' DISAGREE, BUT'/ + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', + ' BECAUSE EITHER'/ + ' THE RATIO OF RELATIVE CURVATURE TO RELATIVE', + ' SLOPE IS TOO HIGH'/ + ' OR THE SCALE IS WRONG.') 5500 FORMAT + (/' (5) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + ' DISAGREE, BUT'/ + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', + ' BECAUSE THE'/ + ' RATIO OF RELATIVE CURVATURE TO RELATIVE SLOPE IS', + ' TOO HIGH.') 5600 FORMAT + (/' (6) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + ' DISAGREE, BUT'/ + ' HAVE AT LEAST 2 DIGITS IN COMMON.') 5700 FORMAT + (/' (7) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', + ' DISAGREE, AND'/ + ' HAVE FEWER THAN 2 DIGITS IN COMMON. DERIVATIVE', + ' CHECKING MUST'/ + ' BE TURNED OFF IN ORDER TO PROCEED.') 6000 FORMAT + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', + I5/ + ' (ESTIMATED BY ODRPACK)') 6100 FORMAT + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', + I5/ + ' (SUPPLIED BY USER)') 7000 FORMAT + (/' NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN '/ + ' USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR '/ + ' USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED ', + I5) 8100 FORMAT + (/' ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED ', + I5// + ' -VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW'/) 8110 FORMAT + (10X,'X(',I2,',',I2,')',1X,1P,3D16.8) END *DODPE3 SUBROUTINE DODPE3 + (UNIT,D2,D3) C***BEGIN PROLOGUE DODPE3 C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE PRINT ERROR REPORTS INDICATING THAT COMPUTATIONS WERE C STOPPED IN USER SUPPLIED SUBROUTINES FCN C***END PROLOGUE DODPE3 C...SCALAR ARGUMENTS INTEGER + D2,D3,UNIT C...VARIABLE DEFINITIONS (ALPHABETICALLY) C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C***FIRST EXECUTABLE STATEMENT DODPE3 C PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE C STOPPED IF (D2.EQ.2) THEN WRITE(UNIT,1100) ELSE IF (D2.EQ.3) THEN WRITE(UNIT,1200) ELSE IF (D2.EQ.4) THEN WRITE(UNIT,1300) END IF IF (D3.EQ.2) THEN WRITE(UNIT,1400) END IF C FORMAT STATEMENTS 1100 FORMAT + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED USING THE'/ + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ + ' PROPER EVALUATION OF SUBROUTINE FCN BEFORE THE '/ + ' REGRESSION PROCEDURE CAN CONTINUE.') 1200 FORMAT + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ + ' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE '/ + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, INDI-'/ + ' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),'/ + ' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION), '/ + ' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE'/ + ' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT '/ + ' SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. THE '/ + ' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') 1300 FORMAT + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ + ' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT '/ + ' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS '/ + ' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR '/ + ' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS '/ + ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA '/ + ' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN '/ + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, '/ + ' PREVENT SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. '/ + ' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') 1400 FORMAT + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED FOR '/ + ' DERIVATIVE EVALUATIONS USING THE INITIAL ESTIMATES OF '/ + ' BETA AND DELTA SUPPLIED BY THE USER. THE INITIAL '/ + ' ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER EVALUATION '/ + ' OF SUBROUTINE FCN BEFORE THE REGRESSION PROCEDURE CAN '/ + ' CONTINUE.') END *DODPER SUBROUTINE DODPER + (INFO,LUNERR,SHORT, + N,M,NP,NQ, + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + LWKMN,LIWKMN, + FJACB,FJACD, + DIFF,MSGB,ISODR,MSGD, + XPLUSD,NROW,NETA,NTOL) C***BEGIN PROLOGUE DODPER C***REFER TO DODR,DODRC C***ROUTINES CALLED DODPE1,DODPE2,DODPE3,DODPHD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS C***END PROLOGUE DODPER C...SCALAR ARGUMENTS INTEGER + INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,LIWKMN,LUNERR,LWKMN, + M,N,NETA,NP,NQ,NROW,NTOL LOGICAL + ISODR,SHORT C...ARRAY ARGUMENTS DOUBLE PRECISION + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) INTEGER + MSGB(NQ*NP+1),MSGD(NQ*M+1) C...LOCAL SCALARS INTEGER + D1,D2,D3,D4,D5,UNIT LOGICAL + HEAD C...EXTERNAL SUBROUTINES EXTERNAL + DODPE1,DODPE2,DODPE3,DODPHD C...INTRINSIC FUNCTIONS INTRINSIC + MOD C...VARIABLE DEFINITIONS (ALPHABETICALLY) C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. C FJACB: THE JACOBIAN WITH RESPECT TO BETA. C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. C N: THE NUMBER OF OBSERVATIONS. C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL C (SHORT=.FALSE.). C UNIT: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. C XPLUSD: THE VALUES X + DELTA. C***FIRST EXECUTABLE STATEMENT DODPER C SET LOGICAL UNIT NUMBER FOR ERROR REPORT IF (LUNERR.EQ.0) THEN RETURN ELSE IF (LUNERR.LT.0) THEN UNIT = 6 ELSE UNIT = LUNERR END IF C PRINT HEADING HEAD = .TRUE. CALL DODPHD(HEAD,UNIT) C EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO D1 = MOD(INFO,100000)/10000 D2 = MOD(INFO,10000)/1000 D3 = MOD(INFO,1000)/100 D4 = MOD(INFO,100)/10 D5 = MOD(INFO,10) C PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP IF (D1.GE.1 .AND. D1.LE.3) THEN C PRINT APPROPRIATE MESSAGES FOR ERRORS IN C PROBLEM SPECIFICATION PARAMETERS C DIMENSION SPECIFICATION PARAMETERS C NUMBER OF GOOD DIGITS IN X C WEIGHTS CALL DODPE1(UNIT,D1,D2,D3,D4,D5, + N,M,NQ, + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, + LWKMN,LIWKMN) ELSE IF ((D1.EQ.4) .OR. (MSGB(1).GE.0)) THEN C PRINT APPROPRIATE MESSAGES FOR DERIVATIVE CHECKING CALL DODPE2(UNIT, + N,M,NP,NQ, + FJACB,FJACD, + DIFF,MSGB(1),MSGB(2),ISODR,MSGD(1),MSGD(2), + XPLUSD,NROW,NETA,NTOL) ELSE IF (D1.EQ.5) THEN C PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FCN CALL DODPE3(UNIT,D2,D3) END IF C PRINT CORRECT FORM OF CALL STATEMENT IF ((D1.GE.1 .AND. D1.LE.3) .OR. + (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. + (D1.EQ.5)) THEN IF (SHORT) THEN WRITE (UNIT,1100) ELSE WRITE (UNIT,1200) END IF END IF RETURN C FORMAT STATEMENTS 1100 FORMAT + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + ' CALL DODR'/ + ' + (FCN,'/ + ' + N,M,NP,NQ,'/ + ' + BETA,'/ + ' + Y,LDY,X,LDX,'/ + ' + WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/ + ' + JOB,'/ + ' + IPRINT,LUNERR,LUNRPT,'/ + ' + WORK,LWORK,IWORK,LIWORK,'/ + ' + INFO)') 1200 FORMAT + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + ' CALL DODRC'/ + ' + (FCN,'/ + ' + N,M,NP,NQ,'/ + ' + BETA,'/ + ' + Y,LDY,X,LDX,'/ + ' + WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/ + ' + IFIXB,IFIXX,LDIFX,'/ + ' + JOB,NDIGIT,TAUFAC,'/ + ' + SSTOL,PARTOL,MAXIT,'/ + ' + IPRINT,LUNERR,LUNRPT,'/ + ' + STPB,STPD,LDSTPD,'/ + ' + SCLB,SCLD,LDSCLD,'/ + ' + WORK,LWORK,IWORK,LIWORK,'/ + ' + INFO)') END *DODPHD SUBROUTINE DODPHD + (HEAD,UNIT) C***BEGIN PROLOGUE DODPHD C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE PRINT ODRPACK HEADING C***END PROLOGUE DODPHD C...SCALAR ARGUMENTS INTEGER + UNIT LOGICAL + HEAD C...VARIABLE DEFINITIONS (ALPHABETICALLY) C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). C UNIT: THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN. C***FIRST EXECUTABLE STATEMENT DODPHD IF (HEAD) THEN WRITE(UNIT,1000) HEAD = .FALSE. END IF RETURN C FORMAT STATEMENTS 1000 FORMAT ( + ' ******************************************************* '/ + ' * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * '/ + ' ******************************************************* '/) END *DODSTP SUBROUTINE DODSTP + (N,M,NP,NQ,NPP, + F,FJACB,FJACD, + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + ALPHA,EPSFCN,ISODR, + TFJACB,OMEGA,U,QRAUX,KPVT, + S,T,PHI,IRANK,RCOND,FORVCV, + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) C***BEGIN PROLOGUE DODSTP C***REFER TO DODR,DODRC C***ROUTINES CALLED IDAMAX,DCHEX,DESUBI,DFCTR,DNRM2,DQRDC,DQRSL,DROT, C DROTG,DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA) C***END PROLOGUE DODSTP C...SCALAR ARGUMENTS DOUBLE PRECISION + ALPHA,EPSFCN,PHI,RCOND INTEGER + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ LOGICAL + ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),WRK(LWRK) INTEGER + KPVT(NP) C...LOCAL SCALARS DOUBLE PRECISION + CO,ONE,SI,TEMP,ZERO INTEGER + I,IMAX,INF,IPVT,J,K,K1,K2,KP,L LOGICAL + ELIM,FORVCV C...LOCAL ARRAYS DOUBLE PRECISION + DUM(2) C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DNRM2 INTEGER + IDAMAX EXTERNAL + DNRM2,IDAMAX C...EXTERNAL SUBROUTINES EXTERNAL + DCHEX,DESUBI,DFCTR,DQRDC,DQRSL,DROT,DROTG, + DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SQRT C...DATA STATEMENTS DATA + ZERO,ONE + /0.0D0,1.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. C CO: THE COSINE FROM THE PLANE ROTATION. C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C DUM: A DUMMY ARRAY. C ELIM: THE VARIABLE DESIGNATING WHETHER COLUMNS OF THE JACOBIAN C WRT BETA HAVE BEEN ELIMINATED (ELIM=TRUE) OR NOT C (ELIM=FALSE). C EPSFCN: THE FUNCTION'S PRECISION. C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C FJACB: THE JACOBIAN WITH RESPECT TO BETA. C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). C I: AN INDEXING VARIABLE. C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE C VALUE. C INF: THE RETURN CODE FROM LINPACK ROUTINES. C IPVT: THE VARIABLE DESIGNATING WHETHER PIVOTING IS TO BE DONE. C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. C J: AN INDEXING VARIABLE. C K: AN INDEXING VARIABLE. C K1: AN INDEXING VARIABLE. C K2: AN INDEXING VARIABLE. C KP: THE RANK OF THE JACOBIAN WRT BETA. C KPVT: THE PIVOT VECTOR. C L: AN INDEXING VARIABLE. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LWRK: THE LENGTH OF VECTOR WRK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. C OMEGA: THE ARRAY DEFINED S.T. C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) C = (I-FJACD*INV(P)*TRANS(FJACD)) C WHERE E = D**2 + ALPHA*TT**2 C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 C ONE: THE VALUE 1.0D0. C PHI: THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP C AND THE TRUST REGION DIAMETER. C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. C S: THE STEP FOR BETA. C SI: THE SINE FROM THE PLANE ROTATION. C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. C T: THE STEP FOR DELTA. C TEMP: A TEMPORARY STORAGE LOCATION. C TFJACB: THE ARRAY OMEGA*FJACB. C TT: THE SCALING VALUES FOR DELTA. C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. C WD: THE (SQUARED) DELTA WEIGHTS. C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, C EQUIVALENCED TO WRK1 AND WRK2. C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK3: A WORK ARRAY OF (NP) ELEMENTS. C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. C WRK5: A WORK ARRAY OF (M) ELEMENTS. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DODSTP C COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE C SET UP KPVT IF ALPHA = 0 IF (ALPHA.EQ.ZERO) THEN KP = NPP DO 10 K=1,NP KPVT(K) = K 10 CONTINUE ELSE IF (NPP.GE.1) THEN KP = NPP-IRANK ELSE KP = NPP END IF END IF IF (ISODR) THEN C T = WD * DELTA = D*G2 CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,T,N) DO 300 I=1,N C COMPUTE WRK4, SUCH THAT C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) CALL DFCTR(.FALSE.,WRK4,M,M,INF) IF (INF.NE.0) THEN ISTOPC = 60000 RETURN END IF C COMPUTE OMEGA, SUCH THAT C TRANS(OMEGA)*OMEGA = I+FJACD*INV(E)*TRANS(FJACD) C INV(TRANS(OMEGA)*OMEGA) = I-FJACD*INV(P)*TRANS(FJACD) CALL DVEVTR(M,NQ,I, + FJACD,N,M, WRK4,M, WRK1,N,NQ, OMEGA,NQ, WRK5) DO 110 L=1,NQ OMEGA(L,L) = ONE + OMEGA(L,L) 110 CONTINUE CALL DFCTR(.FALSE.,OMEGA,NQ,NQ,INF) IF (INF.NE.0) THEN ISTOPC = 60000 RETURN END IF C COMPUTE WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) C = TRANS(FJACD)*INV(TRANS(OMEGA)*OMEGA) DO 130 J=1,M DO 120 L=1,NQ WRK1(I,L,J) = FJACD(I,J,L) 120 CONTINUE CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,4) CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,2) 130 CONTINUE C COMPUTE WRK5 = INV(E)*D*G2 DO 140 J=1,M WRK5(J) = T(I,J) 140 CONTINUE CALL DSOLVE(M,WRK4,M,WRK5,1,4) CALL DSOLVE(M,WRK4,M,WRK5,1,2) C COMPUTE TFJACB = INV(TRANS(OMEGA))*FJACB DO 170 K=1,KP DO 150 L=1,NQ TFJACB(I,L,K) = FJACB(I,KPVT(K),L) 150 CONTINUE CALL DSOLVE(NQ,OMEGA,NQ,TFJACB(I,1,K),N,4) DO 160 L=1,NQ IF (SS(1).GT.ZERO) THEN TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) ELSE TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) END IF 160 CONTINUE 170 CONTINUE C COMPUTE WRK2 = (V*INV(E)*D**2*G2 - G1) DO 190 L=1,NQ WRK2(I,L) = ZERO DO 180 J=1,M WRK2(I,L) = WRK2(I,L) + FJACD(I,J,L)*WRK5(J) 180 CONTINUE WRK2(I,L) = WRK2(I,L) - F(I,L) 190 CONTINUE C COMPUTE WRK2 = INV(TRANS(OMEGA))*(V*INV(E)*D**2*G2 - G1) CALL DSOLVE(NQ,OMEGA,NQ,WRK2(I,1),N,4) 300 CONTINUE ELSE DO 360 I=1,N DO 350 L=1,NQ DO 340 K=1,KP TFJACB(I,L,K) = FJACB(I,KPVT(K),L) IF (SS(1).GT.ZERO) THEN TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) ELSE TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) END IF 340 CONTINUE WRK2(I,L) = -F(I,L) 350 CONTINUE 360 CONTINUE END IF C COMPUTE S C DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0) IF (ALPHA.EQ.ZERO) THEN IPVT = 1 DO 410 K=1,NP KPVT(K) = 0 410 CONTINUE ELSE IPVT = 0 END IF CALL DQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT) CALL DQRSL(TFJACB,N*NQ,N*NQ,KP, + QRAUX,WRK2,DUM,WRK2,DUM,DUM,DUM,1000,INF) IF (INF.NE.0) THEN ISTOPC = 60000 RETURN END IF C ELIMINATE ALPHA PART USING GIVENS ROTATIONS IF (ALPHA.NE.ZERO) THEN CALL DZERO(NPP,1,S,NPP) DO 430 K1=1,KP CALL DZERO(KP,1,WRK3,KP) WRK3(K1) = SQRT(ALPHA) DO 420 K2=K1,KP CALL DROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI) IF (KP-K2.GE.1) THEN CALL DROT(KP-K2,TFJACB(K2,1,K2+1),N*NQ, + WRK3(K2+1),1,CO,SI) END IF TEMP = CO*WRK2(K2,1) + SI*S(KPVT(K1)) S(KPVT(K1)) = -SI*WRK2(K2,1) + CO*S(KPVT(K1)) WRK2(K2,1) = TEMP 420 CONTINUE 430 CONTINUE END IF C COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY IF (NPP.GE.1) THEN IF (ALPHA.EQ.ZERO) THEN KP = NPP C ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR 440 CALL DTRCO(TFJACB,N*NQ,KP,RCOND,U,1) IF (RCOND.LE.EPSFCN) THEN ELIM = .TRUE. IMAX = IDAMAX(KP,U,1) C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX KPVT IF (IMAX.NE.KP) THEN CALL DCHEX(TFJACB,N*NQ,KP,IMAX,KP,WRK2,N*NQ,1, + QRAUX,WRK3,2) K = KPVT(IMAX) DO 450 I=IMAX,KP-1 KPVT(I) = KPVT(I+1) 450 CONTINUE KPVT(KP) = K END IF KP = KP-1 ELSE ELIM = .FALSE. END IF IF (ELIM .AND. KP.GE.1) THEN GO TO 440 ELSE IRANK = NPP-KP END IF END IF END IF IF (FORVCV) RETURN C BACKSOLVE AND UNSCRAMBLE IF (NPP.GE.1) THEN DO 510 I=KP+1,NPP WRK2(I,1) = ZERO 510 CONTINUE IF (KP.GE.1) THEN CALL DTRSL(TFJACB,N*NQ,KP,WRK2,01,INF) IF (INF.NE.0) THEN ISTOPC = 60000 RETURN END IF END IF DO 520 I=1,NPP IF (SS(1).GT.ZERO) THEN S(KPVT(I)) = WRK2(I,1)/SS(KPVT(I)) ELSE S(KPVT(I)) = WRK2(I,1)/ABS(SS(1)) END IF 520 CONTINUE END IF IF (ISODR) THEN C NOTE: T AND WRK1 HAVE BEEN INITIALIZED ABOVE, C WHERE T = WD * DELTA = D*G2 C WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) DO 670 I=1,N C COMPUTE WRK4, SUCH THAT C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) CALL DFCTR(.FALSE.,WRK4,M,M,INF) IF (INF.NE.0) THEN ISTOPC = 60000 RETURN END IF C COMPUTE WRK5 = INV(E)*D*G2 DO 610 J=1,M WRK5(J) = T(I,J) 610 CONTINUE CALL DSOLVE(M,WRK4,M,WRK5,1,4) CALL DSOLVE(M,WRK4,M,WRK5,1,2) DO 640 L=1,NQ WRK2(I,L) = F(I,L) DO 620 K=1,NPP WRK2(I,L) = WRK2(I,L) + FJACB(I,K,L)*S(K) 620 CONTINUE DO 630 J=1,M WRK2(I,L) = WRK2(I,L) - FJACD(I,J,L)*WRK5(J) 630 CONTINUE 640 CONTINUE DO 660 J=1,M WRK5(J) = ZERO DO 650 L=1,NQ WRK5(J) = WRK5(J) + WRK1(I,L,J)*WRK2(I,L) 650 CONTINUE T(I,J) = -(WRK5(J) + T(I,J)) 660 CONTINUE CALL DSOLVE(M,WRK4,M,T(I,1),N,4) CALL DSOLVE(M,WRK4,M,T(I,1),N,2) 670 CONTINUE END IF C COMPUTE PHI(ALPHA) FROM SCALED S AND T CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) IF (ISODR) THEN CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) PHI = DNRM2(NPP+N*M,WRK,1) ELSE PHI = DNRM2(NPP,WRK,1) END IF RETURN END *DODVCV SUBROUTINE DODVCV + (N,M,NP,NQ,NPP, + F,FJACB,FJACD, + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, + EPSFCN,ISODR, + VCV,SD, + WRK6,OMEGA,U,QRAUX,JPVT, + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) C***BEGIN PROLOGUE DODVCV C***REFER TO DODR,DODRC C***ROUTINES CALLED DPODI,DODSTP C***DATE WRITTEN 901207 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS C***END PROLOGUE DODVCV C...SCALAR ARGUMENTS DOUBLE PRECISION + EPSFCN,RCOND,RSS,RVAR INTEGER + IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ LOGICAL + ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + DELTA(N,M),F(N,NQ), + FJACB(N,NP,NQ),FJACD(N,M,NQ), + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SD(NP),SS(NP),SSF(NP), + T(N,M),TT(LDTT,M),U(NP),VCV(NP,NP),WD(LDWD,LD2WD,M), + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M), + WRK6(N*NQ,NP),WRK(LWRK) INTEGER + IFIXB(NP),JPVT(NP) C...LOCAL SCALARS DOUBLE PRECISION + TEMP,ZERO INTEGER + I,IUNFIX,J,JUNFIX,KP,L LOGICAL + FORVCV C...EXTERNAL SUBROUTINES EXTERNAL + DPODI,DODSTP C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SQRT C...DATA STATEMENTS DATA + ZERO + /0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. C EPSFCN: THE FUNCTION'S PRECISION. C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C FJACB: THE JACOBIAN WITH RESPECT TO BETA. C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. C FORVCV: THE VARIABLE DESIGNATING WHETHER SUBROUTINE DODSTP IS C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). C I: AN INDEXING VARIABLE. C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE C VALUE. C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. C IUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. C J: AN INDEXING VARIABLE. C JPVT: THE PIVOT VECTOR. C JUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. C KP: THE RANK OF THE JACOBIAN WRT BETA. C L: AN INDEXING VARIABLE. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDWD: THE LEADING DIMENSION OF ARRAY WD. C LD2WD: THE SECOND DIMENSION OF ARRAY WD. C LWRK: THE LENGTH OF VECTOR WRK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C OMEGA: THE ARRAY DEFINED S.T. C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) C = (I-FJACD*INV(P)*TRANS(FJACD)) C WHERE E = D**2 + ALPHA*TT**2 C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. C RSS: THE RESIDUAL SUM OF SQUARES. C RVAR: THE RESIDUAL VARIANCE. C S: THE STEP FOR BETA. C SD: THE STANDARD DEVIATIONS OF THE ESTIMATED BETAS. C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. C SSF: THE SCALING VALUES USED FOR BETA. C T: THE STEP FOR DELTA. C TEMP: A TEMPORARY STORAGE LOCATION C TT: THE SCALING VALUES FOR DELTA. C U: THE APPROXIMATE NULL VECTOR FOR FJACB. C VCV: THE COVARIANCE MATRIX OF THE ESTIMATED BETAS. C WD: THE DELTA WEIGHTS. C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, C EQUIVALENCED TO WRK1 AND WRK2. C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. C WRK3: A WORK ARRAY OF (NP) ELEMENTS. C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. C WRK5: A WORK ARRAY OF (M) ELEMENTS. C WRK6: A WORK ARRAY OF (N*NQ BY P) ELEMENTS. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DODVCV FORVCV = .TRUE. ISTOPC = 0 CALL DODSTP(N,M,NP,NQ,NPP, + F,FJACB,FJACD, + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, + ZERO,EPSFCN,ISODR, + WRK6,OMEGA,U,QRAUX,JPVT, + S,T,TEMP,IRANK,RCOND,FORVCV, + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) IF (ISTOPC.NE.0) THEN RETURN END IF KP = NPP - IRANK CALL DPODI (WRK6,N*NQ,KP,WRK3,1) IDF = 0 DO 150 I=1,N DO 120 J=1,NPP DO 110 L=1,NQ IF (FJACB(I,J,L).NE.ZERO) THEN IDF = IDF + 1 GO TO 150 END IF 110 CONTINUE 120 CONTINUE IF (ISODR) THEN DO 140 J=1,M DO 130 L=1,NQ IF (FJACD(I,J,L).NE.ZERO) THEN IDF = IDF + 1 GO TO 150 END IF 130 CONTINUE 140 CONTINUE END IF 150 CONTINUE IF (IDF.GT.KP) THEN IDF = IDF - KP RVAR = RSS/IDF ELSE IDF = 0 RVAR = RSS END IF C STORE VARIANCES IN SD, RESTORING ORIGINAL ORDER DO 200 I=1,NP SD(I) = ZERO 200 CONTINUE DO 210 I=1,KP SD(JPVT(I)) = WRK6(I,I) 210 CONTINUE IF (NP.GT.NPP) THEN JUNFIX = NPP DO 220 J=NP,1,-1 IF (IFIXB(J).EQ.0) THEN SD(J) = ZERO ELSE SD(J) = SD(JUNFIX) JUNFIX = JUNFIX - 1 END IF 220 CONTINUE END IF C STORE COVARIANCE MATRIX IN VCV, RESTORING ORIGINAL ORDER DO 310 I=1,NP DO 300 J=1,I VCV(I,J) = ZERO 300 CONTINUE 310 CONTINUE DO 330 I=1,KP DO 320 J=I+1,KP IF (JPVT(I).GT.JPVT(J)) THEN VCV(JPVT(I),JPVT(J))=WRK6(I,J) ELSE VCV(JPVT(J),JPVT(I))=WRK6(I,J) END IF 320 CONTINUE 330 CONTINUE IF (NP.GT.NPP) THEN IUNFIX = NPP DO 360 I=NP,1,-1 IF (IFIXB(I).EQ.0) THEN DO 340 J=I,1,-1 VCV(I,J) = ZERO 340 CONTINUE ELSE JUNFIX = NPP DO 350 J=NP,1,-1 IF (IFIXB(J).EQ.0) THEN VCV(I,J) = ZERO ELSE VCV(I,J) = VCV(IUNFIX,JUNFIX) JUNFIX = JUNFIX - 1 END IF 350 CONTINUE IUNFIX = IUNFIX - 1 END IF 360 CONTINUE END IF DO 380 I=1,NP VCV(I,I) = SD(I) SD(I) = SQRT(RVAR*SD(I)) DO 370 J=1,I VCV(J,I) = VCV(I,J) 370 CONTINUE 380 CONTINUE C UNSCALE STANDARD ERRORS AND COVARIANCE MATRIX DO 410 I=1,NP IF (SSF(1).GT.ZERO) THEN SD(I) = SD(I)/SSF(I) ELSE SD(I) = SD(I)/ABS(SSF(1)) END IF DO 400 J=1,NP IF (SSF(1).GT.ZERO) THEN VCV(I,J) = VCV(I,J)/(SSF(I)*SSF(J)) ELSE VCV(I,J) = VCV(I,J)/(SSF(1)*SSF(1)) END IF 400 CONTINUE 410 CONTINUE RETURN END *DPACK SUBROUTINE DPACK + (N2,N1,V1,V2,IFIX) C***BEGIN PROLOGUE DPACK C***REFER TO DODR,DODRC C***ROUTINES CALLED DCOPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1 C***END PROLOGUE DPACK C...SCALAR ARGUMENTS INTEGER + N1,N2 C...ARRAY ARGUMENTS DOUBLE PRECISION + V1(N2),V2(N2) INTEGER + IFIX(N2) C...LOCAL SCALARS INTEGER + I C...EXTERNAL SUBROUTINES EXTERNAL + DCOPY C...VARIABLE DEFINITIONS (ALPHABETICALLY) C I: AN INDEXING VARIABLE. C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE C FIXED AT THEIR INPUT VALUES OR NOT. C N1: THE NUMBER OF ITEMS IN V1. C N2: THE NUMBER OF ITEMS IN V2. C V1: THE VECTOR OF THE UNFIXED ITEMS FROM V2. C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE C UNFIXED ELEMENTS ARE TO BE EXTRACTED. C***FIRST EXECUTABLE STATEMENT DPACK N1 = 0 IF (IFIX(1).GE.0) THEN DO 10 I=1,N2 IF (IFIX(I).NE.0) THEN N1 = N1+1 V1(N1) = V2(I) END IF 10 CONTINUE ELSE N1 = N2 CALL DCOPY(N2,V2,1,V1,1) END IF RETURN END *DPPNML DOUBLE PRECISION FUNCTION DPPNML + (P) C***BEGIN PROLOGUE DPPNML C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 901207 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***AUTHOR FILLIBEN, JAMES J., C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C (ORIGINAL VERSION--JUNE 1972. C (UPDATED --SEPTEMBER 1975, C NOVEMBER 1975, AND C OCTOBER 1976. C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE C NORMAL (GAUSSIAN) DISTRIBUTION WITH MEAN 0 AND STANDARD C DEVIATION 1, AND WITH PROBABILITY DENSITY FUNCTION C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) C***DESCRIPTION C --THE CODING AS PRESENTED BELOW IS ESSENTIALLY C IDENTICAL TO THAT PRESENTED BY ODEH AND EVANS C AS ALGORTIHM 70 OF APPLIED STATISTICS. C --AS POINTED OUT BY ODEH AND EVANS IN APPLIED C STATISTICS, THEIR ALGORITHM REPRESENTES A C SUBSTANTIAL IMPROVEMENT OVER THE PREVIOUSLY EMPLOYED C HASTINGS APPROXIMATION FOR THE NORMAL PERCENT POINT C FUNCTION, WITH ACCURACY IMPROVING FROM 4.5*(10**-4) C TO 1.5*(10**-8). C***REFERENCES ODEH AND EVANS, THE PERCENTAGE POINTS OF THE NORMAL C DISTRIBUTION, ALGORTIHM 70, APPLIED STATISTICS, 1974, C PAGES 96-97. C EVANS, ALGORITHMS FOR MINIMAL DEGREE POLYNOMIAL AND C RATIONAL APPROXIMATION, M. SC. THESIS, 1972, C UNIVERSITY OF VICTORIA, B. C., CANADA. C HASTINGS, APPROXIMATIONS FOR DIGITAL COMPUTERS, 1955, C PAGES 113, 191, 192. C NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS C SERIES 55, 1964, PAGE 933, FORMULA 26.2.23. C FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE C LOCATION PARAMETER OF A SYMMETRIC DISTRIBUTION C (UNPUBLISHED PH.D. DISSERTATION, PRINCETON C UNIVERSITY), 1969, PAGES 21-44, 229-231. C FILLIBEN, "THE PERCENT POINT FUNCTION", C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, C VOLUME 1, 1970, PAGES 40-111. C KELLEY STATISTICAL TABLES, 1948. C OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, PAGES 3-16. C PEARSON AND HARTLEY, BIOMETRIKA TABLES FOR C STATISTICIANS, VOLUME 1, 1954, PAGES 104-113. C***END PROLOGUE DPPNML C...SCALAR ARGUMENTS DOUBLE PRECISION + P C...LOCAL SCALARS DOUBLE PRECISION + ADEN,ANUM,HALF,ONE,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T,TWO,ZERO C...INTRINSIC FUNCTIONS INTRINSIC + LOG,SQRT C...DATA STATEMENTS DATA + P0,P1,P2,P3,P4 + /-0.322232431088D0,-1.0D0,-0.342242088547D0, + -0.204231210245D-1,-0.453642210148D-4/ DATA + Q0,Q1,Q2,Q3,Q4 + /0.993484626060D-1,0.588581570495D0, + 0.531103462366D0,0.103537752850D0,0.38560700634D-2/ DATA + ZERO,HALF,ONE,TWO + /0.0D0,0.5D0,1.0D0,2.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ADEN: A VALUE USED IN THE APPROXIMATION. C ANUM: A VALUE USED IN THE APPROXIMATION. C HALF: THE VALUE 0.5D0. C ONE: THE VALUE 1.0D0. C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE C EVALUATED. P MUST BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVE. C P0: A PARAMETER USED IN THE APPROXIMATION. C P1: A PARAMETER USED IN THE APPROXIMATION. C P2: A PARAMETER USED IN THE APPROXIMATION. C P3: A PARAMETER USED IN THE APPROXIMATION. C P4: A PARAMETER USED IN THE APPROXIMATION. C Q0: A PARAMETER USED IN THE APPROXIMATION. C Q1: A PARAMETER USED IN THE APPROXIMATION. C Q2: A PARAMETER USED IN THE APPROXIMATION. C Q3: A PARAMETER USED IN THE APPROXIMATION. C Q4: A PARAMETER USED IN THE APPROXIMATION. C R: THE PROBABILITY AT WHICH THE PERCENT POINT IS EVALUATED. C T: A VALUE USED IN THE APPROXIMATION. C TWO: THE VALUE 2.0D0. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DPPT IF (P.EQ.HALF) THEN DPPNML = ZERO ELSE R = P IF (P.GT.HALF) R = ONE - R T = SQRT(-TWO*LOG(R)) ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0) ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0) DPPNML = T + (ANUM/ADEN) IF (P.LT.HALF) DPPNML = -DPPNML END IF RETURN END *DPPT DOUBLE PRECISION FUNCTION DPPT + (P, IDF) C***BEGIN PROLOGUE DPPT C***REFER TO DODR,DODRC C***ROUTINES CALLED DPPNML C***DATE WRITTEN 901207 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***AUTHOR FILLIBEN, JAMES J., C STATISTICAL ENGINEERING DIVISION C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C (ORIGINAL VERSION--OCTOBER 1975.) C (UPDATED --NOVEMBER 1975.) C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE C STUDENT'S T DISTRIBUTION WITH IDF DEGREES OF FREEDOM. C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) C***DESCRIPTION C --FOR IDF = 1 AND IDF = 2, THE PERCENT POINT FUNCTION C FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM C AND SO THE COMPUTED PERCENT POINTS ARE EXACT. C --FOR IDF BETWEEN 3 AND 6, INCLUSIVELY, THE APPROXIMATION C IS AUGMENTED BY 3 ITERATIONS OF NEWTON'S METHOD TO C IMPROVE THE ACCURACY, ESPECIALLY FOR P NEAR 0 OR 1. C***REFERENCES NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS C SERIES 55, 1964, PAGE 949, FORMULA 26.7.5. C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, C VOLUME 2, 1970, PAGE 102, FORMULA 11. C FEDERIGHI, "EXTENDED TABLES OF THE PERCENTAGE POINTS C OF STUDENT"S T DISTRIBUTION, JOURNAL OF THE AMERICAN C STATISTICAL ASSOCIATION, 1969, PAGES 683-688. C HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS, A C HANDBOOK FOR STUDENTS AND PRACTITIONERS, 1975, C PAGES 120-123. C***END PROLOGUE DPPT C...SCALAR ARGUMENTS DOUBLE PRECISION + P INTEGER + IDF C...LOCAL SCALARS DOUBLE PRECISION + ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45, + B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,EIGHT,FIFTN, + HALF,ONE,PI,PPFN,S,TERM1,TERM2,TERM3,TERM4,TERM5,THREE,TWO, + Z,ZERO INTEGER + IPASS,MAXIT C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DPPNML EXTERNAL + DPPNML C...INTRINSIC FUNCTIONS INTRINSIC + ATAN,COS,SIN,SQRT C...DATA STATEMENTS DATA + B21 + /4.0D0/ DATA + B31, B32, B33, B34 + /96.0D0,5.0D0,16.0D0,3.0D0/ DATA + B41, B42, B43, B44, B45 + /384.0D0,3.0D0,19.0D0,17.0D0,-15.0D0/ DATA + B51,B52,B53,B54,B55,B56 + /9216.0D0,79.0D0,776.0D0,1482.0D0,-1920.0D0,-945.0D0/ DATA + ZERO,HALF,ONE,TWO,THREE,EIGHT,FIFTN + /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,8.0D0,15.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ARG: A VALUE USED IN THE APPROXIMATION. C B21: A PARAMETER USED IN THE APPROXIMATION. C B31: A PARAMETER USED IN THE APPROXIMATION. C B32: A PARAMETER USED IN THE APPROXIMATION. C B33: A PARAMETER USED IN THE APPROXIMATION. C B34: A PARAMETER USED IN THE APPROXIMATION. C B41: A PARAMETER USED IN THE APPROXIMATION. C B42: A PARAMETER USED IN THE APPROXIMATION. C B43: A PARAMETER USED IN THE APPROXIMATION. C B44: A PARAMETER USED IN THE APPROXIMATION. C B45: A PARAMETER USED IN THE APPROXIMATION. C B51: A PARAMETER USED IN THE APPROXIMATION. C B52: A PARAMETER USED IN THE APPROXIMATION. C B53: A PARAMETER USED IN THE APPROXIMATION. C B54: A PARAMETER USED IN THE APPROXIMATION. C B55: A PARAMETER USED IN THE APPROXIMATION. C B56: A PARAMETER USED IN THE APPROXIMATION. C C: A VALUE USED IN THE APPROXIMATION. C CON: A VALUE USED IN THE APPROXIMATION. C DF: THE DEGREES OF FREEDOM. C D1: A VALUE USED IN THE APPROXIMATION. C D3: A VALUE USED IN THE APPROXIMATION. C D5: A VALUE USED IN THE APPROXIMATION. C D7: A VALUE USED IN THE APPROXIMATION. C D9: A VALUE USED IN THE APPROXIMATION. C EIGHT: THE VALUE 8.0D0. C FIFTN: THE VALUE 15.0D0. C HALF: THE VALUE 0.5D0. C IDF: THE (POSITIVE INTEGER) DEGREES OF FREEDOM. C IPASS: A VALUE USED IN THE APPROXIMATION. C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR THE APPROX. C ONE: THE VALUE 1.0D0. C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE C EVALUATED. P MUST LIE BETWEEN 0.0DO AND 1.0D0, EXCLUSIVE. C PI: THE VALUE OF PI. C PPFN: THE NORMAL PERCENT POINT VALUE. C S: A VALUE USED IN THE APPROXIMATION. C TERM1: A VALUE USED IN THE APPROXIMATION. C TERM2: A VALUE USED IN THE APPROXIMATION. C TERM3: A VALUE USED IN THE APPROXIMATION. C TERM4: A VALUE USED IN THE APPROXIMATION. C TERM5: A VALUE USED IN THE APPROXIMATION. C THREE: THE VALUE 3.0D0. C TWO: THE VALUE 2.0D0. C Z: A VALUE USED IN THE APPROXIMATION. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DPPT PI = 3.141592653589793238462643383279D0 DF = IDF MAXIT = 5 IF (IDF.LE.0) THEN C TREAT THE IDF < 1 CASE DPPT = ZERO ELSE IF (IDF.EQ.1) THEN C TREAT THE IDF = 1 (CAUCHY) CASE ARG = PI*P DPPT = -COS(ARG)/SIN(ARG) ELSE IF (IDF.EQ.2) THEN C TREAT THE IDF = 2 CASE TERM1 = SQRT(TWO)/TWO TERM2 = TWO*P - ONE TERM3 = SQRT(P*(ONE-P)) DPPT = TERM1*TERM2/TERM3 ELSE IF (IDF.GE.3) THEN C TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE PPFN = DPPNML(P) D1 = PPFN D3 = PPFN**3 D5 = PPFN**5 D7 = PPFN**7 D9 = PPFN**9 TERM1 = D1 TERM2 = (ONE/B21)*(D3+D1)/DF TERM3 = (ONE/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2) TERM4 = (ONE/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) TERM5 = (ONE/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4) DPPT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5 IF (IDF.EQ.3) THEN C AUGMENT THE RESULTS FOR THE IDF = 3 CASE CON = PI*(P-HALF) ARG = DPPT/SQRT(DF) Z = ATAN(ARG) DO 70 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - (Z+S*C-CON)/(TWO*C**2) 70 CONTINUE DPPT = SQRT(DF)*S/C ELSE IF (IDF.EQ.4) THEN C AUGMENT THE RESULTS FOR THE IDF = 4 CASE CON = TWO*(P-HALF) ARG = DPPT/SQRT(DF) Z = ATAN(ARG) DO 90 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - ((ONE+HALF*C**2)*S-CON)/((ONE+HALF)*C**3) 90 CONTINUE DPPT = SQRT(DF)*S/C ELSE IF (IDF.EQ.5) THEN C AUGMENT THE RESULTS FOR THE IDF = 5 CASE CON = PI*(P-HALF) ARG = DPPT/SQRT(DF) Z = ATAN(ARG) DO 110 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - (Z+(C+(TWO/THREE)*C**3)*S-CON)/ + ((EIGHT/THREE)*C**4) 110 CONTINUE DPPT = SQRT(DF)*S/C ELSE IF (IDF.EQ.6) THEN C AUGMENT THE RESULTS FOR THE IDF = 6 CASE CON = TWO*(P-HALF) ARG = DPPT/SQRT(DF) Z = ATAN(ARG) DO 130 IPASS=1,MAXIT S = SIN(Z) C = COS(Z) Z = Z - ((ONE+HALF*C**2 + (THREE/EIGHT)*C**4)*S-CON)/ + ((FIFTN/EIGHT)*C**5) 130 CONTINUE DPPT = SQRT(DF)*S/C END IF END IF RETURN END *DPVB SUBROUTINE DPVB + (FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,STP, + ISTOP,NFEV,PVB, + WRK1,WRK2,WRK6) C***BEGIN PROLOGUE DPVB C***REFER TO DODR,DODRC C***ROUTINES CALLED FCN C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP C***END PROLOGUE DPVB C...SCALAR ARGUMENTS DOUBLE PRECISION + PVB,STP INTEGER + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + BETAJ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C BETAJ: THE CURRENT ESTIMATE OF THE JTH PARAMETER. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C PVB: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. C XPLUSD: THE VALUES OF X + DELTA. C***FIRST EXECUTABLE STATEMENT DPVB C COMPUTE PREDICTED VALUES BETAJ = BETA(J) BETA(J) = BETA(J) + STP ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + 003,WRK2,WRK6,WRK1, + ISTOP) IF (ISTOP.EQ.0) THEN NFEV = NFEV + 1 ELSE RETURN END IF BETA(J) = BETAJ PVB = WRK2(NROW,LQ) RETURN END *DPVD SUBROUTINE DPVD + (FCN, + N,M,NP,NQ, + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, + NROW,J,LQ,STP, + ISTOP,NFEV,PVD, + WRK1,WRK2,WRK6) C***BEGIN PROLOGUE DPVD C***REFER TO DODR,DODRC C***ROUTINES CALLED FCN C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE COMPUTE NROW-TH FUNCTION VALUE USING C X(NROW,J) + DELTA(NROW,J) + STP C***END PROLOGUE DPVD C...SCALAR ARGUMENTS DOUBLE PRECISION + PVD,STP INTEGER + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M) C...SUBROUTINE ARGUMENTS EXTERNAL + FCN C...LOCAL SCALARS DOUBLE PRECISION + XPDJ C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE C FIXED AT THEIR INPUT VALUES OR NOT. C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE C FIXED AT THEIR INPUT VALUES OR NOT. C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C PVD: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. C XPDJ: THE (NROW,J)TH ELEMENT OF XPLUSD. C XPLUSD: THE VALUES OF X + DELTA. C***FIRST EXECUTABLE STATEMENT DPVD C COMPUTE PREDICTED VALUES XPDJ = XPLUSD(NROW,J) XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP ISTOP = 0 CALL FCN(N,M,NP,NQ, + N,M,NP, + BETA,XPLUSD, + IFIXB,IFIXX,LDIFX, + 003,WRK2,WRK6,WRK1, + ISTOP) IF (ISTOP.EQ.0) THEN NFEV = NFEV + 1 ELSE RETURN END IF XPLUSD(NROW,J) = XPDJ PVD = WRK2(NROW,LQ) RETURN END *DSCALE SUBROUTINE DSCALE + (N,M,SCL,LDSCL,T,LDT,SCLT,LDSCLT) C***BEGIN PROLOGUE DSCALE C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SCALE T BY THE INVERSE OF SCL, I.E., COMPUTE T/SCL C***END PROLOGUE DSCALE C...SCALAR ARGUMENTS INTEGER + LDT,LDSCL,LDSCLT,M,N C...ARRAY ARGUMENTS DOUBLE PRECISION + T(LDT,M),SCL(LDSCL,M),SCLT(LDSCLT,M) C...LOCAL SCALARS DOUBLE PRECISION + ONE,TEMP,ZERO INTEGER + I,J C...INTRINSIC FUNCTIONS INTRINSIC + ABS C...DATA STATEMENTS DATA + ONE,ZERO + /1.0D0,0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C I: AN INDEXING VARIABLE. C J: AN INDEXING VARIABLE. C LDSCL: THE LEADING DIMENSION OF ARRAY SCL. C LDSCLT: THE LEADING DIMENSION OF ARRAY SCLT. C LDT: THE LEADING DIMENSION OF ARRAY T. C M: THE NUMBER OF COLUMNS OF DATA IN T. C N: THE NUMBER OF ROWS OF DATA IN T. C ONE: THE VALUE 1.0D0. C SCL: THE SCALE VALUES. C SCLT: THE INVERSELY SCALED MATRIX. C T: THE ARRAY TO BE INVERSELY SCALED BY SCL. C TEMP: A TEMPORARY SCALAR. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DSCALE IF (N.EQ.0 .OR. M.EQ.0) RETURN IF (SCL(1,1).GE.ZERO) THEN IF (LDSCL.GE.N) THEN DO 80 J=1,M DO 70 I=1,N SCLT(I,J) = T(I,J)/SCL(I,J) 70 CONTINUE 80 CONTINUE ELSE DO 100 J=1,M TEMP = ONE/SCL(1,J) DO 90 I=1,N SCLT(I,J) = T(I,J)*TEMP 90 CONTINUE 100 CONTINUE END IF ELSE TEMP = ONE/ABS(SCL(1,1)) DO 120 J=1,M DO 110 I=1,N SCLT(I,J) = T(I,J)*TEMP 110 CONTINUE 120 CONTINUE END IF RETURN END *DSCLB SUBROUTINE DSCLB + (NP,BETA,SSF) C***BEGIN PROLOGUE DSCLB C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SELECT SCALING VALUES FOR BETA ACCORDING TO THE C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE C***END PROLOGUE DSCLB C...SCALAR ARGUMENTS INTEGER + NP C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),SSF(NP) C...LOCAL SCALARS DOUBLE PRECISION + BMAX,BMIN,ONE,TEN,ZERO INTEGER + K LOGICAL + BIGDIF C...INTRINSIC FUNCTIONS INTRINSIC + ABS,LOG10,MAX,MIN,SQRT C...DATA STATEMENTS DATA + ZERO,ONE,TEN + /0.0D0,1.0D0,10.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BETA: THE FUNCTION PARAMETERS. C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF C BETA (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). C BMAX: THE LARGEST NONZERO MAGNITUDE. C BMIN: THE SMALLEST NONZERO MAGNITUDE. C K: AN INDEXING VARIABLE. C NP: THE NUMBER OF FUNCTION PARAMETERS. C ONE: THE VALUE 1.0D0. C SSF: THE SCALING VALUES FOR BETA. C TEN: THE VALUE 10.0D0. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DSCLB BMAX = ABS(BETA(1)) DO 10 K=2,NP BMAX = MAX(BMAX,ABS(BETA(K))) 10 CONTINUE IF (BMAX.EQ.ZERO) THEN C ALL INPUT VALUES OF BETA ARE ZERO DO 20 K=1,NP SSF(K) = ONE 20 CONTINUE ELSE C SOME OF THE INPUT VALUES ARE NONZERO BMIN = BMAX DO 30 K=1,NP IF (BETA(K).NE.ZERO) THEN BMIN = MIN(BMIN,ABS(BETA(K))) END IF 30 CONTINUE BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE DO 40 K=1,NP IF (BETA(K).EQ.ZERO) THEN SSF(K) = TEN/BMIN ELSE IF (BIGDIF) THEN SSF(K) = ONE/ABS(BETA(K)) ELSE SSF(K) = ONE/BMAX END IF END IF 40 CONTINUE END IF RETURN END *DSCLD SUBROUTINE DSCLD + (N,M,X,LDX,TT,LDTT) C***BEGIN PROLOGUE DSCLD C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SELECT SCALING VALUES FOR DELTA ACCORDING TO THE C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE C***END PROLOGUE DSCLD C...SCALAR ARGUMENTS INTEGER + LDTT,LDX,M,N C...ARRAY ARGUMENTS DOUBLE PRECISION + TT(LDTT,M),X(LDX,M) C...LOCAL SCALARS DOUBLE PRECISION + ONE,TEN,XMAX,XMIN,ZERO INTEGER + I,J LOGICAL + BIGDIF C...INTRINSIC FUNCTIONS INTRINSIC + ABS,LOG10,MAX,MIN C...DATA STATEMENTS DATA + ZERO,ONE,TEN + /0.0D0,1.0D0,10.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF C X (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). C I: AN INDEXING VARIABLE. C J: AN INDEXING VARIABLE. C LDTT: THE LEADING DIMENSION OF ARRAY TT. C LDX: THE LEADING DIMENSION OF ARRAY X. C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C ONE: THE VALUE 1.0D0. C TT: THE SCALING VALUES FOR DELTA. C X: THE INDEPENDENT VARIABLE. C XMAX: THE LARGEST NONZERO MAGNITUDE. C XMIN: THE SMALLEST NONZERO MAGNITUDE. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DSCLD DO 50 J=1,M XMAX = ABS(X(1,J)) DO 10 I=2,N XMAX = MAX(XMAX,ABS(X(I,J))) 10 CONTINUE IF (XMAX.EQ.ZERO) THEN C ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO DO 20 I=1,N TT(I,J) = ONE 20 CONTINUE ELSE C SOME OF THE INPUT VALUES ARE NONZERO XMIN = XMAX DO 30 I=1,N IF (X(I,J).NE.ZERO) THEN XMIN = MIN(XMIN,ABS(X(I,J))) END IF 30 CONTINUE BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE DO 40 I=1,N IF (X(I,J).NE.ZERO) THEN IF (BIGDIF) THEN TT(I,J) = ONE/ABS(X(I,J)) ELSE TT(I,J) = ONE/XMAX END IF ELSE TT(I,J) = TEN/XMIN END IF 40 CONTINUE END IF 50 CONTINUE RETURN END *DSETN SUBROUTINE DSETN + (N,M,X,LDX,NROW) C***BEGIN PROLOGUE DSETN C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED C***END PROLOGUE DSETN C...SCALAR ARGUMENTS INTEGER + LDX,M,N,NROW C...ARRAY ARGUMENTS DOUBLE PRECISION + X(LDX,M) C...LOCAL SCALARS INTEGER + I,J C...VARIABLE DEFINITIONS (ALPHABETICALLY) C I: AN INDEX VARIABLE. C J: AN INDEX VARIABLE. C LDX: THE LEADING DIMENSION OF ARRAY X. C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NROW: THE SELECTED ROW NUMBER OF THE INDEPENDENT VARIABLE. C X: THE INDEPENDENT VARIABLE. C***FIRST EXECUTABLE STATEMENT DSETN IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS C IF THERE IS ONE, OTHERWISE FIRST ROW IS USED. DO 20 I = 1, N DO 10 J = 1, M IF (X(I,J).EQ.0.0) GO TO 20 10 CONTINUE NROW = I RETURN 20 CONTINUE NROW = 1 RETURN END *DSOLVE SUBROUTINE DSOLVE(N,T,LDT,B,LDB,JOB) C***BEGIN PROLOGUE DSOLVE C***REFER TO DODR,DODRC C***ROUTINES CALLED DAXPY,DDOT C***DATE WRITTEN 920220 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE SOLVE SYSTEMS OF THE FORM C T * X = B OR TRANS(T) * X = B C WHERE T IS AN UPPER OR LOWER TRIANGULAR MATRIX OF ORDER N, C AND THE SOLUTION X OVERWRITES THE RHS B. C (ADAPTED FROM LINPACK SUBROUTINE DTRSL) C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***END PROLOGUE DSOLVE C...SCALAR ARGUMENTS INTEGER + JOB,LDB,LDT,N C...ARRAY ARGUMENTS DOUBLE PRECISION + B(LDB,N),T(LDT,N) C...LOCAL SCALARS DOUBLE PRECISION + TEMP,ZERO INTEGER + J1,J,JN C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT EXTERNAL + DDOT C...EXTERNAL SUBROUTINES EXTERNAL + DAXPY C...DATA STATEMENTS DATA + ZERO + /0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C B: ON INPUT: THE RIGHT HAND SIDE; ON EXIT: THE SOLUTION C J1: THE FIRST NONZERO ENTRY IN T. C J: AN INDEXING VARIABLE. C JN: THE LAST NONZERO ENTRY IN T. C JOB: WHAT KIND OF SYSTEM IS TO BE SOLVED, WHERE IF JOB IS C 1 SOLVE T*X=B, T LOWER TRIANGULAR, C 2 SOLVE T*X=B, T UPPER TRIANGULAR, C 3 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, C 4 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. C LDB: THE LEADING DIMENSION OF ARRAY B. C LDT: THE LEADING DIMENSION OF ARRAY T. C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY T. C T: THE UPPER OR LOWER TRIDIAGONAL SYSTEM. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DSOLVE C FIND FIRST NONZERO DIAGONAL ENTRY IN T J1 = 0 DO 10 J=1,N IF (J1.EQ.0 .AND. T(J,J).NE.ZERO) THEN J1 = J ELSE IF (T(J,J).EQ.ZERO) THEN B(1,J) = ZERO END IF 10 CONTINUE IF (J1.EQ.0) RETURN C FIND LAST NONZERO DIAGONAL ENTRY IN T JN = 0 DO 20 J=N,J1,-1 IF (JN.EQ.0 .AND. T(J,J).NE.ZERO) THEN JN = J ELSE IF (T(J,J).EQ.ZERO) THEN B(1,J) = ZERO END IF 20 CONTINUE IF (JOB.EQ.1) THEN C SOLVE T*X=B FOR T LOWER TRIANGULAR B(1,J1) = B(1,J1)/T(J1,J1) DO 30 J = J1+1, JN TEMP = -B(1,J-1) CALL DAXPY(JN-J+1,TEMP,T(J,J-1),1,B(1,J),LDB) IF (T(J,J).NE.ZERO) THEN B(1,J) = B(1,J)/T(J,J) ELSE B(1,J) = ZERO END IF 30 CONTINUE ELSE IF (JOB.EQ.2) THEN C SOLVE T*X=B FOR T UPPER TRIANGULAR. B(1,JN) = B(1,JN)/T(JN,JN) DO 40 J = JN-1,J1,-1 TEMP = -B(1,J+1) CALL DAXPY(J,TEMP,T(1,J+1),1,B(1,1),LDB) IF (T(J,J).NE.ZERO) THEN B(1,J) = B(1,J)/T(J,J) ELSE B(1,J) = ZERO END IF 40 CONTINUE ELSE IF (JOB.EQ.3) THEN C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. B(1,JN) = B(1,JN)/T(JN,JN) DO 50 J = JN-1,J1,-1 B(1,J) = B(1,J) - DDOT(JN-J+1,T(J+1,J),1,B(1,J+1),LDB) IF (T(J,J).NE.ZERO) THEN B(1,J) = B(1,J)/T(J,J) ELSE B(1,J) = ZERO END IF 50 CONTINUE ELSE IF (JOB.EQ.4) THEN C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. B(1,J1) = B(1,J1)/T(J1,J1) DO 60 J = J1+1,JN B(1,J) = B(1,J) - DDOT(J-1,T(1,J),1,B(1,1),LDB) IF (T(J,J).NE.ZERO) THEN B(1,J) = B(1,J)/T(J,J) ELSE B(1,J) = ZERO END IF 60 CONTINUE END IF RETURN END *DUNPAC SUBROUTINE DUNPAC + (N2,V1,V2,IFIX) C***BEGIN PROLOGUE DUNPAC C***REFER TO DODR,DODRC C***ROUTINES CALLED DCOPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE C UNFIXED C***END PROLOGUE DUNPAC C...SCALAR ARGUMENTS INTEGER + N2 C...ARRAY ARGUMENTS DOUBLE PRECISION + V1(N2),V2(N2) INTEGER + IFIX(N2) C...LOCAL SCALARS INTEGER + I,N1 C...EXTERNAL SUBROUTINES EXTERNAL + DCOPY C...VARIABLE DEFINITIONS (ALPHABETICALLY) C I: AN INDEXING VARIABLE. C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE C FIXED AT THEIR INPUT VALUES OR NOT. C ODRPACK REFERENCE GUIDE.) C N1: THE NUMBER OF ITEMS IN V1. C N2: THE NUMBER OF ITEMS IN V2. C V1: THE VECTOR OF THE UNFIXED ITEMS. C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE C ELEMENTS OF V1 ARE TO BE INSERTED. C***FIRST EXECUTABLE STATEMENT DUNPAC N1 = 0 IF (IFIX(1).GE.0) THEN DO 10 I = 1,N2 IF (IFIX(I).NE.0) THEN N1 = N1 + 1 V2(I) = V1(N1) END IF 10 CONTINUE ELSE N1 = N2 CALL DCOPY(N2,V1,1,V2,1) END IF RETURN END *DVEVTR SUBROUTINE DVEVTR + (M,NQ,INDX, + V,LDV,LD2V, E,LDE, VE,LDVE,LD2VE, VEV,LDVEV, + WRK5) C***BEGIN PROLOGUE DVEVTR C***REFER TO DODR,DODRC C***ROUTINES CALLED DSOLVE C***DATE WRITTEN 910613 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE COMPUTE V*E*TRANS(V) FOR THE (INDX)TH M BY NQ ARRAY IN V C***END PROLOGUE DVEVTR C...SCALAR ARGUMENTS INTEGER + INDX,LDE,LDV,LDVE,LDVEV,LD2V,LD2VE,M,NQ C...ARRAY ARGUMENTS DOUBLE PRECISION + E(LDE,M),V(LDV,LD2V,NQ),VE(LDVE,LD2VE,M),VEV(LDVEV,NQ),WRK5(M) C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + J,L1,L2 C...EXTERNAL SUBROUTINES EXTERNAL + DSOLVE C...DATA STATEMENTS DATA + ZERO + /0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INDX: THE ROW IN V IN WHICH THE M BY NQ ARRAY IS STORED. C J: AN INDEXING VARIABLE. C LDE: THE LEADING DIMENSION OF ARRAY E. C LDV: THE LEADING DIMENSION OF ARRAY V. C LDVE: THE LEADING DIMENSION OF ARRAY VE. C LDVEV: THE LEADING DIMENSION OF ARRAY VEV. C LD2V: THE SECOND DIMENSION OF ARRAY V. C L1: AN INDEXING VARIABLE. C L2: AN INDEXING VARIABLE. C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C E: THE M BY M MATRIX OF THE FACTORS SO ETE = (D**2 + ALPHA*T**2). C V: AN ARRAY OF NQ BY M MATRICES. C VE: THE NQ BY M ARRAY VE = V * INV(E) C VEV: THE NQ BY NQ ARRAY VEV = V * INV(ETE) * TRANS(V). C WRK5: AN M WORK VECTOR. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DVEVTR IF (NQ.EQ.0 .OR. M.EQ.0) RETURN DO 140 L1 = 1,NQ DO 110 J = 1,M WRK5(J) = V(INDX,J,L1) 110 CONTINUE CALL DSOLVE(M,E,LDE,WRK5,1,4) DO 120 J = 1,M VE(INDX,L1,J) = WRK5(J) 120 CONTINUE 140 CONTINUE DO 230 L1 = 1,NQ DO 220 L2 = 1,L1 VEV(L1,L2) = ZERO DO 210 J = 1,M VEV(L1,L2) = VEV(L1,L2) + VE(INDX,L1,J)*VE(INDX,L2,J) 210 CONTINUE VEV(L2,L1) = VEV(L1,L2) 220 CONTINUE 230 CONTINUE RETURN END *DWGHT SUBROUTINE DWGHT + (N,M,WT,LDWT,LD2WT,T,LDT,WTT,LDWTT) C***BEGIN PROLOGUE DWGHT C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SCALE MATRIX T USING WT, I.E., COMPUTE WTT = WT*T C***END PROLOGUE DWGHT C...SCALAR ARGUMENTS INTEGER + LDT,LDWT,LDWTT,LD2WT,M,N C...ARRAY ARGUMENTS DOUBLE PRECISION + T(LDT,M),WT(LDWT,LD2WT,M),WTT(LDWTT,M) C...LOCAL SCALARS DOUBLE PRECISION + TEMP,ZERO INTEGER + I,J,K C...INTRINSIC FUNCTIONS INTRINSIC + ABS C...DATA STATEMENTS DATA + ZERO + /0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C I: AN INDEXING VARIABLE. C J: AN INDEXING VARIABLE. C K: AN INDEXING VARIABLE. C LDT: THE LEADING DIMENSION OF ARRAY T. C LDWT: THE LEADING DIMENSION OF ARRAY WT. C LDWTT: THE LEADING DIMENSION OF ARRAY WTT. C LD2WT: THE SECOND DIMENSION OF ARRAY WT. C M: THE NUMBER OF COLUMNS OF DATA IN T. C N: THE NUMBER OF ROWS OF DATA IN T. C T: THE ARRAY BEING SCALED BY WT. C TEMP: A TEMPORARY SCALAR. C WT: THE WEIGHTS. C WTT: THE RESULTS OF WEIGHTING ARRAY T BY WT. C ARRAY WTT CAN BE THE SAME AS T ONLY IF THE ARRAYS IN WT C ARE UPPER TRIANGULAR WITH ZEROS BELOW THE DIAGONAL. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DWGHT IF (N.EQ.0 .OR. M.EQ.0) RETURN IF (WT(1,1,1).GE.ZERO) THEN IF (LDWT.GE.N) THEN IF (LD2WT.GE.M) THEN C WT IS AN N-ARRAY OF M BY M MATRICES DO 130 I=1,N DO 120 J=1,M TEMP = ZERO DO 110 K=1,M TEMP = TEMP + WT(I,J,K)*T(I,K) 110 CONTINUE WTT(I,J) = TEMP 120 CONTINUE 130 CONTINUE ELSE C WT IS AN N-ARRAY OF DIAGONAL MATRICES DO 230 I=1,N DO 220 J=1,M WTT(I,J) = WT(I,1,J)*T(I,J) 220 CONTINUE 230 CONTINUE END IF ELSE IF (LD2WT.GE.M) THEN C WT IS AN M BY M MATRIX DO 330 I=1,N DO 320 J=1,M TEMP = ZERO DO 310 K=1,M TEMP = TEMP + WT(1,J,K)*T(I,K) 310 CONTINUE WTT(I,J) = TEMP 320 CONTINUE 330 CONTINUE ELSE C WT IS A DIAGONAL MATRICE DO 430 I=1,N DO 420 J=1,M WTT(I,J) = WT(1,1,J)*T(I,J) 420 CONTINUE 430 CONTINUE END IF END IF ELSE C WT IS A SCALAR DO 520 J=1,M DO 510 I=1,N WTT(I,J) = ABS(WT(1,1,1))*T(I,J) 510 CONTINUE 520 CONTINUE END IF RETURN END *DWINF SUBROUTINE DWINF + (N,M,NP,NQ,LDWE,LD2WE,ISODR, + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, + PARTLI,SSTOLI,TAUFCI,EPSMAI, + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, + FSI,FJACBI,WE1I,DIFFI, + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + LWKMN) C***BEGIN PROLOGUE DWINF C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920619 (YYMMDD) C***PURPOSE SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE C***END PROLOGUE DWINF C...SCALAR ARGUMENTS INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, + DIFFI,EPSI,EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,LDWE,LD2WE,LWKMN, + M,N,NP,NQ,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI, + WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, + WSSI,WSSDEI,WSSEPI,XPLUSI LOGICAL + ISODR C...LOCAL SCALARS INTEGER + NEXT C...VARIABLE DEFINITIONS (ALPHABETICALLY) C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). C LDWE: THE LEADING DIMENSION OF ARRAY WE. C LD2WE: THE SECOND DIMENSION OF ARRAY WE. C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF VECTOR WORK. C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. C N: THE NUMBER OF OBSERVATIONS. C NEXT: THE NEXT AVAILABLE LOCATION WITH WORK. C NP: THE NUMBER OF FUNCTION PARAMETERS. C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCONDI. C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. C***FIRST EXECUTABLE STATEMENT DWINF IF (N.GE.1 .AND. M.GE.1 .AND. NP.GE.1 .AND. NQ.GE.1 .AND. + LDWE.GE.1 .AND. LD2WE.GE.1) THEN DELTAI = 1 EPSI = DELTAI + N*M XPLUSI = EPSI + N*NQ FNI = XPLUSI + N*M SDI = FNI + N*NQ VCVI = SDI + NP RVARI = VCVI + NP*NP WSSI = RVARI + 1 WSSDEI = WSSI + 1 WSSEPI = WSSDEI + 1 RCONDI = WSSEPI + 1 ETAI = RCONDI + 1 OLMAVI = ETAI + 1 TAUI = OLMAVI + 1 ALPHAI = TAUI + 1 ACTRSI = ALPHAI + 1 PNORMI = ACTRSI + 1 RNORSI = PNORMI + 1 PRERSI = RNORSI + 1 PARTLI = PRERSI + 1 SSTOLI = PARTLI + 1 TAUFCI = SSTOLI + 1 EPSMAI = TAUFCI + 1 BETA0I = EPSMAI + 1 BETACI = BETA0I + NP BETASI = BETACI + NP BETANI = BETASI + NP SI = BETANI + NP SSI = SI + NP SSFI = SSI + NP QRAUXI = SSFI + NP UI = QRAUXI + NP FSI = UI + NP FJACBI = FSI + N*NQ WE1I = FJACBI + N*NP*NQ DIFFI = WE1I + LDWE*LD2WE*NQ NEXT = DIFFI + NQ*(NP+M) IF (ISODR) THEN DELTSI = NEXT DELTNI = DELTSI + N*M TI = DELTNI + N*M TTI = TI + N*M OMEGAI = TTI + N*M FJACDI = OMEGAI + NQ*NQ WRK1I = FJACDI + N*M*NQ NEXT = WRK1I + N*M*NQ ELSE DELTSI = DELTAI DELTNI = DELTAI TI = DELTAI TTI = DELTAI OMEGAI = DELTAI FJACDI = DELTAI WRK1I = DELTAI END IF WRK2I = NEXT WRK3I = WRK2I + N*NQ WRK4I = WRK3I + NP WRK5I = WRK4I + M*M WRK6I = WRK5I + M WRK7I = WRK6I + N*NQ*NP NEXT = WRK7I + 5*NQ LWKMN = NEXT ELSE DELTAI = 1 EPSI = 1 XPLUSI = 1 FNI = 1 SDI = 1 VCVI = 1 RVARI = 1 WSSI = 1 WSSDEI = 1 WSSEPI = 1 RCONDI = 1 ETAI = 1 OLMAVI = 1 TAUI = 1 ALPHAI = 1 ACTRSI = 1 PNORMI = 1 RNORSI = 1 PRERSI = 1 PARTLI = 1 SSTOLI = 1 TAUFCI = 1 EPSMAI = 1 BETA0I = 1 BETACI = 1 BETASI = 1 BETANI = 1 SI = 1 SSI = 1 SSFI = 1 QRAUXI = 1 FSI = 1 UI = 1 FJACBI = 1 WE1I = 1 DIFFI = 1 DELTSI = 1 DELTNI = 1 TI = 1 TTI = 1 FJACDI = 1 OMEGAI = 1 WRK1I = 1 WRK2I = 1 WRK3I = 1 WRK4I = 1 WRK5I = 1 WRK6I = 1 WRK7I = 1 LWKMN = 1 END IF RETURN END *DXMY SUBROUTINE DXMY + (N,M,X,LDX,Y,LDY,XMY,LDXMY) C***BEGIN PROLOGUE DXMY C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE COMPUTE XMY = X - Y C***END PROLOGUE DXMY C...SCALAR ARGUMENTS INTEGER + LDX,LDXMY,LDY,M,N C...ARRAY ARGUMENTS DOUBLE PRECISION + X(LDX,M),XMY(LDXMY,M),Y(LDY,M) C...LOCAL SCALARS INTEGER + I,J C...VARIABLE DEFINITIONS (ALPHABETICALLY) C I: AN INDEXING VARIABLE. C J: AN INDEXING VARIABLE. C LDX: THE LEADING DIMENSION OF ARRAY X. C LDXMY: THE LEADING DIMENSION OF ARRAY XMY. C LDY: THE LEADING DIMENSION OF ARRAY Y. C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. C X: THE FIRST OF THE TWO ARRAYS. C XMY: THE VALUES OF X-Y. C Y: THE SECOND OF THE TWO ARRAYS. C***FIRST EXECUTABLE STATEMENT DXMY DO 20 J=1,M DO 10 I=1,N XMY(I,J) = X(I,J) - Y(I,J) 10 CONTINUE 20 CONTINUE RETURN END *DXPY SUBROUTINE DXPY + (N,M,X,LDX,Y,LDY,XPY,LDXPY) C***BEGIN PROLOGUE DXPY C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE COMPUTE XPY = X + Y C***END PROLOGUE DXPY C...SCALAR ARGUMENTS INTEGER + LDX,LDXPY,LDY,M,N C...ARRAY ARGUMENTS DOUBLE PRECISION + X(LDX,M),XPY(LDXPY,M),Y(LDY,M) C...LOCAL SCALARS INTEGER + I,J C...VARIABLE DEFINITIONS (ALPHABETICALLY) C I: AN INDEXING VARIABLE. C J: AN INDEXING VARIABLE. C LDX: THE LEADING DIMENSION OF ARRAY X. C LDXPY: THE LEADING DIMENSION OF ARRAY XPY. C LDY: THE LEADING DIMENSION OF ARRAY Y. C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. C X: THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER. C XPY: THE VALUES OF X+Y. C Y: THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER. C***FIRST EXECUTABLE STATEMENT DXPY DO 20 J=1,M DO 10 I=1,N XPY(I,J) = X(I,J) + Y(I,J) 10 CONTINUE 20 CONTINUE RETURN END *DZERO SUBROUTINE DZERO + (N,M,A,LDA) C***BEGIN PROLOGUE DZERO C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 920304 (YYMMDD) C***PURPOSE SET A = ZERO C***END PROLOGUE DZERO C...SCALAR ARGUMENTS INTEGER + LDA,M,N C...ARRAY ARGUMENTS DOUBLE PRECISION + A(LDA,M) C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + I,J C...DATA STATEMENTS DATA + ZERO + /0.0D0/ C...VARIABLE DEFINITIONS (ALPHABETICALLY) C A: THE ARRAY TO BE SET TO ZERO. C I: AN INDEXING VARIABLE. C J: AN INDEXING VARIABLE. C LDA: THE LEADING DIMENSION OF ARRAY A. C M: THE NUMBER OF COLUMNS TO BE SET TO ZERO. C N: THE NUMBER OF ROWS TO BE SET TO ZERO. C ZERO: THE VALUE 0.0D0. C***FIRST EXECUTABLE STATEMENT DZERO DO 20 J=1,M DO 10 I=1,N A(I,J) = ZERO 10 CONTINUE 20 CONTINUE RETURN END