1*DODR 2 SUBROUTINE DODR 3 + (FCN, 4 + N,M,NP,NQ, 5 + BETA, 6 + Y,LDY,X,LDX, 7 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, 8 + JOB, 9 + IPRINT,LUNERR,LUNRPT, 10 + WORK,LWORK,IWORK,LIWORK, 11 + INFO) 12C***BEGIN PROLOGUE DODR 13C***DATE WRITTEN 860529 (YYMMDD) 14C***REVISION DATE 920619 (YYMMDD) 15C***CATEGORY NO. G2E,I1B1 16C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, 17C NONLINEAR LEAST SQUARES, 18C MEASUREMENT ERROR MODELS, 19C ERRORS IN VARIABLES 20C***AUTHOR BOGGS, PAUL T. 21C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION 22C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 23C GAITHERSBURG, MD 20899 24C BYRD, RICHARD H. 25C DEPARTMENT OF COMPUTER SCIENCE 26C UNIVERSITY OF COLORADO, BOULDER, CO 80309 27C ROGERS, JANET E. 28C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION 29C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 30C BOULDER, CO 80303-3328 31C SCHNABEL, ROBERT B. 32C DEPARTMENT OF COMPUTER SCIENCE 33C UNIVERSITY OF COLORADO, BOULDER, CO 80309 34C AND 35C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION 36C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 37C BOULDER, CO 80303-3328 38C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING 39C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE 40C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST 41C SQUARES (OLS) SOLUTION (SHORT CALL STATEMENT) 42C***DESCRIPTION 43C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. 44C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND 45C R. B. SCHNABEL (1989), 46C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED 47C ORTHOGONAL DISTANCE REGRESSION," 48C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. 49C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND 50C R. B. SCHNABEL (1992), 51C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, 52C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," 53C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 54C INTERNAL REPORT NUMBER 92-4834. 55C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), 56C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR 57C ORTHOGONAL DISTANCE REGRESSION," 58C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. 59C***ROUTINES CALLED DODCNT 60C***END PROLOGUE DODR 61 62C...SCALAR ARGUMENTS 63 INTEGER 64 + INFO,JOB,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,LIWORK,LWORK, 65 + M,N,NDIGIT,NP,NQ 66 67C...ARRAY ARGUMENTS 68 DOUBLE PRECISION 69 + BETA(NP),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), 70 + X(LDX,M),Y(LDY,NQ) 71 INTEGER 72 + IWORK(LIWORK) 73 74C...SUBROUTINE ARGUMENTS 75 EXTERNAL 76 + FCN 77 78C...LOCAL SCALARS 79 DOUBLE PRECISION 80 + NEGONE,PARTOL,SSTOL,TAUFAC,ZERO 81 INTEGER 82 + IPRINT,LDIFX,LDSCLD,LDSTPD,LUNERR,LUNRPT,MAXIT 83 LOGICAL 84 + SHORT 85 86C...LOCAL ARRAYS 87 DOUBLE PRECISION 88 + SCLB(1),SCLD(1,1),STPB(1),STPD(1,1),WD1(1,1,1) 89 INTEGER 90 + IFIXB(1),IFIXX(1,1) 91 92C...EXTERNAL SUBROUTINES 93 EXTERNAL 94 + DODCNT 95 96C...DATA STATEMENTS 97 DATA 98 + NEGONE,ZERO 99 + /-1.0D0,0.0D0/ 100 101C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 102C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 103 104C...VARIABLE DEFINITIONS (ALPHABETICALLY) 105C BETA: THE FUNCTION PARAMETERS. 106C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 107C FIXED AT THEIR INPUT VALUES OR NOT. 108C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 109C FIXED AT THEIR INPUT VALUES OR NOT. 110C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 111C IPRINT: THE PRINT CONTROL VARIABLE. 112C IWORK: THE INTEGER WORK SPACE. 113C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 114C COMPUTATIONAL METHOD. 115C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 116C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. 117C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 118C LDWD: THE LEADING DIMENSION OF ARRAY WD. 119C LDWE: THE LEADING DIMENSION OF ARRAY WE. 120C LDX: THE LEADING DIMENSION OF ARRAY X. 121C LDY: THE LEADING DIMENSION OF ARRAY Y. 122C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 123C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 124C LIWORK: THE LENGTH OF VECTOR IWORK. 125C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. 126C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. 127C LWORK: THE LENGTH OF VECTOR WORK. 128C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 129C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 130C N: THE NUMBER OF OBSERVATIONS. 131C NEGONE: THE VALUE -1.0D0. 132C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS 133C SUPPLIED BY THE USER. 134C NP: THE NUMBER OF FUNCTION PARAMETERS. 135C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 136C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. 137C SCLB: THE SCALING VALUES FOR BETA. 138C SCLD: THE SCALING VALUES FOR DELTA. 139C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 140C DERIVATIVES WITH RESPECT TO BETA. 141C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 142C DERIVATIVES WITH RESPECT TO DELTA. 143C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 144C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL 145C (SHORT=.FALSE.). 146C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. 147C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 148C DIAMETER. 149C WD: THE DELTA WEIGHTS. 150C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. 151C WE: THE EPSILON WEIGHTS. 152C WORK: THE DOUBLE PRECISION WORK SPACE. 153C X: THE EXPLANATORY VARIABLE. 154C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. 155 156 157C***FIRST EXECUTABLE STATEMENT DODR 158 159 160C INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES 161 162 IFIXB(1) = -1 163 IFIXX(1,1) = -1 164 LDIFX = 1 165 NDIGIT = -1 166 TAUFAC = NEGONE 167 SSTOL = NEGONE 168 PARTOL = NEGONE 169 MAXIT = -1 170 STPB(1) = NEGONE 171 STPD(1,1) = NEGONE 172 LDSTPD = 1 173 SCLB(1) = NEGONE 174 SCLD(1,1) = NEGONE 175 LDSCLD = 1 176 177 SHORT = .TRUE. 178 179 IF (WD(1,1,1).NE.ZERO) THEN 180 CALL DODCNT 181 + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, 182 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, 183 + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, 184 + IPRINT,LUNERR,LUNRPT, 185 + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, 186 + WORK,LWORK,IWORK,LIWORK, 187 + INFO) 188 ELSE 189 WD1(1,1,1) = NEGONE 190 CALL DODCNT 191 + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, 192 + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, 193 + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, 194 + IPRINT,LUNERR,LUNRPT, 195 + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, 196 + WORK,LWORK,IWORK,LIWORK, 197 + INFO) 198 END IF 199 200 RETURN 201 202 END 203*DODRC 204 SUBROUTINE DODRC 205 + (FCN, 206 + N,M,NP,NQ, 207 + BETA, 208 + Y,LDY,X,LDX, 209 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, 210 + IFIXB,IFIXX,LDIFX, 211 + JOB,NDIGIT,TAUFAC, 212 + SSTOL,PARTOL,MAXIT, 213 + IPRINT,LUNERR,LUNRPT, 214 + STPB,STPD,LDSTPD, 215 + SCLB,SCLD,LDSCLD, 216 + WORK,LWORK,IWORK,LIWORK, 217 + INFO) 218C***BEGIN PROLOGUE DODRC 219C***DATE WRITTEN 860529 (YYMMDD) 220C***REVISION DATE 920619 (YYMMDD) 221C***CATEGORY NO. G2E,I1B1 222C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, 223C NONLINEAR LEAST SQUARES, 224C MEASUREMENT ERROR MODELS, 225C ERRORS IN VARIABLES 226C***AUTHOR BOGGS, PAUL T. 227C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION 228C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 229C GAITHERSBURG, MD 20899 230C BYRD, RICHARD H. 231C DEPARTMENT OF COMPUTER SCIENCE 232C UNIVERSITY OF COLORADO, BOULDER, CO 80309 233C ROGERS, JANET E. 234C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION 235C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 236C BOULDER, CO 80303-3328 237C SCHNABEL, ROBERT B. 238C DEPARTMENT OF COMPUTER SCIENCE 239C UNIVERSITY OF COLORADO, BOULDER, CO 80309 240C AND 241C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION 242C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 243C BOULDER, CO 80303-3328 244C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING 245C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE 246C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST 247C SQUARES (OLS) SOLUTION (LONG CALL STATEMENT) 248C***DESCRIPTION 249C FOR DETAILS, SEE ODRPACK USER'S REFERENCE GUIDE. 250C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND 251C R. B. SCHNABEL (1989), 252C "ALGORITHM 676 --- ODRPACK: SOFTWARE FOR WEIGHTED 253C ORTHOGONAL DISTANCE REGRESSION," 254C ACM TRANS. MATH. SOFTWARE., 15(4):348-364. 255C BOGGS, P. T., R. H. BYRD, J. E. ROGERS, AND 256C R. B. SCHNABEL (1992), 257C "USER'S REFERENCE GUIDE FOR ODRPACK VERSION 2.01, 258C SOFTWARE FOR WEIGHTED ORTHOGONAL DISTANCE REGRESSION," 259C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY 260C INTERNAL REPORT NUMBER 92-4834. 261C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), 262C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR 263C ORTHOGONAL DISTANCE REGRESSION," 264C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. 265C***ROUTINES CALLED DODCNT 266C***END PROLOGUE DODRC 267 268C...SCALAR ARGUMENTS 269 DOUBLE PRECISION 270 + PARTOL,SSTOL,TAUFAC 271 INTEGER 272 + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, 273 + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ 274 275C...ARRAY ARGUMENTS 276 DOUBLE PRECISION 277 + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), 278 + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), 279 + X(LDX,M),Y(LDY,NQ) 280 INTEGER 281 + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) 282 283C...SUBROUTINE ARGUMENTS 284 EXTERNAL 285 + FCN 286 287C...LOCAL SCALARS 288 DOUBLE PRECISION 289 + NEGONE,ZERO 290 LOGICAL 291 + SHORT 292 293C...LOCAL ARRAYS 294 DOUBLE PRECISION 295 + WD1(1,1,1) 296 297C...EXTERNAL SUBROUTINES 298 EXTERNAL 299 + DODCNT 300 301C...DATA STATEMENTS 302 DATA 303 + NEGONE,ZERO 304 + /-1.0D0,0.0D0/ 305 306C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 307C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 308 309C...VARIABLE DEFINITIONS (ALPHABETICALLY) 310C BETA: THE FUNCTION PARAMETERS. 311C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 312C FIXED AT THEIR INPUT VALUES OR NOT. 313C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 314C FIXED AT THEIR INPUT VALUES OR NOT. 315C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 316C IPRINT: THE PRINT CONTROL VARIABLE. 317C IWORK: THE INTEGER WORK SPACE. 318C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 319C COMPUTATIONAL METHOD. 320C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 321C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. 322C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 323C LDWD: THE LEADING DIMENSION OF ARRAY WD. 324C LDWE: THE LEADING DIMENSION OF ARRAY WE. 325C LDX: THE LEADING DIMENSION OF ARRAY X. 326C LDY: THE LEADING DIMENSION OF ARRAY Y. 327C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 328C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 329C LIWORK: THE LENGTH OF VECTOR IWORK. 330C LUNERR: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. 331C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. 332C LWORK: THE LENGTH OF VECTOR WORK. 333C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 334C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 335C N: THE NUMBER OF OBSERVATIONS. 336C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS 337C SUPPLIED BY THE USER. 338C NP: THE NUMBER OF FUNCTION PARAMETERS. 339C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 340C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. 341C SCLB: THE SCALING VALUES FOR BETA. 342C SCLD: THE SCALING VALUES FOR DELTA. 343C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 344C DERIVATIVES WITH RESPECT TO BETA. 345C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 346C DERIVATIVES WITH RESPECT TO DELTA. 347C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 348C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL 349C (SHORT=.FALSE.). 350C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. 351C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 352C DIAMETER. 353C WD: THE DELTA WEIGHTS. 354C WD1: A DUMMY ARRAY USED WHEN WD(1,1,1)=0.0D0. 355C WE: THE EPSILON WEIGHTS. 356C WORK: THE DOUBLE PRECISION WORK SPACE. 357C X: THE EXPLANATORY VARIABLE. 358C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. 359 360 361C***FIRST EXECUTABLE STATEMENT DODRC 362 363 364 SHORT = .FALSE. 365 366 IF (WD(1,1,1).NE.ZERO) THEN 367 CALL DODCNT 368 + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, 369 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, 370 + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, 371 + IPRINT,LUNERR,LUNRPT, 372 + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, 373 + WORK,LWORK,IWORK,LIWORK, 374 + INFO) 375 ELSE 376 WD1(1,1,1) = NEGONE 377 CALL DODCNT 378 + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, 379 + WE,LDWE,LD2WE,WD1,1,1, IFIXB,IFIXX,LDIFX, 380 + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, 381 + IPRINT,LUNERR,LUNRPT, 382 + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, 383 + WORK,LWORK,IWORK,LIWORK, 384 + INFO) 385 END IF 386 387 RETURN 388 389 END 390*DACCES 391 SUBROUTINE DACCES 392 + (N,M,NP,NQ,LDWE,LD2WE, 393 + WORK,LWORK,IWORK,LIWORK, 394 + ACCESS,ISODR, 395 + JPVT,OMEGA,U,QRAUX,SD,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, 396 + NNZW,NPP, 397 + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, 398 + LUNRPT,IPR1,IPR2,IPR2F,IPR3, 399 + WSS,RVAR,IDF, 400 + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, 401 + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) 402C***BEGIN PROLOGUE DACCES 403C***REFER TO DODR,DODRC 404C***ROUTINES CALLED DIWINF,DWINF 405C***DATE WRITTEN 860529 (YYMMDD) 406C***REVISION DATE 920619 (YYMMDD) 407C***PURPOSE ACCESS OR STORE VALUES IN THE WORK ARRAYS 408C***END PROLOGUE DACESS 409 410C...SCALAR ARGUMENTS 411 DOUBLE PRECISION 412 + ACTRS,ALPHA,ETA,OLMAVG,PARTOL,PNORM,PRERS,RCOND, 413 + RNORMS,RVAR,SSTOL,TAU,TAUFAC 414 INTEGER 415 + IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOP,ISTOPI,JOB,JPVT, 416 + LDWE,LD2WE,LIWORK,LUNRPT,LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV, 417 + NNZW,NP,NPP,NQ,OMEGA,QRAUX,SD,U,VCV, 418 + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 419 LOGICAL 420 + ACCESS,ISODR 421 422C...ARRAY ARGUMENTS 423 DOUBLE PRECISION 424 + WORK(LWORK),WSS(3) 425 INTEGER 426 + IWORK(LIWORK) 427 428C...LOCAL SCALARS 429 INTEGER 430 + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I, 431 + DELTAI,DELTNI,DELTSI,DIFFI,EPSI, 432 + EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT, 433 + IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI, 434 + MSGB,MSGD,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI, 435 + NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, 436 + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, 437 + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, 438 + WSSI,WSSDEI,WSSEPI,XPLUSI 439C...EXTERNAL SUBROUTINES 440 EXTERNAL 441 + DIWINF,DWINF 442 443C...VARIABLE DEFINITIONS (ALPHABETICALLY) 444C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE 445C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN 446C THEM (ACCESS=FALSE). 447C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. 448C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. 449C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. 450C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. 451C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. 452C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. 453C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. 454C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. 455C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. 456C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. 457C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. 458C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. 459C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. 460C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. 461C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. 462C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. 463C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. 464C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. 465C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. 466C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. 467C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF 468C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE 469C NUMBER OF PARAMETERS BEING ESTIMATED. 470C IDFI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE IDF. 471C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS. 472C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. 473C IPR1: THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, 474C WHICH CONTROLS THE INITIAL SUMMARY REPORT. 475C IPR2: THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, 476C WHICH CONTROLS THE ITERATION REPORTS. 477C IPR2F: THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, 478C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. 479C IPR3: THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, 480C WHICH CONTROLS THE FINAL SUMMARY REPORT. 481C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. 482C IPRINT: THE PRINT CONTROL VARIABLE. 483C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. 484C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. 485C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS TO BE 486C FOUND BY ODR (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 487C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 488C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 489C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. 490C IWORK: THE INTEGER WORK SPACE. 491C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 492C COMPUTATIONAL METHOD. 493C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. 494C JPVT: THE PIVOT VECTOR. 495C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE JPVT. 496C LDTTI: THE STARTING LOCATION IN ARRAY IWORK OF VARIABLE LDTT. 497C LDWE: THE LEADING DIMENSION OF ARRAY WE. 498C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 499C LIWORK: THE LENGTH OF VECTOR IWORK. 500C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. 501C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. 502C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. 503C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. 504C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. 505C LWORK: THE LENGTH OF VECTOR WORK. 506C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 507C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 508C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. 509C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. 510C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. 511C N: THE NUMBER OF OBSERVATIONS. 512C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. 513C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. 514C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 515C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. 516C NITER: THE NUMBER OF ITERATIONS TAKEN. 517C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. 518C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. 519C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. 520C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. 521C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. 522C NP: THE NUMBER OF FUNCTION PARAMETERS. 523C NPP: THE NUMBER OF FUNCTION PARAMETERS ACTUALLY ESTIMATED. 524C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. 525C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 526C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. 527C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. 528C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER 529C ITERATION. 530C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. 531C OMEGA: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. 532C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. 533C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. 534C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. 535C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. 536C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. 537C PRERS: THE SAVED PREDICTED RELATIVE REDUCTION IN THE 538C SUM-OF-SQUARES. 539C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. 540C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. 541C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. 542C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. 543C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. 544C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 545C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). 546C RNORMS: THE NORM OF THE SAVED WEIGHTED EPSILONS AND DELTAS. 547C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. 548C RVAR: THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. 549C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. 550C SCLB: THE SCALING VALUES USED FOR BETA. 551C SCLD: THE SCALING VALUES USED FOR DELTA. 552C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. 553C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. 554C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 555C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG- 556C CALL (SHORT=FALSE). 557C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. 558C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. 559C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. 560C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. 561C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. 562C TAU: THE TRUST REGION DIAMETER. 563C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 564C DIAMETER. 565C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. 566C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. 567C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. 568C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. 569C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. 570C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. 571C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. 572C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. 573C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. 574C WORK: THE DOUBLE PRECISION WORK SPACE. 575C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. 576C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. 577C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. 578C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. 579C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. 580C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. 581C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. 582C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. 583C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. 584C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. 585C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. 586C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. 587C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. 588C WSS: THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, 589C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS, AND 590C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. 591C WSSI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(1). 592C WSSDEI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(2). 593C WSSEPI: THE STARTING LOCATION IN ARRAY WORK OF VARIABLE WSS(3). 594C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. 595 596 597C***FIRST EXECUTABLE STATEMENT DACCES 598 599 600C FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE 601 602 CALL DIWINF(M,NP,NQ, 603 + MSGB,MSGD,JPVTI,ISTOPI, 604 + NNZWI,NPPI,IDFI, 605 + JOBI,IPRINI,LUNERI,LUNRPI, 606 + NROWI,NTOLI,NETAI, 607 + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, 608 + LIWKMN) 609 610C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE 611 612 CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, 613 + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, 614 + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, 615 + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, 616 + PARTLI,SSTOLI,TAUFCI,EPSMAI, 617 + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, 618 + FSI,FJACBI,WE1I,DIFFI, 619 + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, 620 + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, 621 + LWKMN) 622 623 IF (ACCESS) THEN 624 625C SET STARTING LOCATIONS FOR WORK VECTORS 626 627 JPVT = JPVTI 628 OMEGA = OMEGAI 629 QRAUX = QRAUXI 630 SD = SDI 631 VCV = VCVI 632 U = UI 633 WRK1 = WRK1I 634 WRK2 = WRK2I 635 WRK3 = WRK3I 636 WRK4 = WRK4I 637 WRK5 = WRK5I 638 WRK6 = WRK6I 639 640C ACCESS VALUES FROM THE WORK VECTORS 641 642 ACTRS = WORK(ACTRSI) 643 ALPHA = WORK(ALPHAI) 644 ETA = WORK(ETAI) 645 OLMAVG = WORK(OLMAVI) 646 PARTOL = WORK(PARTLI) 647 PNORM = WORK(PNORMI) 648 PRERS = WORK(PRERSI) 649 RCOND = WORK(RCONDI) 650 WSS(1) = WORK(WSSI) 651 WSS(2) = WORK(WSSDEI) 652 WSS(3) = WORK(WSSEPI) 653 RVAR = WORK(RVARI) 654 RNORMS = WORK(RNORSI) 655 SSTOL = WORK(SSTOLI) 656 TAU = WORK(TAUI) 657 TAUFAC = WORK(TAUFCI) 658 659 NETA = IWORK(NETAI) 660 IRANK = IWORK(IRANKI) 661 JOB = IWORK(JOBI) 662 LUNRPT = IWORK(LUNRPI) 663 MAXIT = IWORK(MAXITI) 664 NFEV = IWORK(NFEVI) 665 NITER = IWORK(NITERI) 666 NJEV = IWORK(NJEVI) 667 NNZW = IWORK(NNZWI) 668 NPP = IWORK(NPPI) 669 IDF = IWORK(IDFI) 670 INT2 = IWORK(INT2I) 671 672C SET UP PRINT CONTROL VARIABLES 673 674 IPRINT = IWORK(IPRINI) 675 676 IPR1 = MOD(IPRINT,10000)/1000 677 IPR2 = MOD(IPRINT,1000)/100 678 IPR2F = MOD(IPRINT,100)/10 679 IPR3 = MOD(IPRINT,10) 680 681 ELSE 682 683C STORE VALUES INTO THE WORK VECTORS 684 685 WORK(ACTRSI) = ACTRS 686 WORK(ALPHAI) = ALPHA 687 WORK(OLMAVI) = OLMAVG 688 WORK(PARTLI) = PARTOL 689 WORK(PNORMI) = PNORM 690 WORK(PRERSI) = PRERS 691 WORK(RCONDI) = RCOND 692 WORK(WSSI) = WSS(1) 693 WORK(WSSDEI) = WSS(2) 694 WORK(WSSEPI) = WSS(3) 695 WORK(RVARI) = RVAR 696 WORK(RNORSI) = RNORMS 697 WORK(SSTOLI) = SSTOL 698 WORK(TAUI) = TAU 699 700 IWORK(IRANKI) = IRANK 701 IWORK(ISTOPI) = ISTOP 702 IWORK(NFEVI) = NFEV 703 IWORK(NITERI) = NITER 704 IWORK(NJEVI) = NJEV 705 IWORK(IDFI) = IDF 706 IWORK(INT2I) = INT2 707 END IF 708 709 RETURN 710 END 711*DESUBI 712 SUBROUTINE DESUBI 713 + (N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,E) 714C***BEGIN PROLOGUE DESUBI 715C***REFER TO DODR,DODRC 716C***ROUTINES CALLED DZERO 717C***DATE WRITTEN 860529 (YYMMDD) 718C***REVISION DATE 920304 (YYMMDD) 719C***PURPOSE COMPUTE E = WD + ALPHA*TT**2 720C***END PROLOGUE DESUBI 721 722C...SCALAR ARGUMENTS 723 DOUBLE PRECISION 724 + ALPHA 725 INTEGER 726 + LDTT,LDWD,LD2WD,M,N 727 728C...ARRAY ARGUMENTS 729 DOUBLE PRECISION 730 + E(M,M),TT(LDTT,M),WD(LDWD,LD2WD,M) 731 732C...LOCAL SCALARS 733 DOUBLE PRECISION 734 + ZERO 735 INTEGER 736 + I,J,J1,J2 737 738C...EXTERNAL SUBROUTINES 739 EXTERNAL 740 + DZERO 741 742C...DATA STATEMENTS 743 DATA 744 + ZERO 745 + /0.0D0/ 746 747C...VARIABLE DEFINITIONS (ALPHABETICALLY) 748C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. 749C E: THE VALUE OF THE ARRAY E = WD + ALPHA*TT**2 750C I: AN INDEXING VARIABLE. 751C J: AN INDEXING VARIABLE. 752C J1: AN INDEXING VARIABLE. 753C J2: AN INDEXING VARIABLE. 754C LDWD: THE LEADING DIMENSION OF ARRAY WD. 755C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 756C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. 757C N: THE NUMBER OF OBSERVATIONS. 758C NP: THE NUMBER OF RESPONSES PER OBSERVATION. 759C TT: THE SCALING VALUES USED FOR DELTA. 760C WD: THE SQUARED DELTA WEIGHTS, D**2. 761C ZERO: THE VALUE 0.0D0. 762 763 764C***FIRST EXECUTABLE STATEMENT DESUBI 765 766 767C N.B. THE LOCATIONS OF WD AND TT ACCESSED DEPEND ON THE VALUE 768C OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSIONS 769C OF THE MULTIPLY SUBSCRIPTED ARRAYS. 770 771 IF (N.EQ.0 .OR. M.EQ.0) RETURN 772 773 IF (WD(1,1,1).GE.ZERO) THEN 774 IF (LDWD.GE.N) THEN 775C THE ELEMENTS OF WD HAVE BEEN INDIVIDUALLY SPECIFIED 776 777 IF (LD2WD.EQ.1) THEN 778C THE ARRAYS STORED IN WD ARE DIAGONAL 779 CALL DZERO(M,M,E,M) 780 DO 10 J=1,M 781 E(J,J) = WD(I,1,J) 782 10 CONTINUE 783 ELSE 784C THE ARRAYS STORED IN WD ARE FULL POSITIVE SEMIDEFINITE MATRICES 785 DO 30 J1=1,M 786 DO 20 J2=1,M 787 E(J1,J2) = WD(I,J1,J2) 788 20 CONTINUE 789 30 CONTINUE 790 END IF 791 792 IF (TT(1,1).GT.ZERO) THEN 793 IF (LDTT.GE.N) THEN 794 DO 110 J=1,M 795 E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 796 110 CONTINUE 797 ELSE 798 DO 120 J=1,M 799 E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 800 120 CONTINUE 801 END IF 802 ELSE 803 DO 130 J=1,M 804 E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 805 130 CONTINUE 806 END IF 807 ELSE 808C WD IS AN M BY M MATRIX 809 810 IF (LD2WD.EQ.1) THEN 811C THE ARRAY STORED IN WD IS DIAGONAL 812 CALL DZERO(M,M,E,M) 813 DO 140 J=1,M 814 E(J,J) = WD(1,1,J) 815 140 CONTINUE 816 ELSE 817C THE ARRAY STORED IN WD IS A FULL POSITIVE SEMIDEFINITE MATRICES 818 DO 160 J1=1,M 819 DO 150 J2=1,M 820 E(J1,J2) = WD(1,J1,J2) 821 150 CONTINUE 822 160 CONTINUE 823 END IF 824 825 IF (TT(1,1).GT.ZERO) THEN 826 IF (LDTT.GE.N) THEN 827 DO 210 J=1,M 828 E(J,J) = E(J,J) + ALPHA*TT(I,J)**2 829 210 CONTINUE 830 ELSE 831 DO 220 J=1,M 832 E(J,J) = E(J,J) + ALPHA*TT(1,J)**2 833 220 CONTINUE 834 END IF 835 ELSE 836 DO 230 J=1,M 837 E(J,J) = E(J,J) + ALPHA*TT(1,1)**2 838 230 CONTINUE 839 END IF 840 END IF 841 ELSE 842C WD IS A DIAGONAL MATRIX WITH ELEMENTS ABS(WD(1,1,1)) 843 CALL DZERO(M,M,E,M) 844 IF (TT(1,1).GT.ZERO) THEN 845 IF (LDTT.GE.N) THEN 846 DO 310 J=1,M 847 E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(I,J)**2 848 310 CONTINUE 849 ELSE 850 DO 320 J=1,M 851 E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,J)**2 852 320 CONTINUE 853 END IF 854 ELSE 855 DO 330 J=1,M 856 E(J,J) = ABS(WD(1,1,1)) + ALPHA*TT(1,1)**2 857 330 CONTINUE 858 END IF 859 END IF 860 861 RETURN 862 END 863*DETAF 864 SUBROUTINE DETAF 865 + (FCN, 866 + N,M,NP,NQ, 867 + XPLUSD,BETA,EPSMAC,NROW, 868 + PARTMP,PV0, 869 + IFIXB,IFIXX,LDIFX, 870 + ISTOP,NFEV,ETA,NETA, 871 + WRK1,WRK2,WRK6,WRK7) 872C***BEGIN PROLOGUE DETAF 873C***REFER TO DODR,DODRC 874C***ROUTINES CALLED FCN 875C***DATE WRITTEN 860529 (YYMMDD) 876C***REVISION DATE 920619 (YYMMDD) 877C***PURPOSE COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS 878C (ADAPTED FROM STARPAC SUBROUTINE ETAFUN) 879C***END PROLOGUE DETAF 880 881C...SCALAR ARGUMENTS 882 DOUBLE PRECISION 883 + EPSMAC,ETA 884 INTEGER 885 + ISTOP,LDIFX,M,N,NETA,NFEV,NP,NQ,NROW 886 887C...ARRAY ARGUMENTS 888 DOUBLE PRECISION 889 + BETA(NP),PARTMP(NP),PV0(N,NQ), 890 + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),WRK7(-2:2,NQ),XPLUSD(N,M) 891 INTEGER 892 + IFIXB(NP),IFIXX(LDIFX,M) 893 894C...SUBROUTINE ARGUMENTS 895 EXTERNAL 896 + FCN 897 898C...LOCAL SCALARS 899 DOUBLE PRECISION 900 + A,B,FAC,HUNDRD,ONE,P1,P2,P5,STP,TWO,ZERO 901 INTEGER 902 + J,K,L 903 904C...INTRINSIC FUNCTIONS 905 INTRINSIC 906 + ABS,INT,LOG10,MAX,SQRT 907 908C...DATA STATEMENTS 909 DATA 910 + ZERO,P1,P2,P5,ONE,TWO,HUNDRD 911 + /0.0D0,0.1D0,0.2D0,0.5D0,1.0D0,2.0D0,1.0D2/ 912 913C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 914C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 915 916C...VARIABLE DEFINITIONS (ALPHABETICALLY) 917C A: PARAMETERS OF THE LOCAL FIT. 918C B: PARAMETERS OF THE LOCAL FIT. 919C BETA: THE FUNCTION PARAMETERS. 920C EPSMAC: THE VALUE OF MACHINE PRECISION. 921C ETA: THE NOISE IN THE MODEL RESULTS. 922C FAC: A FACTOR USED IN THE COMPUTATIONS. 923C HUNDRD: THE VALUE 1.0D2. 924C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 925C FIXED AT THEIR INPUT VALUES OR NOT. 926C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 927C FIXED AT THEIR INPUT VALUES OR NOT. 928C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 929C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 930C J: AN INDEX VARIABLE. 931C K: AN INDEX VARIABLE. 932C L: AN INDEX VARIABLE. 933C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 934C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 935C N: THE NUMBER OF OBSERVATIONS. 936C NETA: THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. 937C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 938C NP: THE NUMBER OF FUNCTION PARAMETERS. 939C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 940C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. 941C ONE: THE VALUE 1.0D0. 942C P1: THE VALUE 0.1D0. 943C P2: THE VALUE 0.2D0. 944C P5: THE VALUE 0.5D0. 945C PARTMP: THE MODEL PARAMETERS. 946C PV0: THE ORIGINAL PREDICTED VALUES. 947C STP: A SMALL VALUE USED TO PERTURB THE PARAMETERS. 948C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. 949C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 950C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. 951C WRK7: A WORK ARRAY OF (5 BY NQ) ELEMENTS. 952C XPLUSD: THE VALUES OF X + DELTA. 953C ZERO: THE VALUE 0.0D0. 954 955 956C***FIRST EXECUTABLE STATEMENT DETAF 957 958 959 STP = HUNDRD*EPSMAC 960 ETA = EPSMAC 961 962 DO 40 J=-2,2 963 IF (J.EQ.0) THEN 964 DO 10 L=1,NQ 965 WRK7(J,L) = PV0(NROW,L) 966 10 CONTINUE 967 ELSE 968 DO 20 K=1,NP 969 IF (IFIXB(1).LT.0) THEN 970 PARTMP(K) = BETA(K) + J*STP*BETA(K) 971 ELSE IF (IFIXB(K).NE.0) THEN 972 PARTMP(K) = BETA(K) + J*STP*BETA(K) 973 ELSE 974 PARTMP(K) = BETA(K) 975 END IF 976 20 CONTINUE 977 ISTOP = 0 978 CALL FCN(N,M,NP,NQ, 979 + N,M,NP, 980 + PARTMP,XPLUSD, 981 + IFIXB,IFIXX,LDIFX, 982 + 003,WRK2,WRK6,WRK1,ISTOP) 983 IF (ISTOP.NE.0) THEN 984 RETURN 985 ELSE 986 NFEV = NFEV + 1 987 END IF 988 DO 30 L=1,NQ 989 WRK7(J,L) = WRK2(NROW,L) 990 30 CONTINUE 991 END IF 992 40 CONTINUE 993 994 DO 100 L=1,NQ 995 A = ZERO 996 B = ZERO 997 DO 50 J=-2,2 998 A = A + WRK7(J,L) 999 B = B + J*WRK7(J,L) 1000 50 CONTINUE 1001 A = P2*A 1002 B = P1*B 1003 IF ((WRK7(0,L).NE.ZERO) .AND. 1004 + (ABS(WRK7(1,L)+WRK7(-1,L)).GT.HUNDRD*EPSMAC)) THEN 1005 FAC = ONE/ABS(WRK7(0,L)) 1006 ELSE 1007 FAC = ONE 1008 END IF 1009 DO 60 J=-2,2 1010 WRK7(J,L) = ABS((WRK7(J,L)-(A+J*B))*FAC) 1011 ETA = MAX(WRK7(J,L),ETA) 1012 60 CONTINUE 1013 100 CONTINUE 1014 NETA = MAX(TWO,P5-LOG10(ETA)) 1015 1016 RETURN 1017 END 1018*DEVJAC 1019 SUBROUTINE DEVJAC 1020 + (FCN, 1021 + ANAJAC,CDJAC, 1022 + N,M,NP,NQ, 1023 + BETAC,BETA,STPB, 1024 + IFIXB,IFIXX,LDIFX, 1025 + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, 1026 + SSF,TT,LDTT,NETA,FN, 1027 + STP,WRK1,WRK2,WRK3,WRK6, 1028 + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, 1029 + NJEV,NFEV,ISTOP,INFO) 1030C***BEGIN PROLOGUE DEVJAC 1031C***REFER TO DODR,DODRC 1032C***ROUTINES CALLED FCN,DDOT,DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY 1033C***DATE WRITTEN 860529 (YYMMDD) 1034C***REVISION DATE 920304 (YYMMDD) 1035C***PURPOSE COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA 1036C***END PROLOGUE DEVJAC 1037 1038C...SCALAR ARGUMENTS 1039 INTEGER 1040 + INFO,ISTOP,LDIFX,LDSTPD,LDTT,LDWE,LDX,LD2WE, 1041 + M,N,NETA,NFEV,NJEV,NP,NQ 1042 LOGICAL 1043 + ANAJAC,CDJAC,ISODR 1044 1045C...ARRAY ARGUMENTS 1046 DOUBLE PRECISION 1047 + BETA(NP),BETAC(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), 1048 + FN(N,NQ),SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), 1049 + WE1(LDWE,LD2WE,NQ),WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP), 1050 + WRK6(N,NP,NQ),X(LDX,M),XPLUSD(N,M) 1051 INTEGER 1052 + IFIXB(NP),IFIXX(LDIFX,M) 1053 1054C...SUBROUTINE ARGUMENTS 1055 EXTERNAL 1056 + FCN 1057 1058C...LOCAL SCALARS 1059 INTEGER 1060 + IDEVAL,J,K,K1,L 1061 DOUBLE PRECISION 1062 + ZERO 1063 LOGICAL 1064 + ERROR 1065 1066C...EXTERNAL SUBROUTINES 1067 EXTERNAL 1068 + DIFIX,DJACCD,DJACFD,DWGHT,DUNPAC,DXPY 1069 1070C...EXTERNAL FUNCTIONS 1071 DOUBLE PRECISION 1072 + DDOT 1073 EXTERNAL 1074 + DDOT 1075 1076C...DATA STATEMENTS 1077 DATA ZERO 1078 + /0.0D0/ 1079 1080C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 1081C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 1082 1083C...VARIABLE DEFINITIONS (ALPHABETICALLY) 1084C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 1085C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT 1086C (ANAJAC=TRUE). 1087C BETA: THE FUNCTION PARAMETERS. 1088C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. 1089C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 1090C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD 1091C DIFFERENCES (CDJAC=FALSE). 1092C DELTA: THE ESTIMATED VALUES OF DELTA. 1093C ERROR: THE VARIABLE DESIGNATING WHETHER ODRPACK DETECTED NONZERO 1094C VALUES IN ARRAY DELTA IN THE OLS CASE, AND THUS WHETHER 1095C THE USER MAY HAVE OVERWRITTEN IMPORTANT INFORMATION 1096C BY COMPUTING FJACD IN THE OLS CASE. 1097C FJACB: THE JACOBIAN WITH RESPECT TO BETA. 1098C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. 1099C FN: THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT POINT. 1100C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE 1101C PERFORMED BY USER-SUPPLIED SUBROUTINE FCN. 1102C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 1103C FIXED AT THEIR INPUT VALUES OR NOT. 1104C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF DELTA ARE 1105C FIXED AT THEIR INPUT VALUES OR NOT. 1106C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 1107C ISTOP: THE VARIABLE DESIGNATING THAT THE USER WISHES THE 1108C COMPUTATIONS STOPPED. 1109C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 1110C (ISODR=TRUE) OR OLS (ISODR=FALSE). 1111C J: AN INDEXING VARIABLE. 1112C K: AN INDEXING VARIABLE. 1113C K1: AN INDEXING VARIABLE. 1114C L: AN INDEXING VARIABLE. 1115C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 1116C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 1117C LDTT: THE LEADING DIMENSION OF ARRAY TT. 1118C LDWE: THE LEADING DIMENSION OF ARRAYS WE AND WE1. 1119C LDX: THE LEADING DIMENSION OF ARRAY X. 1120C LD2WE: THE SECOND DIMENSION OF ARRAYS WE AND WE1. 1121C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. 1122C N: THE NUMBER OF OBSERVATIONS. 1123C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. 1124C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 1125C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. 1126C NP: THE NUMBER OF FUNCTION PARAMETERS. 1127C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 1128C SSF: THE SCALE USED FOR THE BETA'S. 1129C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE 1130C DERIVATIVES WITH RESPECT TO DELTA. 1131C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE 1132C DERIVATIVES WITH RESPECT TO BETA. 1133C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE 1134C DERIVATIVES WITH RESPECT TO DELTA. 1135C TT: THE SCALING VALUES USED FOR DELTA. 1136C WE1: THE SQUARE ROOTS OF THE EPSILON WEIGHTS IN ARRAY WE. 1137C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. 1138C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 1139C WRK3: A WORK ARRAY OF (NP) ELEMENTS. 1140C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. 1141C X: THE INDEPENDENT VARIABLE. 1142C XPLUSD: THE VALUES OF X + DELTA. 1143C ZERO: THE VALUE 0.0D0. 1144 1145 1146C***FIRST EXECUTABLE STATEMENT DEVJAC 1147 1148 1149C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA 1150 1151 CALL DUNPAC(NP,BETAC,BETA,IFIXB) 1152 1153C COMPUTE XPLUSD = X + DELTA 1154 1155 CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) 1156 1157C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND 1158C THE JACOBIAN WRT DELTA (FJACD) 1159 1160 ISTOP = 0 1161 IF (ISODR) THEN 1162 IDEVAL = 110 1163 ELSE 1164 IDEVAL = 010 1165 END IF 1166 IF (ANAJAC) THEN 1167 CALL FCN(N,M,NP,NQ, 1168 + N,M,NP, 1169 + BETA,XPLUSD, 1170 + IFIXB,IFIXX,LDIFX, 1171 + IDEVAL,WRK2,FJACB,FJACD, 1172 + ISTOP) 1173 IF (ISTOP.NE.0) THEN 1174 RETURN 1175 ELSE 1176 NJEV = NJEV+1 1177 END IF 1178C MAKE SURE FIXED ELEMENTS OF FJACD ARE ZERO 1179 IF (ISODR) THEN 1180 DO 10 L=1,NQ 1181 CALL DIFIX(N,M,IFIXX,LDIFX,FJACD(1,1,L),N,FJACD(1,1,L),N) 1182 10 CONTINUE 1183 END IF 1184 ELSE IF (CDJAC) THEN 1185 CALL DJACCD(FCN, 1186 + N,M,NP,NQ, 1187 + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, 1188 + STPB,STPD,LDSTPD, 1189 + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, 1190 + FJACB,ISODR,FJACD,NFEV,ISTOP) 1191 ELSE 1192 CALL DJACFD(FCN, 1193 + N,M,NP,NQ, 1194 + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, 1195 + STPB,STPD,LDSTPD, 1196 + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, 1197 + FJACB,ISODR,FJACD,NFEV,ISTOP) 1198 END IF 1199 IF (ISTOP.LT.0) THEN 1200 RETURN 1201 ELSE IF (.NOT.ISODR) THEN 1202C TRY TO DETECT WHETHER THE USER HAS COMPUTED JFACD 1203C WITHIN FCN IN THE OLS CASE 1204 ERROR = DDOT(N*M,DELTA,1,DELTA,1).NE.ZERO 1205 IF (ERROR) THEN 1206 INFO = 50300 1207 RETURN 1208 END IF 1209 END IF 1210 1211C WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS 1212 1213 IF (IFIXB(1).LT.0) THEN 1214 DO 20 K=1,NP 1215 CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, 1216 + FJACB(1,K,1),N*NP,FJACB(1,K,1),N*NP) 1217 20 CONTINUE 1218 ELSE 1219 K1 = 0 1220 DO 30 K=1,NP 1221 IF (IFIXB(K).GE.1) THEN 1222 K1 = K1 + 1 1223 CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, 1224 + FJACB(1,K,1),N*NP,FJACB(1,K1,1),N*NP) 1225 END IF 1226 30 CONTINUE 1227 END IF 1228 1229C WEIGHT THE JACOBIAN'S WRT DELTA AS APPROPRIATE 1230 1231 IF (ISODR) THEN 1232 DO 40 J=1,M 1233 CALL DWGHT(N,NQ,WE1,LDWE,LD2WE, 1234 + FJACD(1,J,1),N*M,FJACD(1,J,1),N*M) 1235 40 CONTINUE 1236 END IF 1237 1238 RETURN 1239 END 1240*DFCTR 1241 SUBROUTINE DFCTR(OKSEMI,A,LDA,N,INFO) 1242C***BEGIN PROLOGUE DFCTR 1243C***REFER TO DODR,DODRC 1244C***ROUTINES CALLED DDOT 1245C***DATE WRITTEN 910706 (YYMMDD) 1246C***REVISION DATE 920619 (YYMMDD) 1247C***PURPOSE FACTOR THE POSITIVE (SEMI)DEFINITE MATRIX A USING A 1248C MODIFIED CHOLESKY FACTORIZATION 1249C (ADAPTED FROM LINPACK SUBROUTINE DPOFA) 1250C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., 1251C *LINPACK USERS GUIDE*, SIAM, 1979. 1252C***END PROLOGUE DFCTR 1253 1254C...SCALAR ARGUMENTS 1255 INTEGER INFO,LDA,N 1256 LOGICAL OKSEMI 1257 1258C...ARRAY ARGUMENTS 1259 DOUBLE PRECISION A(LDA,N) 1260 1261C...LOCAL SCALARS 1262 DOUBLE PRECISION XI,S,T,TEN,ZERO 1263 INTEGER J,K 1264 1265C...EXTERNAL FUNCTIONS 1266 EXTERNAL DMPREC,DDOT 1267 DOUBLE PRECISION DMPREC,DDOT 1268 1269C...INTRINSIC FUNCTIONS 1270 INTRINSIC SQRT 1271 1272C...DATA STATEMENTS 1273 DATA 1274 + ZERO,TEN 1275 + /0.0D0,10.0D0/ 1276 1277C...VARIABLE DEFINITIONS (ALPHABETICALLY) 1278C A: THE ARRAY TO BE FACTORED. UPON RETURN, A CONTAINS THE 1279C UPPER TRIANGULAR MATRIX R SO THAT A = TRANS(R)*R 1280C WHERE THE STRICT LOWER TRIANGLE IS SET TO ZERO 1281C IF INFO .NE. 0 , THE FACTORIZATION IS NOT COMPLETE. 1282C I: AN INDEXING VARIABLE. 1283C INFO: AN IDICATOR VARIABLE, WHERE IF 1284C INFO = 0 THEN FACTORIZATION WAS COMPLETED 1285C INFO = K SIGNALS AN ERROR CONDITION. THE LEADING MINOR 1286C OF ORDER K IS NOT POSITIVE (SEMI)DEFINITE. 1287C J: AN INDEXING VARIABLE. 1288C LDA: THE LEADING DIMENSION OF ARRAY A. 1289C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY A. 1290C OKSEMI: THE INDICATING WHETHER THE FACTORED ARRAY CAN BE POSITIVE 1291C SEMIDEFINITE (OKSEMI=TRUE) OR WHETHER IT MUST BE FOUND TO 1292C BE POSITIVE DEFINITE (OKSEMI=FALSE). 1293C TEN: THE VALUE 10.0D0. 1294C XI: A VALUE USED TO TEST FOR NON POSITIVE SEMIDEFINITENESS. 1295C ZERO: THE VALUE 0.0D0. 1296 1297 1298C***FIRST EXECUTABLE STATEMENT DFCTR 1299 1300 1301C SET RELATIVE TOLERANCE FOR DETECTING NON POSITIVE SEMIDEFINITENESS. 1302 XI = -TEN*DMPREC() 1303 1304C COMPUTE FACTORIZATION, STORING IN UPPER TRIANGULAR PORTION OF A 1305 DO 20 J=1,N 1306 INFO = J 1307 S = ZERO 1308 DO 10 K=1,J-1 1309 IF (A(K,K).EQ.ZERO) THEN 1310 T = ZERO 1311 ELSE 1312 T = A(K,J) - DDOT(K-1,A(1,K),1,A(1,J),1) 1313 T = T/A(K,K) 1314 END IF 1315 A(K,J) = T 1316 S = S + T*T 1317 10 CONTINUE 1318 S = A(J,J) - S 1319C ......EXIT 1320 IF (A(J,J).LT.ZERO .OR. S.LT.XI*ABS(A(J,J))) THEN 1321 RETURN 1322 ELSE IF (.NOT.OKSEMI .AND. S.LE.ZERO) THEN 1323 RETURN 1324 ELSE IF (S.LE.ZERO) THEN 1325 A(J,J) = ZERO 1326 ELSE 1327 A(J,J) = SQRT(S) 1328 END IF 1329 20 CONTINUE 1330 INFO = 0 1331 1332C ZERO OUT LOWER PORTION OF A 1333 DO 40 J=2,N 1334 DO 30 K=1,J-1 1335 A(J,K) = ZERO 1336 30 CONTINUE 1337 40 CONTINUE 1338 1339 RETURN 1340 END 1341*DFCTRW 1342 SUBROUTINE DFCTRW 1343 + (N,M,NQ,NPP, 1344 + ISODR, 1345 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, 1346 + WRK0,WRK4, 1347 + WE1,NNZW,INFO) 1348C***BEGIN PROLOGUE DFCTRW 1349C***REFER TO DODR,DODRC 1350C***ROUTINES CALLED DFCTR 1351C***DATE WRITTEN 860529 (YYMMDD) 1352C***REVISION DATE 920619 (YYMMDD) 1353C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING 1354C NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE 1355C ODRPACK REFERENCE GUIDE 1356C***END PROLOGUE DFCTRW 1357 1358C...SCALAR ARGUMENTS 1359 INTEGER 1360 + INFO,LDWD,LDWE,LD2WD,LD2WE, 1361 + M,N,NNZW,NPP,NQ 1362 LOGICAL 1363 + ISODR 1364 1365C...ARRAY ARGUMENTS 1366 DOUBLE PRECISION 1367 + WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M), 1368 + WRK0(NQ,NQ),WRK4(M,M) 1369 1370C...LOCAL SCALARS 1371 DOUBLE PRECISION 1372 + ZERO 1373 INTEGER 1374 + I,INF,J,J1,J2,L,L1,L2 1375 LOGICAL 1376 + NOTZRO 1377 1378C...EXTERNAL SUBROUTINES 1379 EXTERNAL 1380 + DFCTR 1381 1382C...DATA STATEMENTS 1383 DATA 1384 + ZERO 1385 + /0.0D0/ 1386 1387C...VARIABLE DEFINITIONS (ALPHABETICALLY) 1388C I: AN INDEXING VARIABLE. 1389C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 1390C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 1391C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 1392C J: AN INDEXING VARIABLE. 1393C J1: AN INDEXING VARIABLE. 1394C J2: AN INDEXING VARIABLE. 1395C L: AN INDEXING VARIABLE. 1396C L1: AN INDEXING VARIABLE. 1397C L2: AN INDEXING VARIABLE. 1398C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. 1399C LDWD: THE LEADING DIMENSION OF ARRAY WD. 1400C LDWE: THE LEADING DIMENSION OF ARRAY WE. 1401C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 1402C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 1403C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 1404C N: THE NUMBER OF OBSERVATIONS. 1405C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. 1406C NOTZRO: THE VARIABLE DESIGNATING WHETHER A GIVEN COMPONENT OF THE 1407C WEIGHT ARRAY WE CONTAINS A NONZERO ELEMENT (NOTZRO=FALSE) 1408C OR NOT (NOTZRO=TRUE). 1409C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. 1410C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. 1411C WE: THE (SQUARED) EPSILON WEIGHTS. 1412C WE1: THE FACTORED EPSILON WEIGHTS, S.T. TRANS(WE1)*WE1 = WE. 1413C WD: THE (SQUARED) DELTA WEIGHTS. 1414C WRK0: A WORK ARRAY OF (NQ BY NQ) ELEMENTS. 1415C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. 1416C ZERO: THE VALUE 0.0D0. 1417 1418 1419C***FIRST EXECUTABLE STATEMENT DFCTRW 1420 1421 1422C CHECK EPSILON WEIGHTS, AND STORE FACTORIZATION IN WE1 1423 1424 IF (WE(1,1,1).LT.ZERO) THEN 1425C WE CONTAINS A SCALAR 1426 WE1(1,1,1) = -SQRT(ABS(WE(1,1,1))) 1427 NNZW = N 1428 1429 ELSE 1430 NNZW = 0 1431 1432 IF (LDWE.EQ.1) THEN 1433 1434 IF (LD2WE.EQ.1) THEN 1435C WE CONTAINS A DIAGONAL MATRIX 1436 DO 110 L=1,NQ 1437 IF (WE(1,1,L).GT.ZERO) THEN 1438 NNZW = N 1439 WE1(1,1,L) = SQRT(WE(1,1,L)) 1440 ELSE IF (WE(1,1,L).LT.ZERO) THEN 1441 INFO = 30010 1442 GO TO 300 1443 END IF 1444 110 CONTINUE 1445 ELSE 1446 1447C WE CONTAINS A FULL NQ BY NQ SEMIDEFINITE MATRIX 1448 DO 130 L1=1,NQ 1449 DO 120 L2=L1,NQ 1450 WRK0(L1,L2) = WE(1,L1,L2) 1451 120 CONTINUE 1452 130 CONTINUE 1453 CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) 1454 IF (INF.NE.0) THEN 1455 INFO = 30010 1456 GO TO 300 1457 ELSE 1458 DO 150 L1=1,NQ 1459 DO 140 L2=1,NQ 1460 WE1(1,L1,L2) = WRK0(L1,L2) 1461 140 CONTINUE 1462 IF (WE1(1,L1,L1).NE.ZERO) THEN 1463 NNZW = N 1464 END IF 1465 150 CONTINUE 1466 END IF 1467 END IF 1468 1469 ELSE 1470 1471 IF (LD2WE.EQ.1) THEN 1472C WE CONTAINS AN ARRAY OF DIAGONAL MATRIX 1473 DO 220 I=1,N 1474 NOTZRO = .FALSE. 1475 DO 210 L=1,NQ 1476 IF (WE(I,1,L).GT.ZERO) THEN 1477 NOTZRO = .TRUE. 1478 WE1(I,1,L) = SQRT(WE(I,1,L)) 1479 ELSE IF (WE(I,1,L).LT.ZERO) THEN 1480 INFO = 30010 1481 GO TO 300 1482 END IF 1483 210 CONTINUE 1484 IF (NOTZRO) THEN 1485 NNZW = NNZW + 1 1486 END IF 1487 220 CONTINUE 1488 ELSE 1489 1490C WE CONTAINS AN ARRAY OF FULL NQ BY NQ SEMIDEFINITE MATRICES 1491 DO 270 I=1,N 1492 DO 240 L1=1,NQ 1493 DO 230 L2=L1,NQ 1494 WRK0(L1,L2) = WE(I,L1,L2) 1495 230 CONTINUE 1496 240 CONTINUE 1497 CALL DFCTR(.TRUE.,WRK0,NQ,NQ,INF) 1498 IF (INF.NE.0) THEN 1499 INFO = 30010 1500 GO TO 300 1501 ELSE 1502 NOTZRO = .FALSE. 1503 DO 260 L1=1,NQ 1504 DO 250 L2=1,NQ 1505 WE1(I,L1,L2) = WRK0(L1,L2) 1506 250 CONTINUE 1507 IF (WE1(I,L1,L1).NE.ZERO) THEN 1508 NOTZRO = .TRUE. 1509 END IF 1510 260 CONTINUE 1511 END IF 1512 IF (NOTZRO) THEN 1513 NNZW = NNZW + 1 1514 END IF 1515 270 CONTINUE 1516 END IF 1517 END IF 1518 END IF 1519 1520C CHECK FOR A SUFFICIENT NUMBER OF NONZERO EPSILON WEIGHTS 1521 1522 IF (NNZW.LT.NPP) THEN 1523 INFO = 30020 1524 END IF 1525 1526 1527C CHECK DELTA WEIGHTS 1528 1529 300 CONTINUE 1530 IF (.NOT.ISODR .OR. WD(1,1,1).LT.ZERO) THEN 1531C PROBLEM IS NOT ODR, OR WD CONTAINS A SCALAR 1532 RETURN 1533 1534 ELSE 1535 1536 IF (LDWD.EQ.1) THEN 1537 1538 IF (LD2WD.EQ.1) THEN 1539C WD CONTAINS A DIAGONAL MATRIX 1540 DO 310 J=1,M 1541 IF (WD(1,1,J).LE.ZERO) THEN 1542 INFO = MAX(30001,INFO+1) 1543 RETURN 1544 END IF 1545 310 CONTINUE 1546 ELSE 1547 1548C WD CONTAINS A FULL M BY M POSITIVE DEFINITE MATRIX 1549 DO 330 J1=1,M 1550 DO 320 J2=J1,M 1551 WRK4(J1,J2) = WD(1,J1,J2) 1552 320 CONTINUE 1553 330 CONTINUE 1554 CALL DFCTR(.FALSE.,WRK4,M,M,INF) 1555 IF (INF.NE.0) THEN 1556 INFO = MAX(30001,INFO+1) 1557 RETURN 1558 END IF 1559 END IF 1560 1561 ELSE 1562 1563 IF (LD2WD.EQ.1) THEN 1564C WD CONTAINS AN ARRAY OF DIAGONAL MATRICES 1565 DO 420 I=1,N 1566 DO 410 J=1,M 1567 IF (WD(I,1,J).LE.ZERO) THEN 1568 INFO = MAX(30001,INFO+1) 1569 RETURN 1570 END IF 1571 410 CONTINUE 1572 420 CONTINUE 1573 ELSE 1574 1575C WD CONTAINS AN ARRAY OF FULL M BY M POSITIVE DEFINITE MATRICES 1576 DO 470 I=1,N 1577 DO 440 J1=1,M 1578 DO 430 J2=J1,M 1579 WRK4(J1,J2) = WD(I,J1,J2) 1580 430 CONTINUE 1581 440 CONTINUE 1582 CALL DFCTR(.FALSE.,WRK4,M,M,INF) 1583 IF (INF.NE.0) THEN 1584 INFO = MAX(30001,INFO+1) 1585 RETURN 1586 END IF 1587 470 CONTINUE 1588 END IF 1589 END IF 1590 END IF 1591 1592 RETURN 1593 END 1594*DFLAGS 1595 SUBROUTINE DFLAGS 1596 + (JOB,RESTRT,INITD,DOVCV,REDOJ,ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) 1597C***BEGIN PROLOGUE DFLAGS 1598C***REFER TO DODR,DODRC 1599C***ROUTINES CALLED (NONE) 1600C***DATE WRITTEN 860529 (YYMMDD) 1601C***REVISION DATE 920304 (YYMMDD) 1602C***PURPOSE SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB 1603C***END PROLOGUE DFLAGS 1604 1605C...SCALAR ARGUMENTS 1606 INTEGER 1607 + JOB 1608 LOGICAL 1609 + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT 1610 1611C...LOCAL SCALARS 1612 INTEGER 1613 + J 1614 1615C...INTRINSIC FUNCTIONS 1616 INTRINSIC 1617 + MOD 1618 1619C...VARIABLE DEFINITIONS (ALPHABETICALLY) 1620C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED 1621C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). 1622C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED 1623C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD 1624C DIFFERENCES (CDJAC=FALSE). 1625C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED 1626C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT 1627C (CHKJAC=FALSE). 1628C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 1629C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). 1630C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 1631C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 1632C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED 1633C TO ZERO (INITD=TRUE) OR TO THE FIRST N BY M ELEMENTS OF 1634C ARRAY WORK (INITD=FALSE). 1635C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 1636C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 1637C J: THE VALUE OF A SPECIFIC DIGIT OF JOB. 1638C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 1639C COMPUTATIONAL METHOD. 1640C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO 1641C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 1642C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). 1643C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 1644C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). 1645 1646 1647C***FIRST EXECUTABLE STATEMENT DFLAGS 1648 1649 1650 IF (JOB.GE.0) THEN 1651 1652 RESTRT= JOB.GE.10000 1653 1654 INITD = MOD(JOB,10000)/1000.EQ.0 1655 1656 J = MOD(JOB,1000)/100 1657 IF (J.EQ.0) THEN 1658 DOVCV = .TRUE. 1659 REDOJ = .TRUE. 1660 ELSE IF (J.EQ.1) THEN 1661 DOVCV = .TRUE. 1662 REDOJ = .FALSE. 1663 ELSE 1664 DOVCV = .FALSE. 1665 REDOJ = .FALSE. 1666 END IF 1667 1668 J = MOD(JOB,100)/10 1669 IF (J.EQ.0) THEN 1670 ANAJAC = .FALSE. 1671 CDJAC = .FALSE. 1672 CHKJAC = .FALSE. 1673 ELSE IF (J.EQ.1) THEN 1674 ANAJAC = .FALSE. 1675 CDJAC = .TRUE. 1676 CHKJAC = .FALSE. 1677 ELSE IF (J.EQ.2) THEN 1678 ANAJAC = .TRUE. 1679 CDJAC = .FALSE. 1680 CHKJAC = .TRUE. 1681 ELSE 1682 ANAJAC = .TRUE. 1683 CDJAC = .FALSE. 1684 CHKJAC = .FALSE. 1685 END IF 1686 1687 J = MOD(JOB,10) 1688 IF (J.EQ.0) THEN 1689 ISODR = .TRUE. 1690 IMPLCT = .FALSE. 1691 ELSE IF (J.EQ.1) THEN 1692 ISODR = .TRUE. 1693 IMPLCT = .TRUE. 1694 ELSE 1695 ISODR = .FALSE. 1696 IMPLCT = .FALSE. 1697 END IF 1698 1699 ELSE 1700 1701 RESTRT = .FALSE. 1702 INITD = .TRUE. 1703 DOVCV = .TRUE. 1704 REDOJ = .TRUE. 1705 ANAJAC = .FALSE. 1706 CDJAC = .FALSE. 1707 CHKJAC = .FALSE. 1708 ISODR = .TRUE. 1709 IMPLCT = .FALSE. 1710 1711 END IF 1712 1713 RETURN 1714 END 1715*DHSTEP 1716 DOUBLE PRECISION FUNCTION DHSTEP 1717 + (ITYPE,NETA,I,J,STP,LDSTP) 1718C***BEGIN PROLOGUE DHSTEP 1719C***REFER TO DODR,DODRC 1720C***ROUTINES CALLED (NONE) 1721C***DATE WRITTEN 860529 (YYMMDD) 1722C***REVISION DATE 920304 (YYMMDD) 1723C***PURPOSE SET RELATIVE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES 1724C***END PROLOGUE DHSTEP 1725 1726C...SCALAR ARGUMENTS 1727 INTEGER 1728 + I,ITYPE,J,LDSTP,NETA 1729 1730C...ARRAY ARGUMENTS 1731 DOUBLE PRECISION 1732 + STP(LDSTP,J) 1733 1734C...LOCAL SCALARS 1735 DOUBLE PRECISION 1736 + TEN,THREE,TWO,ZERO 1737 1738C...DATA STATEMENTS 1739 DATA 1740 + ZERO,TWO,THREE,TEN 1741 + /0.0D0,2.0D0,3.0D0,10.0D0/ 1742 1743C...VARIABLE DEFINITIONS (ALPHABETICALLY) 1744C I: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. 1745C ITYPE: THE FINITE DIFFERENCE METHOD BEING USED, WHERE 1746C ITYPE = 0 INDICATES FORWARD FINITE DIFFERENCES, AND 1747C ITYPE = 1 INDICATES CENTRAL FINITE DIFFERENCES. 1748C J: AN IDENTIFIER FOR SELECTING USER SUPPLIED STEP SIZES. 1749C LDSTP: THE LEADING DIMENSION OF ARRAY STP. 1750C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. 1751C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. 1752C TEN: THE VALUE 10.0D0. 1753C THREE: THE VALUE 3.0D0. 1754C TWO: THE VALUE 2.0D0. 1755C ZERO: THE VALUE 0.0D0. 1756 1757 1758 1759C***FIRST EXECUTABLE STATEMENT DHSTEP 1760 1761 1762C SET DHSTEP TO RELATIVE FINITE DIFFERENCE STEP SIZE 1763 1764 IF (STP(1,1).LE.ZERO) THEN 1765 1766 IF (ITYPE.EQ.0) THEN 1767C USE DEFAULT FORWARD FINITE DIFFERENCE STEP SIZE 1768 DHSTEP = TEN**(-ABS(NETA)/TWO - TWO) 1769 1770 ELSE 1771C USE DEFAULT CENTRAL FINITE DIFFERENCE STEP SIZE 1772 DHSTEP = TEN**(-ABS(NETA)/THREE) 1773 END IF 1774 1775 ELSE IF (LDSTP.EQ.1) THEN 1776 DHSTEP = STP(1,J) 1777 1778 ELSE 1779 DHSTEP = STP(I,J) 1780 END IF 1781 1782 RETURN 1783 END 1784*DIFIX 1785 SUBROUTINE DIFIX 1786 + (N,M,IFIX,LDIFIX,T,LDT,TFIX,LDTFIX) 1787C***BEGIN PROLOGUE DIFIX 1788C***REFER TO DODR,DODRC 1789C***ROUTINES CALLED (NONE) 1790C***DATE WRITTEN 910612 (YYMMDD) 1791C***REVISION DATE 920304 (YYMMDD) 1792C***PURPOSE SET ELEMENTS OF T TO ZERO ACCORDING TO IFIX 1793C***END PROLOGUE DIFIX 1794 1795C...SCALAR ARGUMENTS 1796 INTEGER 1797 + LDIFIX,LDT,LDTFIX,M,N 1798 1799C...ARRAY ARGUMENTS 1800 DOUBLE PRECISION 1801 + T(LDT,M),TFIX(LDTFIX,M) 1802 INTEGER 1803 + IFIX(LDIFIX,M) 1804 1805C...LOCAL SCALARS 1806 DOUBLE PRECISION 1807 + ZERO 1808 INTEGER 1809 + I,J 1810 1811C...INTRINSIC FUNCTIONS 1812 INTRINSIC 1813 + ABS 1814 1815C...DATA STATEMENTS 1816 DATA 1817 + ZERO 1818 + /0.0D0/ 1819 1820C...VARIABLE DEFINITIONS (ALPHABETICALLY) 1821C I: AN INDEXING VARIABLE. 1822C IFIX: THE ARRAY DESIGNATING WHETHER AN ELEMENT OF T IS TO BE 1823C SET TO ZERO. 1824C J: AN INDEXING VARIABLE. 1825C LDT: THE LEADING DIMENSION OF ARRAY T. 1826C LDIFIX: THE LEADING DIMENSION OF ARRAY IFIX. 1827C LDTFIX: THE LEADING DIMENSION OF ARRAY TFIX. 1828C M: THE NUMBER OF COLUMNS OF DATA IN THE ARRAY. 1829C N: THE NUMBER OF ROWS OF DATA IN THE ARRAY. 1830C T: THE ARRAY BEING SET TO ZERO ACCORDING TO THE ELEMENTS 1831C OF IFIX. 1832C TFIX: THE RESULTING ARRAY. 1833C ZERO: THE VALUE 0.0D0. 1834 1835 1836C***FIRST EXECUTABLE STATEMENT DIFIX 1837 1838 1839 IF (N.EQ.0 .OR. M.EQ.0) RETURN 1840 1841 IF (IFIX(1,1).GE.ZERO) THEN 1842 IF (LDIFIX.GE.N) THEN 1843 DO 20 J=1,M 1844 DO 10 I=1,N 1845 IF (IFIX(I,J).EQ.0) THEN 1846 TFIX(I,J) = ZERO 1847 ELSE 1848 TFIX(I,J) = T(I,J) 1849 END IF 1850 10 CONTINUE 1851 20 CONTINUE 1852 ELSE 1853 DO 100 J=1,M 1854 IF (IFIX(1,J).EQ.0) THEN 1855 DO 30 I=1,N 1856 TFIX(I,J) = ZERO 1857 30 CONTINUE 1858 ELSE 1859 DO 90 I=1,N 1860 TFIX(I,J) = T(I,J) 1861 90 CONTINUE 1862 END IF 1863 100 CONTINUE 1864 END IF 1865 END IF 1866 1867 RETURN 1868 END 1869*DINIWK 1870 SUBROUTINE DINIWK 1871 + (N,M,NP,WORK,LWORK,IWORK,LIWORK, 1872 + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, 1873 + BETA,SCLB, 1874 + SSTOL,PARTOL,MAXIT,TAUFAC, 1875 + JOB,IPRINT,LUNERR,LUNRPT, 1876 + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, 1877 + JOBI,IPRINI,LUNERI,LUNRPI, 1878 + SSFI,TTI,LDTTI,DELTAI) 1879C***BEGIN PROLOGUE DINIWK 1880C***REFER TO DODR,DODRC 1881C***ROUTINES CALLED DFLAGS,DMPREC,DSCLB,DSCLD,DZERO 1882C***DATE WRITTEN 860529 (YYMMDD) 1883C***REVISION DATE 920304 (YYMMDD) 1884C***PURPOSE INITIALIZE WORK VECTORS AS NECESSARY 1885C***END PROLOGUE DINIWK 1886 1887C...SCALAR ARGUMENTS 1888 DOUBLE PRECISION 1889 + PARTOL,SSTOL,TAUFAC 1890 INTEGER 1891 + DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX, 1892 + LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M, 1893 + MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI 1894 1895C...ARRAY ARGUMENTS 1896 DOUBLE PRECISION 1897 + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M) 1898 INTEGER 1899 + IFIXX(LDIFX,M),IWORK(LIWORK) 1900 1901C...LOCAL SCALARS 1902 DOUBLE PRECISION 1903 + ONE,THREE,TWO,ZERO 1904 INTEGER 1905 + I,J 1906 LOGICAL 1907 + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT 1908 1909C...EXTERNAL FUNCTIONS 1910 DOUBLE PRECISION 1911 + DMPREC 1912 EXTERNAL 1913 + DMPREC 1914 1915C...EXTERNAL SUBROUTINES 1916 EXTERNAL 1917 + DCOPY,DFLAGS,DSCLB,DSCLD,DZERO 1918 1919C...INTRINSIC FUNCTIONS 1920 INTRINSIC 1921 + MIN,SQRT 1922 1923C...DATA STATEMENTS 1924 DATA 1925 + ZERO,ONE,TWO,THREE 1926 + /0.0D0,1.0D0,2.0D0,3.0D0/ 1927 1928C...VARIABLE DEFINITIONS (ALPHABETICALLY) 1929C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 1930C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT 1931C (ANAJAC=TRUE). 1932C BETA: THE FUNCTION PARAMETERS. 1933C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 1934C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD 1935C DIFFERENCES (CDJAC=FALSE). 1936C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER-SUPPLIED 1937C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT 1938C (CHKJAC=FALSE). 1939C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. 1940C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 1941C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). 1942C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. 1943C I: AN INDEXING VARIABLE. 1944C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED 1945C AT THEIR INPUT VALUES OR NOT. 1946C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 1947C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 1948C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED 1949C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M 1950C ELEMENTS OF ARRAY WORK (INITD=FALSE). 1951C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. 1952C IPRINT: THE PRINT CONTROL VARIABLE. 1953C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 1954C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 1955C IWORK: THE INTEGER WORK SPACE. 1956C J: AN INDEXING VARIABLE. 1957C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 1958C COMPUTATIONAL METHOD. 1959C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. 1960C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 1961C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. 1962C LDTTI: THE LEADING DIMENSION OF ARRAY TT. 1963C LDX: THE LEADING DIMENSION OF ARRAY X. 1964C LIWORK: THE LENGTH OF VECTOR IWORK. 1965C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. 1966C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. 1967C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. 1968C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. 1969C LWORK: THE LENGTH OF VECTOR WORK. 1970C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. 1971C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 1972C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. 1973C N: THE NUMBER OF OBSERVATIONS. 1974C NP: THE NUMBER OF FUNCTION PARAMETERS. 1975C ONE: THE VALUE 1.0D0. 1976C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. 1977C PARTOL: THE PARAMETER CONVERGENCE STOPPING CRITERIA. 1978C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO 1979C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 1980C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). 1981C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 1982C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). 1983C SCLB: THE SCALING VALUES FOR BETA. 1984C SCLD: THE SCALING VALUES FOR DELTA. 1985C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. 1986C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. 1987C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. 1988C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 1989C DIAMETER. 1990C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. 1991C THREE: THE VALUE 3.0D0. 1992C TTI: THE STARTING LOCATION IN ARRAY WORK OF THE ARRAY TT. 1993C TWO: THE VALUE 2.0D0. 1994C WORK: THE DOUBLE PRECISION WORK SPACE. 1995C X: THE INDEPENDENT VARIABLE. 1996C ZERO: THE VALUE 0.0D0. 1997 1998 1999C***FIRST EXECUTABLE STATEMENT DINIWK 2000 2001 2002 CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, 2003 + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) 2004 2005C STORE VALUE OF MACHINE PRECISION IN WORK VECTOR 2006 2007 WORK(EPSMAI) = DMPREC() 2008 2009C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE 2010C PARAMETERS (SEE ALSO SUBPROGRAM DODCNT) 2011 2012 IF (PARTOL.LT.ZERO) THEN 2013 WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE) 2014 ELSE 2015 WORK(PARTLI) = MIN(PARTOL, ONE) 2016 END IF 2017 2018C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE 2019C SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS 2020 2021 IF (SSTOL.LT.ZERO) THEN 2022 WORK(SSTOLI) = SQRT(WORK(EPSMAI)) 2023 ELSE 2024 WORK(SSTOLI) = MIN(SSTOL, ONE) 2025 END IF 2026 2027C SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION 2028 2029 IF (TAUFAC.LE.ZERO) THEN 2030 WORK(TAUFCI) = ONE 2031 ELSE 2032 WORK(TAUFCI) = MIN(TAUFAC, ONE) 2033 END IF 2034 2035C SET MAXIMUM NUMBER OF ITERATIONS 2036 2037 IF (MAXIT.LT.0) THEN 2038 IWORK(MAXITI) = 50 2039 ELSE 2040 IWORK(MAXITI) = MAXIT 2041 END IF 2042 2043C STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL 2044C VARIABLE 2045 2046 IF (JOB.LE.0) THEN 2047 IWORK(JOBI) = 0 2048 ELSE 2049 IWORK(JOBI) = JOB 2050 END IF 2051 2052C SET PRINT CONTROL 2053 2054 IF (IPRINT.LT.0) THEN 2055 IWORK(IPRINI) = 2001 2056 ELSE 2057 IWORK(IPRINI) = IPRINT 2058 END IF 2059 2060C SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES 2061 2062 IF (LUNERR.LT.0) THEN 2063 IWORK(LUNERI) = 6 2064 ELSE 2065 IWORK(LUNERI) = LUNERR 2066 END IF 2067 2068C SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS 2069 2070 IF (LUNRPT.LT.0) THEN 2071 IWORK(LUNRPI) = 6 2072 ELSE 2073 IWORK(LUNRPI) = LUNRPT 2074 END IF 2075 2076C COMPUTE SCALING FOR BETA'S AND DELTA'S 2077 2078 IF (SCLB(1).LE.ZERO) THEN 2079 CALL DSCLB(NP,BETA,WORK(SSFI)) 2080 ELSE 2081 CALL DCOPY(NP,SCLB,1,WORK(SSFI),1) 2082 END IF 2083 IF (ISODR) THEN 2084 IF (SCLD(1,1).LE.ZERO) THEN 2085 IWORK(LDTTI) = N 2086 CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI)) 2087 ELSE 2088 IF (LDSCLD.EQ.1) THEN 2089 IWORK(LDTTI) = 1 2090 CALL DCOPY(M,SCLD(1,1),1,WORK(TTI),1) 2091 ELSE 2092 IWORK(LDTTI) = N 2093 DO 10 J=1,M 2094 CALL DCOPY(N,SCLD(1,J),1, 2095 + WORK(TTI+(J-1)*IWORK(LDTTI)),1) 2096 10 CONTINUE 2097 END IF 2098 END IF 2099 END IF 2100 2101C INITIALIZE DELTA'S AS NECESSARY 2102 2103 IF (ISODR) THEN 2104 IF (INITD) THEN 2105 CALL DZERO(N,M,WORK(DELTAI),N) 2106 ELSE 2107 IF (IFIXX(1,1).GE.0) THEN 2108 IF (LDIFX.EQ.1) THEN 2109 DO 20 J=1,M 2110 IF (IFIXX(1,J).EQ.0) THEN 2111 CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N) 2112 END IF 2113 20 CONTINUE 2114 ELSE 2115 DO 40 J=1,M 2116 DO 30 I=1,N 2117 IF (IFIXX(I,J).EQ.0) THEN 2118 WORK(DELTAI-1+I+(J-1)*N) = ZERO 2119 END IF 2120 30 CONTINUE 2121 40 CONTINUE 2122 END IF 2123 END IF 2124 END IF 2125 ELSE 2126 CALL DZERO(N,M,WORK(DELTAI),N) 2127 END IF 2128 2129 RETURN 2130 END 2131*DIWINF 2132 SUBROUTINE DIWINF 2133 + (M,NP,NQ, 2134 + MSGBI,MSGDI,IFIX2I,ISTOPI, 2135 + NNZWI,NPPI,IDFI, 2136 + JOBI,IPRINI,LUNERI,LUNRPI, 2137 + NROWI,NTOLI,NETAI, 2138 + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, 2139 + LIWKMN) 2140C***BEGIN PROLOGUE DIWINF 2141C***REFER TO DODR,DODRC 2142C***ROUTINES CALLED (NONE) 2143C***DATE WRITTEN 860529 (YYMMDD) 2144C***REVISION DATE 920304 (YYMMDD) 2145C***PURPOSE SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE 2146C***END PROLOGUE DIWINF 2147 2148C...SCALAR ARGUMENTS 2149 INTEGER 2150 + IDFI,INT2I,IPRINI,IRANKI,ISTOPI,JOBI,IFIX2I,LDTTI,LIWKMN, 2151 + LUNERI,LUNRPI,M,MAXITI,MSGBI,MSGDI,NETAI,NFEVI,NITERI,NJEVI, 2152 + NNZWI,NP,NPPI,NQ,NROWI,NTOLI 2153 2154C...VARIABLE DEFINITIONS (ALPHABETICALLY) 2155C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. 2156C IFIX2I: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY IFIX2. 2157C INT2I: THE LOCATION IN ARRAY IWORK OF VARIABLE INT2. 2158C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. 2159C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. 2160C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. 2161C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. 2162C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. 2163C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. 2164C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. 2165C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. 2166C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. 2167C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. 2168C MSGBI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. 2169C MSGDI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. 2170C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. 2171C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. 2172C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABEL NITER. 2173C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. 2174C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. 2175C NP: THE NUMBER OF FUNCTION PARAMETERS. 2176C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. 2177C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 2178C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. 2179C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. 2180 2181 2182C***FIRST EXECUTABLE STATEMENT DIWINF 2183 2184 2185 IF (NP.GE.1 .AND. M.GE.1) THEN 2186 MSGBI = 1 2187 MSGDI = MSGBI + NQ*NP+1 2188 IFIX2I = MSGDI + NQ*M+1 2189 ISTOPI = IFIX2I + NP 2190 NNZWI = ISTOPI + 1 2191 NPPI = NNZWI + 1 2192 IDFI = NPPI + 1 2193 JOBI = IDFI + 1 2194 IPRINI = JOBI + 1 2195 LUNERI = IPRINI + 1 2196 LUNRPI = LUNERI + 1 2197 NROWI = LUNRPI + 1 2198 NTOLI = NROWI + 1 2199 NETAI = NTOLI + 1 2200 MAXITI = NETAI + 1 2201 NITERI = MAXITI + 1 2202 NFEVI = NITERI + 1 2203 NJEVI = NFEVI + 1 2204 INT2I = NJEVI + 1 2205 IRANKI = INT2I + 1 2206 LDTTI = IRANKI + 1 2207 LIWKMN = LDTTI 2208 ELSE 2209 MSGBI = 1 2210 MSGDI = 1 2211 IFIX2I = 1 2212 ISTOPI = 1 2213 NNZWI = 1 2214 NPPI = 1 2215 IDFI = 1 2216 JOBI = 1 2217 IPRINI = 1 2218 LUNERI = 1 2219 LUNRPI = 1 2220 NROWI = 1 2221 NTOLI = 1 2222 NETAI = 1 2223 MAXITI = 1 2224 NITERI = 1 2225 NFEVI = 1 2226 NJEVI = 1 2227 INT2I = 1 2228 IRANKI = 1 2229 LDTTI = 1 2230 LIWKMN = 1 2231 END IF 2232 2233 RETURN 2234 END 2235*DJACCD 2236 SUBROUTINE DJACCD 2237 + (FCN, 2238 + N,M,NP,NQ, 2239 + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, 2240 + STPB,STPD,LDSTPD, 2241 + SSF,TT,LDTT,NETA,STP,WRK1,WRK2,WRK3,WRK6, 2242 + FJACB,ISODR,FJACD,NFEV,ISTOP) 2243C***BEGIN PROLOGUE DJACCD 2244C***REFER TO DODR,DODRC 2245C***ROUTINES CALLED FCN,DHSTEP,DZERO 2246C***DATE WRITTEN 860529 (YYMMDD) 2247C***REVISION DATE 920619 (YYMMDD) 2248C***PURPOSE COMPUTE CENTRAL DIFFERENCE APPROXIMATIONS TO THE 2249C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS 2250C***END PROLOGUE DJACCD 2251 2252C...SCALAR ARGUMENTS 2253 INTEGER 2254 + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ 2255 LOGICAL 2256 + ISODR 2257 2258C...ARRAY ARGUMENTS 2259 DOUBLE PRECISION 2260 + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ), 2261 + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), 2262 + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), 2263 + X(LDX,M),XPLUSD(N,M) 2264 INTEGER 2265 + IFIXB(NP),IFIXX(LDIFX,M) 2266 2267C...SUBROUTINE ARGUMENTS 2268 EXTERNAL 2269 + FCN 2270 2271C...LOCAL SCALARS 2272 DOUBLE PRECISION 2273 + BETAK,ONE,TYPJ,ZERO 2274 INTEGER 2275 + I,J,K,L 2276 LOGICAL 2277 + DOIT,SETZRO 2278 2279C...EXTERNAL SUBROUTINES 2280 EXTERNAL 2281 + DZERO 2282 2283C...EXTERNAL FUNCTIONS 2284 DOUBLE PRECISION 2285 + DHSTEP 2286 EXTERNAL 2287 + DHSTEP 2288 2289C...INTRINSIC FUNCTIONS 2290 INTRINSIC 2291 + ABS,MAX,SIGN,SQRT 2292 2293C...DATA STATEMENTS 2294 DATA 2295 + ZERO,ONE 2296 + /0.0D0,1.0D0/ 2297 2298C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 2299C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 2300 2301C...VARIABLE DEFINITIONS (ALPHABETICALLY) 2302C BETA: THE FUNCTION PARAMETERS. 2303C BETAK: THE K-TH FUNCTION PARAMETER. 2304C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 2305C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A GIVEN 2306C BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT 2307C (DOIT=FALSE). 2308C FJACB: THE JACOBIAN WITH RESPECT TO BETA. 2309C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. 2310C I: AN INDEXING VARIABLE. 2311C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 2312C FIXED AT THEIR INPUT VALUES OR NOT. 2313C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE FIXED 2314C AT THEIR INPUT VALUES OR NOT. 2315C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 2316C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 2317C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 2318C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 2319C J: AN INDEXING VARIABLE. 2320C K: AN INDEXING VARIABLE. 2321C L: AN INDEXING VARIABLE. 2322C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 2323C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 2324C LDTT: THE LEADING DIMENSION OF ARRAY TT. 2325C LDX: THE LEADING DIMENSION OF ARRAY X. 2326C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 2327C N: THE NUMBER OF OBSERVATIONS. 2328C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. 2329C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 2330C NP: THE NUMBER OF FUNCTION PARAMETERS. 2331C ONE: THE VALUE 1.0D0. 2332C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME 2333C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT 2334C (SETZRO=FALSE). 2335C SSF: THE SCALING VALUES USED FOR BETA. 2336C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE 2337C DERIVATIVES WITH RESPECT TO EACH DELTA. 2338C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE 2339C DERIVATIVES WITH RESPECT TO EACH BETA. 2340C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE 2341C DERIVATIVES WITH RESPECT TO EACH DELTA. 2342C TT: THE SCALING VALUES USED FOR DELTA. 2343C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. 2344C X: THE EXPLANATORY VARIABLE. 2345C XPLUSD: THE VALUES OF X + DELTA. 2346C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. 2347C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 2348C WRK3: A WORK ARRAY OF (NP) ELEMENTS. 2349C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. 2350C ZERO: THE VALUE 0.0D0. 2351 2352 2353C***FIRST EXECUTABLE STATEMENT DJACCD 2354 2355 2356C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS 2357 2358 DO 60 K=1,NP 2359 IF (IFIXB(1).GE.0) THEN 2360 IF (IFIXB(K).EQ.0) THEN 2361 DOIT = .FALSE. 2362 ELSE 2363 DOIT = .TRUE. 2364 END IF 2365 ELSE 2366 DOIT = .TRUE. 2367 END IF 2368 IF (.NOT.DOIT) THEN 2369 DO 10 L=1,NQ 2370 CALL DZERO(N,1,FJACB(1,K,L),N) 2371 10 CONTINUE 2372 ELSE 2373 BETAK = BETA(K) 2374 IF (BETAK.EQ.ZERO) THEN 2375 IF (SSF(1).LT.ZERO) THEN 2376 TYPJ = ONE/ABS(SSF(1)) 2377 ELSE 2378 TYPJ = ONE/SSF(K) 2379 END IF 2380 ELSE 2381 TYPJ = ABS(BETAK) 2382 END IF 2383 WRK3(K) = BETAK 2384 + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(1,NETA,1,K,STPB,1) 2385 WRK3(K) = WRK3(K) - BETAK 2386 2387 BETA(K) = BETAK + WRK3(K) 2388 ISTOP = 0 2389 CALL FCN(N,M,NP,NQ, 2390 + N,M,NP, 2391 + BETA,XPLUSD, 2392 + IFIXB,IFIXX,LDIFX, 2393 + 001,WRK2,WRK6,WRK1, 2394 + ISTOP) 2395 IF (ISTOP.NE.0) THEN 2396 RETURN 2397 ELSE 2398 NFEV = NFEV + 1 2399 DO 30 L=1,NQ 2400 DO 20 I=1,N 2401 FJACB(I,K,L) = WRK2(I,L) 2402 20 CONTINUE 2403 30 CONTINUE 2404 END IF 2405 2406 BETA(K) = BETAK - WRK3(K) 2407 ISTOP = 0 2408 CALL FCN(N,M,NP,NQ, 2409 + N,M,NP, 2410 + BETA,XPLUSD, 2411 + IFIXB,IFIXX,LDIFX, 2412 + 001,WRK2,WRK6,WRK1, 2413 + ISTOP) 2414 IF (ISTOP.NE.0) THEN 2415 RETURN 2416 ELSE 2417 NFEV = NFEV + 1 2418 END IF 2419 2420 DO 50 L=1,NQ 2421 DO 40 I=1,N 2422 FJACB(I,K,L) = (FJACB(I,K,L)-WRK2(I,L))/(2*WRK3(K)) 2423 40 CONTINUE 2424 50 CONTINUE 2425 BETA(K) = BETAK 2426 END IF 2427 60 CONTINUE 2428 2429C COMPUTE THE JACOBIAN WRT THE X'S 2430 2431 IF (ISODR) THEN 2432 DO 220 J=1,M 2433 IF (IFIXX(1,1).LT.0) THEN 2434 DOIT = .TRUE. 2435 SETZRO = .FALSE. 2436 ELSE IF (LDIFX.EQ.1) THEN 2437 IF (IFIXX(1,J).EQ.0) THEN 2438 DOIT = .FALSE. 2439 ELSE 2440 DOIT = .TRUE. 2441 END IF 2442 SETZRO = .FALSE. 2443 ELSE 2444 DOIT = .FALSE. 2445 SETZRO = .FALSE. 2446 DO 100 I=1,N 2447 IF (IFIXX(I,J).NE.0) THEN 2448 DOIT = .TRUE. 2449 ELSE 2450 SETZRO = .TRUE. 2451 END IF 2452 100 CONTINUE 2453 END IF 2454 IF (.NOT.DOIT) THEN 2455 DO 110 L=1,NQ 2456 CALL DZERO(N,1,FJACD(1,J,L),N) 2457 110 CONTINUE 2458 ELSE 2459 DO 120 I=1,N 2460 IF (XPLUSD(I,J).EQ.ZERO) THEN 2461 IF (TT(1,1).LT.ZERO) THEN 2462 TYPJ = ONE/ABS(TT(1,1)) 2463 ELSE IF (LDTT.EQ.1) THEN 2464 TYPJ = ONE/TT(1,J) 2465 ELSE 2466 TYPJ = ONE/TT(I,J) 2467 END IF 2468 ELSE 2469 TYPJ = ABS(XPLUSD(I,J)) 2470 END IF 2471 STP(I) = XPLUSD(I,J) 2472 + + SIGN(ONE,XPLUSD(I,J)) 2473 + *TYPJ*DHSTEP(1,NETA,I,J,STPD,LDSTPD) 2474 STP(I) = STP(I) - XPLUSD(I,J) 2475 XPLUSD(I,J) = XPLUSD(I,J) + STP(I) 2476 120 CONTINUE 2477 ISTOP = 0 2478 CALL FCN(N,M,NP,NQ, 2479 + N,M,NP, 2480 + BETA,XPLUSD, 2481 + IFIXB,IFIXX,LDIFX, 2482 + 001,WRK2,WRK6,WRK1, 2483 + ISTOP) 2484 IF (ISTOP.NE.0) THEN 2485 RETURN 2486 ELSE 2487 NFEV = NFEV + 1 2488 DO 140 L=1,NQ 2489 DO 130 I=1,N 2490 FJACD(I,J,L) = WRK2(I,L) 2491 130 CONTINUE 2492 140 CONTINUE 2493 END IF 2494 2495 DO 150 I=1,N 2496 XPLUSD(I,J) = X(I,J) + DELTA(I,J) - STP(I) 2497 150 CONTINUE 2498 ISTOP = 0 2499 CALL FCN(N,M,NP,NQ, 2500 + N,M,NP, 2501 + BETA,XPLUSD, 2502 + IFIXB,IFIXX,LDIFX, 2503 + 001,WRK2,WRK6,WRK1, 2504 + ISTOP) 2505 IF (ISTOP.NE.0) THEN 2506 RETURN 2507 ELSE 2508 NFEV = NFEV + 1 2509 END IF 2510 2511 IF (SETZRO) THEN 2512 DO 180 I=1,N 2513 IF (IFIXX(I,J).EQ.0) THEN 2514 DO 160 L=1,NQ 2515 FJACD(I,J,L) = ZERO 2516 160 CONTINUE 2517 ELSE 2518 DO 170 L=1,NQ 2519 FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ 2520 + (2*STP(I)) 2521 170 CONTINUE 2522 END IF 2523 180 CONTINUE 2524 ELSE 2525 DO 200 L=1,NQ 2526 DO 190 I=1,N 2527 FJACD(I,J,L) = (FJACD(I,J,L)-WRK2(I,L))/ 2528 + (2*STP(I)) 2529 190 CONTINUE 2530 200 CONTINUE 2531 END IF 2532 DO 210 I=1,N 2533 XPLUSD(I,J) = X(I,J) + DELTA(I,J) 2534 210 CONTINUE 2535 END IF 2536 220 CONTINUE 2537 END IF 2538 2539 RETURN 2540 END 2541*DJACFD 2542 SUBROUTINE DJACFD 2543 + (FCN, 2544 + N,M,NP,NQ, 2545 + BETA,X,LDX,DELTA,XPLUSD,IFIXB,IFIXX,LDIFX, 2546 + STPB,STPD,LDSTPD, 2547 + SSF,TT,LDTT,NETA,FN,STP,WRK1,WRK2,WRK3,WRK6, 2548 + FJACB,ISODR,FJACD,NFEV,ISTOP) 2549C***BEGIN PROLOGUE DJACFD 2550C***REFER TO DODR,DODRC 2551C***ROUTINES CALLED FCN,DHSTEP,DZERO 2552C***DATE WRITTEN 860529 (YYMMDD) 2553C***REVISION DATE 920619 (YYMMDD) 2554C***PURPOSE COMPUTE FORWARD DIFFERENCE APPROXIMATIONS TO THE 2555C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS 2556C***END PROLOGUE DJACFD 2557 2558C...SCALAR ARGUMENTS 2559 INTEGER 2560 + ISTOP,LDIFX,LDSTPD,LDTT,LDX,M,N,NETA,NFEV,NP,NQ 2561 LOGICAL 2562 + ISODR 2563 2564C...ARRAY ARGUMENTS 2565 DOUBLE PRECISION 2566 + BETA(NP),DELTA(N,M),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ), 2567 + SSF(NP),STP(N),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), 2568 + WRK1(N,M,NQ),WRK2(N,NQ),WRK3(NP),WRK6(N,NP,NQ), 2569 + X(LDX,M),XPLUSD(N,M) 2570 INTEGER 2571 + IFIXB(NP),IFIXX(LDIFX,M) 2572 2573C...SUBROUTINE ARGUMENTS 2574 EXTERNAL 2575 + FCN 2576 2577C...LOCAL SCALARS 2578 DOUBLE PRECISION 2579 + BETAK,ONE,TYPJ,ZERO 2580 INTEGER 2581 + I,J,K,L 2582 LOGICAL 2583 + DOIT,SETZRO 2584 2585C...EXTERNAL SUBROUTINES 2586 EXTERNAL 2587 + DZERO 2588 2589C...EXTERNAL FUNCTIONS 2590 DOUBLE PRECISION 2591 + DHSTEP 2592 EXTERNAL 2593 + DHSTEP 2594 2595C...INTRINSIC FUNCTIONS 2596 INTRINSIC 2597 + ABS,MAX,SIGN,SQRT 2598 2599C...DATA STATEMENTS 2600 DATA 2601 + ZERO,ONE 2602 + /0.0D0,1.0D0/ 2603 2604C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 2605C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 2606 2607C...VARIABLE DEFINITIONS (ALPHABETICALLY) 2608C BETA: THE FUNCTION PARAMETERS. 2609C BETAK: THE K-TH FUNCTION PARAMETER. 2610C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 2611C DOIT: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT A 2612C GIVEN BETA OR DELTA NEEDS TO BE COMPUTED (DOIT=TRUE) 2613C OR NOT (DOIT=FALSE). 2614C FJACB: THE JACOBIAN WITH RESPECT TO BETA. 2615C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. 2616C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. 2617C I: AN INDEXING VARIABLE. 2618C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 2619C FIXED AT THEIR INPUT VALUES OR NOT. 2620C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 2621C FIXED AT THEIR INPUT VALUES OR NOT. 2622C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 2623C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 2624C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 2625C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 2626C J: AN INDEXING VARIABLE. 2627C K: AN INDEXING VARIABLE. 2628C L: AN INDEXING VARIABLE. 2629C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 2630C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 2631C LDTT: THE LEADING DIMENSION OF ARRAY TT. 2632C LDX: THE LEADING DIMENSION OF ARRAY X. 2633C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 2634C N: THE NUMBER OF OBSERVATIONS. 2635C NETA: THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. 2636C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 2637C NP: THE NUMBER OF FUNCTION PARAMETERS. 2638C ONE: THE VALUE 1.0D0. 2639C SETZRO: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVE WRT SOME 2640C DELTA NEEDS TO BE SET TO ZERO (SETZRO=TRUE) OR NOT 2641C (SETZRO=FALSE). 2642C SSF: THE SCALE USED FOR THE BETA'S. 2643C STP: THE STEP USED FOR COMPUTING FINITE DIFFERENCE 2644C DERIVATIVES WITH RESPECT TO DELTA. 2645C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE 2646C DERIVATIVES WITH RESPECT TO BETA. 2647C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE 2648C DERIVATIVES WITH RESPECT TO DELTA. 2649C TT: THE SCALING VALUES USED FOR DELTA. 2650C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. 2651C X: THE EXPLANATORY VARIABLE. 2652C XPLUSD: THE VALUES OF X + DELTA. 2653C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. 2654C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 2655C WRK3: A WORK ARRAY OF (NP) ELEMENTS. 2656C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. 2657C ZERO: THE VALUE 0.0D0. 2658 2659 2660C***FIRST EXECUTABLE STATEMENT DJACFD 2661 2662 2663C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS 2664 2665 DO 40 K=1,NP 2666 IF (IFIXB(1).GE.0) THEN 2667 IF (IFIXB(K).EQ.0) THEN 2668 DOIT = .FALSE. 2669 ELSE 2670 DOIT = .TRUE. 2671 END IF 2672 ELSE 2673 DOIT = .TRUE. 2674 END IF 2675 IF (.NOT.DOIT) THEN 2676 DO 10 L=1,NQ 2677 CALL DZERO(N,1,FJACB(1,K,L),N) 2678 10 CONTINUE 2679 ELSE 2680 BETAK = BETA(K) 2681 IF (BETAK.EQ.ZERO) THEN 2682 IF (SSF(1).LT.ZERO) THEN 2683 TYPJ = ONE/ABS(SSF(1)) 2684 ELSE 2685 TYPJ = ONE/SSF(K) 2686 END IF 2687 ELSE 2688 TYPJ = ABS(BETAK) 2689 END IF 2690 WRK3(K) = BETAK 2691 + + SIGN(ONE,BETAK)*TYPJ*DHSTEP(0,NETA,1,K,STPB,1) 2692 WRK3(K) = WRK3(K) - BETAK 2693 BETA(K) = BETAK + WRK3(K) 2694 ISTOP = 0 2695 CALL FCN(N,M,NP,NQ, 2696 + N,M,NP, 2697 + BETA,XPLUSD, 2698 + IFIXB,IFIXX,LDIFX, 2699 + 001,WRK2,WRK6,WRK1, 2700 + ISTOP) 2701 IF (ISTOP.NE.0) THEN 2702 RETURN 2703 ELSE 2704 NFEV = NFEV + 1 2705 END IF 2706 DO 30 L=1,NQ 2707 DO 20 I=1,N 2708 FJACB(I,K,L) = (WRK2(I,L)-FN(I,L))/WRK3(K) 2709 20 CONTINUE 2710 30 CONTINUE 2711 BETA(K) = BETAK 2712 END IF 2713 40 CONTINUE 2714 2715C COMPUTE THE JACOBIAN WRT THE X'S 2716 2717 IF (ISODR) THEN 2718 DO 220 J=1,M 2719 IF (IFIXX(1,1).LT.0) THEN 2720 DOIT = .TRUE. 2721 SETZRO = .FALSE. 2722 ELSE IF (LDIFX.EQ.1) THEN 2723 IF (IFIXX(1,J).EQ.0) THEN 2724 DOIT = .FALSE. 2725 ELSE 2726 DOIT = .TRUE. 2727 END IF 2728 SETZRO = .FALSE. 2729 ELSE 2730 DOIT = .FALSE. 2731 SETZRO = .FALSE. 2732 DO 100 I=1,N 2733 IF (IFIXX(I,J).NE.0) THEN 2734 DOIT = .TRUE. 2735 ELSE 2736 SETZRO = .TRUE. 2737 END IF 2738 100 CONTINUE 2739 END IF 2740 IF (.NOT.DOIT) THEN 2741 DO 110 L=1,NQ 2742 CALL DZERO(N,1,FJACD(1,J,L),N) 2743 110 CONTINUE 2744 ELSE 2745 DO 120 I=1,N 2746 IF (XPLUSD(I,J).EQ.ZERO) THEN 2747 IF (TT(1,1).LT.ZERO) THEN 2748 TYPJ = ONE/ABS(TT(1,1)) 2749 ELSE IF (LDTT.EQ.1) THEN 2750 TYPJ = ONE/TT(1,J) 2751 ELSE 2752 TYPJ = ONE/TT(I,J) 2753 END IF 2754 ELSE 2755 TYPJ = ABS(XPLUSD(I,J)) 2756 END IF 2757 2758 STP(I) = XPLUSD(I,J) 2759 + + SIGN(ONE,XPLUSD(I,J)) 2760 + *TYPJ*DHSTEP(0,NETA,I,J,STPD,LDSTPD) 2761 STP(I) = STP(I) - XPLUSD(I,J) 2762 XPLUSD(I,J) = XPLUSD(I,J) + STP(I) 2763 120 CONTINUE 2764 2765 ISTOP = 0 2766 CALL FCN(N,M,NP,NQ, 2767 + N,M,NP, 2768 + BETA,XPLUSD, 2769 + IFIXB,IFIXX,LDIFX, 2770 + 001,WRK2,WRK6,WRK1, 2771 + ISTOP) 2772 IF (ISTOP.NE.0) THEN 2773 RETURN 2774 ELSE 2775 NFEV = NFEV + 1 2776 DO 140 L=1,NQ 2777 DO 130 I=1,N 2778 FJACD(I,J,L) = WRK2(I,L) 2779 130 CONTINUE 2780 140 CONTINUE 2781 2782 END IF 2783 2784 IF (SETZRO) THEN 2785 DO 180 I=1,N 2786 IF (IFIXX(I,J).EQ.0) THEN 2787 DO 160 L=1,NQ 2788 FJACD(I,J,L) = ZERO 2789 160 CONTINUE 2790 ELSE 2791 DO 170 L=1,NQ 2792 FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) 2793 170 CONTINUE 2794 END IF 2795 180 CONTINUE 2796 ELSE 2797 DO 200 L=1,NQ 2798 DO 190 I=1,N 2799 FJACD(I,J,L) = (FJACD(I,J,L)-FN(I,L))/STP(I) 2800 190 CONTINUE 2801 200 CONTINUE 2802 END IF 2803 DO 210 I=1,N 2804 XPLUSD(I,J) = X(I,J) + DELTA(I,J) 2805 210 CONTINUE 2806 END IF 2807 220 CONTINUE 2808 END IF 2809 2810 RETURN 2811 END 2812*DJCK 2813 SUBROUTINE DJCK 2814 + (FCN, 2815 + N,M,NP,NQ, 2816 + BETA,XPLUSD, 2817 + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, 2818 + SSF,TT,LDTT, 2819 + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, 2820 + PV0,FJACB,FJACD, 2821 + MSGB,MSGD,DIFF,ISTOP,NFEV,NJEV, 2822 + WRK1,WRK2,WRK6) 2823C***BEGIN PROLOGUE DJCK 2824C***REFER TO DODR,DODRC 2825C***ROUTINES CALLED FCN,DHSTEP,DJCKM 2826C***DATE WRITTEN 860529 (YYMMDD) 2827C***REVISION DATE 920619 (YYMMDD) 2828C***PURPOSE DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS 2829C (ADAPTED FROM STARPAC SUBROUTINE DCKCNT) 2830C***END PROLOGUE DJCK 2831 2832C...SCALAR ARGUMENTS 2833 DOUBLE PRECISION 2834 + EPSMAC,ETA 2835 INTEGER 2836 + ISTOP,LDIFX,LDSTPD,LDTT, 2837 + M,N,NETA,NFEV,NJEV,NP,NQ,NROW,NTOL 2838 LOGICAL 2839 + ISODR 2840 2841C...ARRAY ARGUMENTS 2842 DOUBLE PRECISION 2843 + BETA(NP),DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ), 2844 + PV0(N,NQ),SSF(NP),STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), 2845 + WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) 2846 INTEGER 2847 + IFIXB(NP),IFIXX(LDIFX,M),MSGB(1+NQ*NP),MSGD(1+NQ*M) 2848 2849C...SUBROUTINE ARGUMENTS 2850 EXTERNAL 2851 + FCN 2852 2853C...LOCAL SCALARS 2854 DOUBLE PRECISION 2855 + DIFFJ,H0,HC0,ONE,P5,PV,TOL,TYPJ,ZERO 2856 INTEGER 2857 + IDEVAL,J,LQ,MSGB1,MSGD1 2858 LOGICAL 2859 + ISFIXD,ISWRTB 2860 2861C...EXTERNAL SUBROUTINES 2862 EXTERNAL 2863 + DJCKM 2864 2865C...EXTERNAL FUNCTIONS 2866 DOUBLE PRECISION 2867 + DHSTEP 2868 EXTERNAL 2869 + DHSTEP 2870 2871C...INTRINSIC FUNCTIONS 2872 INTRINSIC 2873 + ABS,INT,LOG10 2874 2875C...DATA STATEMENTS 2876 DATA 2877 + ZERO,P5,ONE 2878 + /0.0D0,0.5D0,1.0D0/ 2879 2880C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 2881C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 2882 2883C...VARIABLE DEFINITIONS (ALPHABETICALLY) 2884C BETA: THE FUNCTION PARAMETERS. 2885C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND 2886C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. 2887C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND 2888C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING 2889C CHECKED. 2890C EPSMAC: THE VALUE OF MACHINE PRECISION. 2891C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. 2892C FJACB: THE JACOBIAN WITH RESPECT TO BETA. 2893C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. 2894C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. 2895C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. 2896C IDEVAL: THE VARIABLE DESIGNATING WHAT COMPUTATIONS ARE TO BE 2897C PERFORMED BY USER SUPPLIED SUBROUTINE FCN. 2898C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 2899C FIXED AT THEIR INPUT VALUES OR NOT. 2900C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 2901C FIXED AT THEIR INPUT VALUES OR NOT. 2902C ISFIXD: THE VARIABLE DESIGNATING WHETHER THE PARAMETER IS FIXED 2903C (ISFIXD=TRUE) OR NOT (ISFIXD=FALSE). 2904C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 2905C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 2906C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 2907C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). 2908C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 2909C (ISWRTB=TRUE) OR DELTA (ISWRTB=FALSE) ARE BEING CHECKED. 2910C J: AN INDEX VARIABLE. 2911C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 2912C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 2913C LDTT: THE LEADING DIMENSION OF ARRAY TT. 2914C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. 2915C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 2916C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. 2917C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. 2918C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. 2919C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. 2920C N: THE NUMBER OF OBSERVATIONS. 2921C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER 2922C SET BY THE USER OR COMPUTED BY DETAF. 2923C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 2924C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. 2925C NP: THE NUMBER OF FUNCTION PARAMETERS. 2926C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 2927C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 2928C THE DERIVATIVE IS CHECKED. 2929C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE 2930C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES. 2931C ONE: THE VALUE 1.0D0. 2932C P5: THE VALUE 0.5D0. 2933C PV: THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR 2934C ROW NROW IS STORED. 2935C PV0: THE PREDICTED VALUES USING THE CURRENT PARAMETER ESTIMATES. 2936C SSF: THE SCALING VALUES USED FOR BETA. 2937C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. 2938C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. 2939C TOL: THE AGREEMENT TOLERANCE. 2940C TT: THE SCALING VALUES USED FOR DELTA. 2941C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. 2942C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. 2943C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 2944C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. 2945C XPLUSD: THE VALUES OF X + DELTA. 2946C ZERO: THE VALUE 0.0D0. 2947 2948 2949C***FIRST EXECUTABLE STATEMENT DJCK 2950 2951 2952C SET TOLERANCE FOR CHECKING DERIVATIVES 2953 2954 TOL = ETA**(0.25D0) 2955 NTOL = MAX(ONE,P5-LOG10(TOL)) 2956 2957 2958C COMPUTE USER SUPPLIED DERIVATIVE VALUES 2959 2960 ISTOP = 0 2961 IF (ISODR) THEN 2962 IDEVAL = 110 2963 ELSE 2964 IDEVAL = 010 2965 END IF 2966 CALL FCN(N,M,NP,NQ, 2967 + N,M,NP, 2968 + BETA,XPLUSD, 2969 + IFIXB,IFIXX,LDIFX, 2970 + IDEVAL,WRK2,FJACB,FJACD, 2971 + ISTOP) 2972 IF (ISTOP.NE.0) THEN 2973 RETURN 2974 ELSE 2975 NJEV = NJEV + 1 2976 END IF 2977 2978C CHECK DERIVATIVES WRT BETA FOR EACH RESPONSE OF OBSERVATION NROW 2979 2980 MSGB1 = 0 2981 MSGD1 = 0 2982 2983 DO 30 LQ=1,NQ 2984 2985C SET PREDICTED VALUE OF MODEL AT CURRENT PARAMETER ESTIMATES 2986 PV = PV0(NROW,LQ) 2987 2988 ISWRTB = .TRUE. 2989 DO 10 J=1,NP 2990 2991 IF (IFIXB(1).LT.0) THEN 2992 ISFIXD = .FALSE. 2993 ELSE IF (IFIXB(J).EQ.0) THEN 2994 ISFIXD = .TRUE. 2995 ELSE 2996 ISFIXD = .FALSE. 2997 END IF 2998 2999 IF (ISFIXD) THEN 3000 MSGB(1+LQ+(J-1)*NQ) = -1 3001 ELSE 3002 IF (BETA(J).EQ.ZERO) THEN 3003 IF (SSF(1).LT.ZERO) THEN 3004 TYPJ = ONE/ABS(SSF(1)) 3005 ELSE 3006 TYPJ = ONE/SSF(J) 3007 END IF 3008 ELSE 3009 TYPJ = ABS(BETA(J)) 3010 END IF 3011 3012 H0 = DHSTEP(0,NETA,1,J,STPB,1) 3013 HC0 = H0 3014 3015C CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW 3016 3017 CALL DJCKM(FCN, 3018 + N,M,NP,NQ, 3019 + BETA,XPLUSD, 3020 + IFIXB,IFIXX,LDIFX, 3021 + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, 3022 + ISWRTB,PV,FJACB(NROW,J,LQ), 3023 + DIFFJ,MSGB1,MSGB(2),ISTOP,NFEV, 3024 + WRK1,WRK2,WRK6) 3025 IF (ISTOP.NE.0) THEN 3026 MSGB(1) = -1 3027 RETURN 3028 ELSE 3029 DIFF(LQ,J) = DIFFJ 3030 END IF 3031 END IF 3032 3033 10 CONTINUE 3034 3035C CHECK DERIVATIVES WRT X FOR EACH RESPONSE OF OBSERVATION NROW 3036 3037 IF (ISODR) THEN 3038 ISWRTB = .FALSE. 3039 DO 20 J=1,M 3040 3041 IF (IFIXX(1,1).LT.0) THEN 3042 ISFIXD = .FALSE. 3043 ELSE IF (LDIFX.EQ.1) THEN 3044 IF (IFIXX(1,J).EQ.0) THEN 3045 ISFIXD = .TRUE. 3046 ELSE 3047 ISFIXD = .FALSE. 3048 END IF 3049 ELSE 3050 ISFIXD = .FALSE. 3051 END IF 3052 3053 IF (ISFIXD) THEN 3054 MSGD(1+LQ+(J-1)*NQ) = -1 3055 ELSE 3056 3057 IF (XPLUSD(NROW,J).EQ.ZERO) THEN 3058 IF (TT(1,1).LT.ZERO) THEN 3059 TYPJ = ONE/ABS(TT(1,1)) 3060 ELSE IF (LDTT.EQ.1) THEN 3061 TYPJ = ONE/TT(1,J) 3062 ELSE 3063 TYPJ = ONE/TT(NROW,J) 3064 END IF 3065 ELSE 3066 TYPJ = ABS(XPLUSD(NROW,J)) 3067 END IF 3068 3069 H0 = DHSTEP(0,NETA,NROW,J,STPD,LDSTPD) 3070 HC0 = DHSTEP(1,NETA,NROW,J,STPD,LDSTPD) 3071 3072C CHECK DERIVATIVE WRT THE J-TH COLUMN OF DELTA AT ROW NROW 3073 3074 CALL DJCKM(FCN, 3075 + N,M,NP,NQ, 3076 + BETA,XPLUSD, 3077 + IFIXB,IFIXX,LDIFX, 3078 + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, 3079 + ISWRTB,PV,FJACD(NROW,J,LQ), 3080 + DIFFJ,MSGD1,MSGD(2),ISTOP,NFEV, 3081 + WRK1,WRK2,WRK6) 3082 IF (ISTOP.NE.0) THEN 3083 MSGD(1) = -1 3084 RETURN 3085 ELSE 3086 DIFF(LQ,NP+J) = DIFFJ 3087 END IF 3088 END IF 3089 3090 20 CONTINUE 3091 END IF 3092 30 CONTINUE 3093 MSGB(1) = MSGB1 3094 MSGD(1) = MSGD1 3095 3096 RETURN 3097 END 3098*DJCKC 3099 SUBROUTINE DJCKC 3100 + (FCN, 3101 + N,M,NP,NQ, 3102 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3103 + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, 3104 + FD,TYPJ,PVPSTP,STP0, 3105 + PV,D, 3106 + DIFFJ,MSG,ISTOP,NFEV, 3107 + WRK1,WRK2,WRK6) 3108C***BEGIN PROLOGUE DJCKC 3109C***REFER TO DODR,DODRC 3110C***ROUTINES CALLED DJCKF,DPVB,DPVD 3111C***DATE WRITTEN 860529 (YYMMDD) 3112C***REVISION DATE 920619 (YYMMDD) 3113C***PURPOSE CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE 3114C DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES 3115C (ADAPTED FROM STARPAC SUBROUTINE DCKCRV) 3116C***END PROLOGUE DJCKC 3117 3118C...SCALAR ARGUMENTS 3119 DOUBLE PRECISION 3120 + D,DIFFJ,EPSMAC,ETA,FD,HC,PV,PVPSTP,STP0,TOL,TYPJ 3121 INTEGER 3122 + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW 3123 LOGICAL 3124 + ISWRTB 3125 3126C...ARRAY ARGUMENTS 3127 DOUBLE PRECISION 3128 + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) 3129 INTEGER 3130 + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) 3131 3132C...SUBROUTINE ARGUMENTS 3133 EXTERNAL 3134 + FCN 3135 3136C...LOCAL SCALARS 3137 DOUBLE PRECISION 3138 + CURVE,ONE,PVMCRV,PVPCRV,P01,STP,STPCRV,TEN,TWO 3139 3140C...EXTERNAL SUBROUTINES 3141 EXTERNAL 3142 + DJCKF,DPVB,DPVD 3143 3144C...INTRINSIC FUNCTIONS 3145 INTRINSIC 3146 + ABS,SIGN 3147 3148C...DATA STATEMENTS 3149 DATA 3150 + P01,ONE,TWO,TEN 3151 + /0.01D0,1.0D0,2.0D0,10.0D0/ 3152 3153C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 3154C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 3155 3156C...VARIABLE DEFINITIONS (ALPHABETICALLY) 3157C BETA: THE FUNCTION PARAMETERS. 3158C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. 3159C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. 3160C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND 3161C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING 3162C CHECKED. 3163C EPSMAC: THE VALUE OF MACHINE PRECISION. 3164C ETA: THE RELATIVE NOISE IN THE MODEL 3165C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. 3166C HC: THE RELATIVE STEP SIZE FOR CENTRAL FINITE DIFFERENCES. 3167C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 3168C FIXED AT THEIR INPUT VALUES OR NOT. 3169C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 3170C FIXED AT THEIR INPUT VALUES OR NOT. 3171C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 3172C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 3173C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 3174C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. 3175C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. 3176C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 3177C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. 3178C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 3179C MSG: THE ERROR CHECKING RESULTS. 3180C N: THE NUMBER OF OBSERVATIONS. 3181C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 3182C NP: THE NUMBER OF FUNCTION PARAMETERS. 3183C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 3184C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 3185C THE DERIVATIVE IS TO BE CHECKED. 3186C ONE: THE VALUE 1.0D0. 3187C PV: THE PREDICTED VALUE OF THE MODEL FOR ROW NROW . 3188C PVMCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL 3189C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 3190C JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV. 3191C PVPCRV: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL 3192C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 3193C JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV. 3194C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL 3195C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 3196C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. 3197C P01: THE VALUE 0.01D0. 3198C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. 3199C STP: A STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. 3200C STPCRV: THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL. 3201C TEN: THE VALUE 10.0D0. 3202C TOL: THE AGREEMENT TOLERANCE. 3203C TWO: THE VALUE 2.0D0. 3204C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. 3205C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. 3206C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 3207C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. 3208C XPLUSD: THE VALUES OF X + DELTA. 3209 3210 3211C***FIRST EXECUTABLE STATEMENT DJCKC 3212 3213 3214 IF (ISWRTB) THEN 3215 3216C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT BETA 3217 3218 STPCRV = (HC*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) 3219 CALL DPVB(FCN, 3220 + N,M,NP,NQ, 3221 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3222 + NROW,J,LQ,STPCRV, 3223 + ISTOP,NFEV,PVPCRV, 3224 + WRK1,WRK2,WRK6) 3225 IF (ISTOP.NE.0) THEN 3226 RETURN 3227 END IF 3228 CALL DPVB(FCN, 3229 + N,M,NP,NQ, 3230 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3231 + NROW,J,LQ,-STPCRV, 3232 + ISTOP,NFEV,PVMCRV, 3233 + WRK1,WRK2,WRK6) 3234 IF (ISTOP.NE.0) THEN 3235 RETURN 3236 END IF 3237 ELSE 3238 3239C PERFORM CENTRAL DIFFERENCE COMPUTATIONS FOR DERIVATIVES WRT DELTA 3240 3241 STPCRV = (HC*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) - 3242 + XPLUSD(NROW,J) 3243 CALL DPVD(FCN, 3244 + N,M,NP,NQ, 3245 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3246 + NROW,J,LQ,STPCRV, 3247 + ISTOP,NFEV,PVPCRV, 3248 + WRK1,WRK2,WRK6) 3249 IF (ISTOP.NE.0) THEN 3250 RETURN 3251 END IF 3252 CALL DPVD(FCN, 3253 + N,M,NP,NQ, 3254 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3255 + NROW,J,LQ,-STPCRV, 3256 + ISTOP,NFEV,PVMCRV, 3257 + WRK1,WRK2,WRK6) 3258 IF (ISTOP.NE.0) THEN 3259 RETURN 3260 END IF 3261 END IF 3262 3263C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL 3264 3265 CURVE = ABS((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV) 3266 CURVE = CURVE + 3267 + ETA*(ABS(PVPCRV)+ABS(PVMCRV)+TWO*ABS(PV)) / (STPCRV**2) 3268 3269 3270C CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT. 3271 CALL DJCKF(FCN, 3272 + N,M,NP,NQ, 3273 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3274 + ETA,TOL,NROW,J,LQ,ISWRTB, 3275 + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, 3276 + DIFFJ,MSG,ISTOP,NFEV, 3277 + WRK1,WRK2,WRK6) 3278 IF (ISTOP.NE.0) THEN 3279 RETURN 3280 END IF 3281 IF (MSG(LQ,J).EQ.0) THEN 3282 RETURN 3283 END IF 3284 3285C CHECK IF HIGH CURVATURE COULD BE THE PROBLEM. 3286 3287 STP = TWO*MAX(TOL*ABS(D)/CURVE,EPSMAC) 3288 IF (STP.LT.ABS(TEN*STP0)) THEN 3289 STP = MIN(STP,P01*ABS(STP0)) 3290 END IF 3291 3292 3293 IF (ISWRTB) THEN 3294 3295C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA 3296 STP = (STP*SIGN(ONE,BETA(J)) + BETA(J)) - BETA(J) 3297 CALL DPVB(FCN, 3298 + N,M,NP,NQ, 3299 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3300 + NROW,J,LQ,STP, 3301 + ISTOP,NFEV,PVPSTP, 3302 + WRK1,WRK2,WRK6) 3303 IF (ISTOP.NE.0) THEN 3304 RETURN 3305 END IF 3306 ELSE 3307 3308C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA 3309 STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - 3310 + XPLUSD(NROW,J) 3311 CALL DPVD(FCN, 3312 + N,M,NP,NQ, 3313 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3314 + NROW,J,LQ,STP, 3315 + ISTOP,NFEV,PVPSTP, 3316 + WRK1,WRK2,WRK6) 3317 IF (ISTOP.NE.0) THEN 3318 RETURN 3319 END IF 3320 END IF 3321 3322C COMPUTE THE NEW NUMERICAL DERIVATIVE 3323 3324 FD = (PVPSTP-PV)/STP 3325 DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) 3326 3327C CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK 3328 IF (ABS(FD-D).LE.TOL*ABS(D)) THEN 3329 MSG(LQ,J) = 0 3330 3331C CHECK IF FINITE PRECISION MAY BE THE CULPRIT (FUDGE FACTOR = 2) 3332 ELSE IF (ABS(STP*(FD-D)).LT.TWO*ETA*(ABS(PV)+ABS(PVPSTP)) 3333 + + CURVE*(EPSMAC*TYPJ)**2) THEN 3334 MSG(LQ,J) = 5 3335 END IF 3336 3337 RETURN 3338 END 3339*DJCKF 3340 SUBROUTINE DJCKF 3341 + (FCN, 3342 + N,M,NP,NQ, 3343 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3344 + ETA,TOL,NROW,J,LQ,ISWRTB, 3345 + FD,TYPJ,PVPSTP,STP0,CURVE,PV,D, 3346 + DIFFJ,MSG,ISTOP,NFEV, 3347 + WRK1,WRK2,WRK6) 3348C***BEGIN PROLOGUE DJCKF 3349C***REFER TO DODR,DODRC 3350C***ROUTINES CALLED DPVB,DPVD 3351C***DATE WRITTEN 860529 (YYMMDD) 3352C***REVISION DATE 920619 (YYMMDD) 3353C***PURPOSE CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE 3354C CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES 3355C (ADAPTED FROM STARPAC SUBROUTINE DCKFPA) 3356C***END PROLOGUE DJCKF 3357 3358C...SCALAR ARGUMENTS 3359 DOUBLE PRECISION 3360 + CURVE,D,DIFFJ,ETA,FD,PV,PVPSTP,STP0,TOL,TYPJ 3361 INTEGER 3362 + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW 3363 LOGICAL 3364 + ISWRTB 3365 3366C...ARRAY ARGUMENTS 3367 DOUBLE PRECISION 3368 + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) 3369 INTEGER 3370 + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) 3371 3372C...SUBROUTINE ARGUMENTS 3373 EXTERNAL 3374 + FCN 3375 3376C...LOCAL SCALARS 3377 DOUBLE PRECISION 3378 + HUNDRD,ONE,P1,STP,TWO 3379 LOGICAL 3380 + LARGE 3381 3382C...EXTERNAL SUBROUTINES 3383 EXTERNAL 3384 + DPVB,DPVD 3385 3386C...INTRINSIC FUNCTIONS 3387 INTRINSIC 3388 + ABS,SIGN 3389 3390C...DATA STATEMENTS 3391 DATA 3392 + P1,ONE,TWO,HUNDRD 3393 + /0.1D0,1.0D0,2.0D0,100.0D0/ 3394 3395C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 3396C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 3397 3398C...VARIABLE DEFINITIONS (ALPHABETICALLY) 3399C BETA: THE FUNCTION PARAMETERS. 3400C CURVE: A MEASURE OF THE CURVATURE IN THE MODEL. 3401C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. 3402C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND 3403C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING 3404C CHECKED. 3405C ETA: THE RELATIVE NOISE IN THE MODEL 3406C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. 3407C HUNDRD: THE VALUE 100.0D0. 3408C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 3409C FIXED AT THEIR INPUT VALUES OR NOT. 3410C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 3411C FIXED AT THEIR INPUT VALUES OR NOT. 3412C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 3413C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 3414C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 3415C (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. 3416C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. 3417C LARGE: THE VALUE DESIGNATING WHETHER THE RECOMMENDED INCREASE IN 3418C THE STEP SIZE WOULD BE GREATER THAN TYPJ. 3419C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 3420C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. 3421C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 3422C MSG: THE ERROR CHECKING RESULTS. 3423C N: THE NUMBER OF OBSERVATIONS. 3424C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 3425C NP: THE NUMBER OF FUNCTION PARAMETERS. 3426C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 3427C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 3428C THE DERIVATIVE IS TO BE CHECKED. 3429C ONE: THE VALUE 1.0D0. 3430C PV: THE PREDICTED VALUE FOR ROW NROW . 3431C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL 3432C BASED ON THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 3433C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. 3434C P1: THE VALUE 0.1D0. 3435C STP0: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. 3436C TOL: THE AGREEMENT TOLERANCE. 3437C TWO: THE VALUE 2.0D0. 3438C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. 3439C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. 3440C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 3441C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. 3442C XPLUSD: THE VALUES OF X + DELTA. 3443 3444 3445C***FIRST EXECUTABLE STATEMENT DJCKF 3446 3447 3448C FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM. 3449C TRY A LARGER STEP SIZE BASED ON ESTIMATE OF CONDITION ERROR 3450 3451 STP = ETA*(ABS(PV)+ABS(PVPSTP))/(TOL*ABS(D)) 3452 IF (STP.GT.ABS(P1*STP0)) THEN 3453 STP = MAX(STP,HUNDRD*ABS(STP0)) 3454 END IF 3455 IF (STP.GT.TYPJ) THEN 3456 STP = TYPJ 3457 LARGE = .TRUE. 3458 ELSE 3459 LARGE = .FALSE. 3460 END IF 3461 3462 IF (ISWRTB) THEN 3463 3464C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA 3465 STP = (STP*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) 3466 CALL DPVB(FCN, 3467 + N,M,NP,NQ, 3468 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3469 + NROW,J,LQ,STP, 3470 + ISTOP,NFEV,PVPSTP, 3471 + WRK1,WRK2,WRK6) 3472 ELSE 3473 3474C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA 3475 STP = (STP*SIGN(ONE,XPLUSD(NROW,J)) + XPLUSD(NROW,J)) - 3476 + XPLUSD(NROW,J) 3477 CALL DPVD(FCN, 3478 + N,M,NP,NQ, 3479 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3480 + NROW,J,LQ,STP, 3481 + ISTOP,NFEV,PVPSTP, 3482 + WRK1,WRK2,WRK6) 3483 END IF 3484 IF (ISTOP.NE.0) THEN 3485 RETURN 3486 END IF 3487 3488 FD = (PVPSTP-PV)/STP 3489 DIFFJ = MIN(DIFFJ,ABS(FD-D)/ABS(D)) 3490 3491C CHECK FOR AGREEMENT 3492 3493 IF ((ABS(FD-D)).LE.TOL*ABS(D)) THEN 3494C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES AGREE. 3495 MSG(LQ,J) = 0 3496 3497 ELSE IF ((ABS(FD-D).LE.ABS(TWO*CURVE*STP)) .OR. LARGE) THEN 3498C CURVATURE MAY BE THE CULPRIT (FUDGE FACTOR = 2) 3499 IF (LARGE) THEN 3500 MSG(LQ,J) = 4 3501 ELSE 3502 MSG(LQ,J) = 5 3503 END IF 3504 END IF 3505 3506 RETURN 3507 END 3508*DJCKM 3509 SUBROUTINE DJCKM 3510 + (FCN, 3511 + N,M,NP,NQ, 3512 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3513 + ETA,TOL,NROW,EPSMAC,J,LQ,TYPJ,H0,HC0, 3514 + ISWRTB,PV,D, 3515 + DIFFJ,MSG1,MSG,ISTOP,NFEV, 3516 + WRK1,WRK2,WRK6) 3517C***BEGIN PROLOGUE DJCKM 3518C***REFER TO DODR,DODRC 3519C***ROUTINES CALLED DJCKC,DJCKZ,DPVB,DPVD 3520C***DATE WRITTEN 860529 (YYMMDD) 3521C***REVISION DATE 920619 (YYMMDD) 3522C***PURPOSE CHECK USER SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL 3523C DERIVATIVES 3524C (ADAPTED FROM STARPAC SUBROUTINE DCKMN) 3525C***END PROLOGUE DJCKM 3526 3527C...SCALAR ARGUMENTS 3528 DOUBLE PRECISION 3529 + D,DIFFJ,EPSMAC,ETA,H0,HC0,PV,TOL,TYPJ 3530 INTEGER 3531 + ISTOP,J,LDIFX,LQ,M,MSG1,N,NFEV,NP,NQ,NROW 3532 LOGICAL 3533 + ISWRTB 3534 3535C...ARRAY ARGUMENTS 3536 DOUBLE PRECISION 3537 + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) 3538 INTEGER 3539 + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) 3540 3541C...SUBROUTINE ARGUMENTS 3542 EXTERNAL 3543 + FCN 3544 3545C...LOCAL SCALARS 3546 DOUBLE PRECISION 3547 + BIG,FD,H,HC,H1,HC1,HUNDRD,ONE,PVPSTP,P01,P1,STP0, 3548 + TEN,THREE,TOL2,TWO,ZERO 3549 INTEGER 3550 + I 3551 3552C...EXTERNAL SUBROUTINES 3553 EXTERNAL 3554 + DJCKC,DJCKZ,DPVB,DPVD 3555 3556C...INTRINSIC FUNCTIONS 3557 INTRINSIC 3558 + ABS,MAX,SIGN,SQRT 3559 3560C...DATA STATEMENTS 3561 DATA 3562 + ZERO,P01,P1,ONE,TWO,THREE,TEN,HUNDRD 3563 + /0.0D0,0.01D0,0.1D0,1.0D0,2.0D0,3.0D0,1.0D1,1.0D2/ 3564 DATA 3565 + BIG,TOL2 3566 + /1.0D19,5.0D-2/ 3567 3568C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 3569C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 3570 3571C...VARIABLE DEFINITIONS (ALPHABETICALLY) 3572C BETA: THE FUNCTION PARAMETERS. 3573C BIG: A BIG VALUE, USED TO INITIALIZE DIFFJ. 3574C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. 3575C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND 3576C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING 3577C CHECKED. 3578C EPSMAC: THE VALUE OF MACHINE PRECISION. 3579C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. 3580C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. 3581C H: THE RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. 3582C H0: THE INITIAL RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. 3583C H1: THE DEFAULT RELATIVE STEP SIZE FOR FORWARD DIFFERENCES. 3584C HC: THE RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. 3585C HC0: THE INITIAL RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. 3586C HC1: THE DEFAULT RELATIVE STEP SIZE FOR CENTRAL DIFFERENCES. 3587C HUNDRD: THE VALUE 100.0D0. 3588C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 3589C FIXED AT THEIR INPUT VALUES OR NOT. 3590C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 3591C FIXED AT THEIR INPUT VALUES OR NOT. 3592C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 3593C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 3594C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 3595C (ISWRTB=TRUE) OR DELTAS (ISWRTB=FALSE) ARE BEING CHECKED. 3596C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. 3597C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 3598C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. 3599C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 3600C MSG: THE ERROR CHECKING RESULTS. 3601C MSG1: THE ERROR CHECKING RESULTS SUMMARY. 3602C N: THE NUMBER OF OBSERVATIONS. 3603C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 3604C NP: THE NUMBER OF FUNCTION PARAMETERS. 3605C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 3606C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 3607C THE DERIVATIVE IS TO BE CHECKED. 3608C ONE: THE VALUE 1.0D0. 3609C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . 3610C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL 3611C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE JTH 3612C PARAMETER VALUE, WHICH IS BETA(J) + STP0. 3613C P01: THE VALUE 0.01D0. 3614C P1: THE VALUE 0.1D0. 3615C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. 3616C TEN: THE VALUE 10.0D0. 3617C THREE: THE VALUE 3.0D0. 3618C TWO: THE VALUE 2.0D0. 3619C TOL: THE AGREEMENT TOLERANCE. 3620C TOL2: A MINIMUM AGREEMENT TOLERANCE. 3621C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. 3622C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. 3623C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 3624C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. 3625C XPLUSD: THE VALUES OF X + DELTA. 3626C ZERO: THE VALUE 0.0D0. 3627 3628 3629C***FIRST EXECUTABLE STATEMENT DJCKM 3630 3631 3632C CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE 3633C QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES 3634 3635 H1 = SQRT(ETA) 3636 HC1 = ETA**(ONE/THREE) 3637 3638 MSG(LQ,J) = 7 3639 DIFFJ = BIG 3640 3641 DO 10 I=1,3 3642 3643 IF (I.EQ.1) THEN 3644C TRY INITIAL RELATIVE STEP SIZE 3645 H = H0 3646 HC = HC0 3647 3648 ELSE IF (I.EQ.2) THEN 3649C TRY LARGER RELATIVE STEP SIZE 3650 H = MAX(TEN*H1, MIN(HUNDRD*H0, ONE)) 3651 HC = MAX(TEN*HC1,MIN(HUNDRD*HC0,ONE)) 3652 3653 ELSE IF (I.EQ.3) THEN 3654C TRY SMALLER RELATIVE STEP SIZE 3655 H = MIN(P1*H1, MAX(P01*H,TWO*EPSMAC)) 3656 HC = MIN(P1*HC1,MAX(P01*HC,TWO*EPSMAC)) 3657 END IF 3658 3659 IF (ISWRTB) THEN 3660 3661C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA 3662 3663 STP0 = (H*TYPJ*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) 3664 CALL DPVB(FCN, 3665 + N,M,NP,NQ, 3666 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3667 + NROW,J,LQ,STP0, 3668 + ISTOP,NFEV,PVPSTP, 3669 + WRK1,WRK2,WRK6) 3670 ELSE 3671 3672C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA 3673 3674 STP0 = (H*TYPJ*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) 3675 + - XPLUSD(NROW,J) 3676 CALL DPVD(FCN, 3677 + N,M,NP,NQ, 3678 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3679 + NROW,J,LQ,STP0, 3680 + ISTOP,NFEV,PVPSTP, 3681 + WRK1,WRK2,WRK6) 3682 END IF 3683 IF (ISTOP.NE.0) THEN 3684 RETURN 3685 END IF 3686 3687 FD = (PVPSTP-PV)/STP0 3688 3689C CHECK FOR AGREEMENT 3690 3691 IF (ABS(FD-D).LE.TOL*ABS(D)) THEN 3692C NUMERICAL AND ANALYTIC DERIVATIVES AGREE 3693 3694C SET RELATIVE DIFFERENCE FOR DERIVATIVE CHECKING REPORT 3695 IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN 3696 DIFFJ = ABS(FD-D) 3697 ELSE 3698 DIFFJ = ABS(FD-D)/ABS(D) 3699 END IF 3700 3701C SET MSG FLAG. 3702 IF (D.EQ.ZERO) THEN 3703 3704C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH ZERO. 3705 MSG(LQ,J) = 1 3706 3707 ELSE 3708C JTH ANALYTIC AND NUMERICAL DERIVATIVES ARE BOTH NONZERO. 3709 MSG(LQ,J) = 0 3710 END IF 3711 3712 ELSE 3713 3714C NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE. CHECK WHY 3715 IF ((D.EQ.ZERO) .OR. (FD.EQ.ZERO)) THEN 3716 CALL DJCKZ(FCN, 3717 + N,M,NP,NQ, 3718 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3719 + NROW,EPSMAC,J,LQ,ISWRTB, 3720 + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, 3721 + DIFFJ,MSG,ISTOP,NFEV, 3722 + WRK1,WRK2,WRK6) 3723 ELSE 3724 CALL DJCKC(FCN, 3725 + N,M,NP,NQ, 3726 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3727 + ETA,TOL,NROW,EPSMAC,J,LQ,HC,ISWRTB, 3728 + FD,TYPJ,PVPSTP,STP0,PV,D, 3729 + DIFFJ,MSG,ISTOP,NFEV, 3730 + WRK1,WRK2,WRK6) 3731 END IF 3732 IF (MSG(LQ,J).LE.2) THEN 3733 GO TO 20 3734 END IF 3735 END IF 3736 10 CONTINUE 3737 3738C SET SUMMARY FLAG TO INDICATE QUESTIONABLE RESULTS 3739 20 CONTINUE 3740 IF ((MSG(LQ,J).GE.7) .AND. (DIFFJ.LE.TOL2)) MSG(LQ,J) = 6 3741 IF ((MSG(LQ,J).GE.1) .AND. (MSG(LQ,J).LE.6)) THEN 3742 MSG1 = MAX(MSG1,1) 3743 ELSE IF (MSG(LQ,J).GE.7) THEN 3744 MSG1 = 2 3745 END IF 3746 3747 RETURN 3748 END 3749*DJCKZ 3750 SUBROUTINE DJCKZ 3751 + (FCN, 3752 + N,M,NP,NQ, 3753 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3754 + NROW,EPSMAC,J,LQ,ISWRTB, 3755 + TOL,D,FD,TYPJ,PVPSTP,STP0,PV, 3756 + DIFFJ,MSG,ISTOP,NFEV, 3757 + WRK1,WRK2,WRK6) 3758C***BEGIN PROLOGUE DJCKZ 3759C***REFER TO DODR,DODRC 3760C***ROUTINES CALLED DPVB,DPVD 3761C***DATE WRITTEN 860529 (YYMMDD) 3762C***REVISION DATE 920619 (YYMMDD) 3763C***PURPOSE RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE 3764C DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC 3765C DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO 3766C (ADAPTED FROM STARPAC SUBROUTINE DCKZRO) 3767C***END PROLOGUE DJCKZ 3768 3769C...SCALAR ARGUMENTS 3770 DOUBLE PRECISION 3771 + D,DIFFJ,EPSMAC,FD,PV,PVPSTP,STP0,TOL,TYPJ 3772 INTEGER 3773 + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW 3774 LOGICAL 3775 + ISWRTB 3776 3777C...ARRAY ARGUMENTS 3778 DOUBLE PRECISION 3779 + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) 3780 INTEGER 3781 + IFIXB(NP),IFIXX(LDIFX,M),MSG(NQ,J) 3782 3783C...SUBROUTINE ARGUMENTS 3784 EXTERNAL 3785 + FCN 3786 3787C...LOCAL SCALARS 3788 DOUBLE PRECISION 3789 + CD,ONE,PVMSTP,THREE,TWO,ZERO 3790 3791C...EXTERNAL SUBROUTINES 3792 EXTERNAL 3793 + DPVB,DPVD 3794 3795C...INTRINSIC FUNCTIONS 3796 INTRINSIC 3797 + ABS,MIN 3798 3799C...DATA STATEMENTS 3800 DATA 3801 + ZERO,ONE,TWO,THREE 3802 + /0.0D0,1.0D0,2.0D0,3.0D0/ 3803 3804C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 3805C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 3806 3807C...VARIABLE DEFINITIONS (ALPHABETICALLY) 3808C BETA: THE FUNCTION PARAMETERS. 3809C CD: THE CENTRAL DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. 3810C D: THE DERIVATIVE WITH RESPECT TO THE JTH UNKNOWN PARAMETER. 3811C DIFFJ: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND 3812C FINITE DIFFERENCE DERIVATIVES FOR THE DERIVATIVE BEING 3813C CHECKED. 3814C EPSMAC: THE VALUE OF MACHINE PRECISION. 3815C FD: THE FORWARD DIFFERENCE DERIVATIVE WRT THE JTH PARAMETER. 3816C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 3817C FIXED AT THEIR INPUT VALUES OR NOT. 3818C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 3819C FIXED AT THEIR INPUT VALUES OR NOT. 3820C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 3821C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 3822C ISWRTB: THE VARIABLE DESIGNATING WHETHER THE DERIVATIVES WRT BETA 3823C (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED. 3824C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. 3825C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 3826C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. 3827C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 3828C MSG: THE ERROR CHECKING RESULTS. 3829C N: THE NUMBER OF OBSERVATIONS. 3830C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 3831C NP: THE NUMBER OF FUNCTION PARAMETERS. 3832C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 3833C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT WHICH 3834C THE DERIVATIVE IS TO BE CHECKED. 3835C ONE: THE VALUE 1.0D0. 3836C PV: THE PREDICTED VALUE FROM THE MODEL FOR ROW NROW . 3837C PVMSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL 3838C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 3839C JTH PARAMETER VALUE, WHICH IS BETA(J) - STP0. 3840C PVPSTP: THE PREDICTED VALUE FOR ROW NROW OF THE MODEL 3841C USING THE CURRENT PARAMETER ESTIMATES FOR ALL BUT THE 3842C JTH PARAMETER VALUE, WHICH IS BETA(J) + STP0. 3843C STP0: THE INITIAL STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. 3844C THREE: THE VALUE 3.0D0. 3845C TWO: THE VALUE 2.0D0. 3846C TOL: THE AGREEMENT TOLERANCE. 3847C TYPJ: THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. 3848C WRK1: A WORK ARRAY OF (N BY M BY NQ) ELEMENTS. 3849C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 3850C WRK6: A WORK ARRAY OF (N BY NP BY NQ) ELEMENTS. 3851C XPLUSD: THE VALUES OF X + DELTA. 3852C ZERO: THE VALUE 0.0D0. 3853 3854 3855C***FIRST EXECUTABLE STATEMENT DJCKZ 3856 3857 3858C RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP 3859C SIZE OF 2*STP0 3860 3861 IF (ISWRTB) THEN 3862 3863C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA 3864 3865 CALL DPVB(FCN, 3866 + N,M,NP,NQ, 3867 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3868 + NROW,J,LQ,-STP0, 3869 + ISTOP,NFEV,PVMSTP, 3870 + WRK1,WRK2,WRK6) 3871 ELSE 3872 3873C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA 3874 3875 CALL DPVD(FCN, 3876 + N,M,NP,NQ, 3877 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 3878 + NROW,J,LQ,-STP0, 3879 + ISTOP,NFEV,PVMSTP, 3880 + WRK1,WRK2,WRK6) 3881 END IF 3882 IF (ISTOP.NE.0) THEN 3883 RETURN 3884 END IF 3885 3886 CD = (PVPSTP-PVMSTP)/(TWO*STP0) 3887 DIFFJ = MIN(ABS(CD-D),ABS(FD-D)) 3888 3889C CHECK FOR AGREEMENT 3890 3891 IF (DIFFJ.LE.TOL*ABS(D)) THEN 3892 3893C FINITE DIFFERENCE AND ANALYTIC DERIVATIVES NOW AGREE. 3894 IF (D.EQ.ZERO) THEN 3895 MSG(LQ,J) = 1 3896 ELSE 3897 MSG(LQ,J) = 0 3898 END IF 3899 3900 ELSE IF (DIFFJ*TYPJ.LE.ABS(PV*EPSMAC**(ONE/THREE))) THEN 3901C DERIVATIVES ARE BOTH CLOSE TO ZERO 3902 MSG(LQ,J) = 2 3903 3904 ELSE 3905C DERIVATIVES ARE NOT BOTH CLOSE TO ZERO 3906 MSG(LQ,J) = 3 3907 END IF 3908 3909 RETURN 3910 END 3911*DODCHK 3912 SUBROUTINE DODCHK 3913 + (N,M,NP,NQ, 3914 + ISODR,ANAJAC,IMPLCT, 3915 + IFIXB, 3916 + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, 3917 + LDY, 3918 + LWORK,LWKMN,LIWORK,LIWKMN, 3919 + SCLB,SCLD,STPB,STPD, 3920 + INFO) 3921C***BEGIN PROLOGUE DODCHK 3922C***REFER TO DODR,DODRC 3923C***ROUTINES CALLED (NONE) 3924C***DATE WRITTEN 860529 (YYMMDD) 3925C***REVISION DATE 920619 (YYMMDD) 3926C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING 3927C NONZERO VALUES OF ARGUMENT INFO 3928C***END PROLOGUE DODCHK 3929 3930C...SCALAR ARGUMENTS 3931 INTEGER 3932 + INFO,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, 3933 + LIWKMN,LIWORK,LWKMN,LWORK,M,N,NP,NQ 3934 LOGICAL 3935 + ANAJAC,IMPLCT,ISODR 3936 3937C...ARRAY ARGUMENTS 3938 DOUBLE PRECISION 3939 + SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M) 3940 INTEGER 3941 + IFIXB(NP) 3942 3943C...LOCAL SCALARS 3944 INTEGER 3945 + I,J,K,LAST,NPP 3946 3947C...VARIABLE DEFINITIONS (ALPHABETICALLY) 3948C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 3949C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT 3950C (ANAJAC=TRUE). 3951C I: AN INDEXING VARIABLE. 3952C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 3953C FIXED AT THEIR INPUT VALUES OR NOT. 3954C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 3955C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 3956C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 3957C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 3958C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 3959C J: AN INDEXING VARIABLE. 3960C K: AN INDEXING VARIABLE. 3961C LAST: THE LAST ROW OF THE ARRAY TO BE ACCESSED. 3962C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 3963C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. 3964C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 3965C LDWD: THE LEADING DIMENSION OF ARRAY WD. 3966C LDWE: THE LEADING DIMENSION OF ARRAY WE. 3967C LDX: THE LEADING DIMENSION OF ARRAY X. 3968C LDY: THE LEADING DIMENSION OF ARRAY X. 3969C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 3970C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 3971C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. 3972C LIWORK: THE LENGTH OF VECTOR IWORK. 3973C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. 3974C LWORK: THE LENGTH OF VECTOR WORK. 3975C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 3976C N: THE NUMBER OF OBSERVATIONS. 3977C NP: THE NUMBER OF FUNCTION PARAMETERS. 3978C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. 3979C NQ: THE NUMBER OF RESPONSES PER OBSERVATIONS. 3980C SCLB: THE SCALING VALUES FOR BETA. 3981C SCLD: THE SCALING VALUE FOR DELTA. 3982C STPB: THE STEP FOR THE FINITE DIFFERENCE DERIVATIVE WRT BETA. 3983C STPD: THE STEP FOR THE FINITE DIFFERENCE DERIVATIVE WRT DELTA. 3984 3985 3986C***FIRST EXECUTABLE STATEMENT DODCHK 3987 3988 3989C FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED 3990 3991 IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN 3992 NPP = NP 3993 ELSE 3994 NPP = 0 3995 DO 10 K=1,NP 3996 IF (IFIXB(K).NE.0) THEN 3997 NPP = NPP + 1 3998 END IF 3999 10 CONTINUE 4000 END IF 4001 4002C CHECK PROBLEM SPECIFICATION PARAMETERS 4003 4004 IF (N.LE.0 .OR. 4005 + M.LE.0 .OR. 4006 + (NPP.LE.0 .OR. NPP.GT.N) .OR. 4007 + (NQ.LE.0)) THEN 4008 4009 INFO = 10000 4010 IF (N.LE.0) THEN 4011 INFO = INFO + 1000 4012 END IF 4013 IF (M.LE.0) THEN 4014 INFO = INFO + 100 4015 END IF 4016 IF (NPP.LE.0 .OR. NPP.GT.N) THEN 4017 INFO = INFO + 10 4018 END IF 4019 IF (NQ.LE.0) THEN 4020 INFO = INFO + 1 4021 END IF 4022 4023 RETURN 4024 4025 END IF 4026 4027C CHECK DIMENSION SPECIFICATION PARAMETERS 4028 4029 IF ((.NOT.IMPLCT .AND. LDY.LT.N) .OR. 4030 + (LDX.LT.N) .OR. 4031 + (LDWE.NE.1 .AND. LDWE.LT.N) .OR. 4032 + (LD2WE.NE.1 .AND. LD2WE.LT.NQ) .OR. 4033 + (ISODR .AND. (LDWD.NE.1 .AND. LDWD.LT.N)) .OR. 4034 + (ISODR .AND. (LD2WD.NE.1 .AND. LD2WD.LT.M)) .OR. 4035 + (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) .OR. 4036 + (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) .OR. 4037 + (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) .OR. 4038 + (LWORK.LT.LWKMN) .OR. 4039 + (LIWORK.LT.LIWKMN)) THEN 4040 4041 INFO = 20000 4042 IF (.NOT.IMPLCT .AND. LDY.LT.N) THEN 4043 INFO = INFO + 1000 4044 END IF 4045 IF (LDX.LT.N) THEN 4046 INFO = INFO + 2000 4047 END IF 4048 4049 IF ((LDWE.NE.1 .AND. LDWE.LT.N) .OR. 4050 + (LD2WE.NE.1 .AND. LD2WE.LT.NQ)) THEN 4051 INFO = INFO + 100 4052 END IF 4053 IF (ISODR .AND. ((LDWD.NE.1 .AND. LDWD.LT.N) .OR. 4054 + (LD2WD.NE.1 .AND. LD2WD.LT.M))) THEN 4055 INFO = INFO + 200 4056 END IF 4057 4058 IF (ISODR .AND. (LDIFX.NE.1 .AND. LDIFX.LT.N)) THEN 4059 INFO = INFO + 10 4060 END IF 4061 IF (ISODR .AND. (LDSTPD.NE.1 .AND. LDSTPD.LT.N)) THEN 4062 INFO = INFO + 20 4063 END IF 4064 IF (ISODR .AND. (LDSCLD.NE.1 .AND. LDSCLD.LT.N)) THEN 4065 INFO = INFO + 40 4066 END IF 4067 4068 IF (LWORK.LT.LWKMN) THEN 4069 INFO = INFO + 1 4070 END IF 4071 IF (LIWORK.LT.LIWKMN) THEN 4072 INFO = INFO + 2 4073 END IF 4074 RETURN 4075 4076 END IF 4077 4078C CHECK DELTA SCALING 4079 4080 IF (ISODR .AND. SCLD(1,1).GT.0) THEN 4081 IF (LDSCLD.GE.N) THEN 4082 LAST = N 4083 ELSE 4084 LAST = 1 4085 END IF 4086 DO 120 J=1,M 4087 DO 110 I=1,LAST 4088 IF (SCLD(I,J).LE.0) THEN 4089 INFO = 30200 4090 GO TO 130 4091 END IF 4092 110 CONTINUE 4093 120 CONTINUE 4094 END IF 4095 130 CONTINUE 4096 4097C CHECK BETA SCALING 4098 4099 IF (SCLB(1).GT.0) THEN 4100 DO 210 K=1,NP 4101 IF (SCLB(K).LE.0) THEN 4102 IF (INFO.EQ.0) THEN 4103 INFO = 30100 4104 ELSE 4105 INFO = INFO + 100 4106 END IF 4107 GO TO 220 4108 END IF 4109 210 CONTINUE 4110 END IF 4111 220 CONTINUE 4112 4113C CHECK DELTA FINITE DIFFERENCE STEP SIZES 4114 4115 IF (ANAJAC .AND. ISODR .AND. STPD(1,1).GT.0) THEN 4116 IF (LDSTPD.GE.N) THEN 4117 LAST = N 4118 ELSE 4119 LAST = 1 4120 END IF 4121 DO 320 J=1,M 4122 DO 310 I=1,LAST 4123 IF (STPD(I,J).LE.0) THEN 4124 IF (INFO.EQ.0) THEN 4125 INFO = 32000 4126 ELSE 4127 INFO = INFO + 2000 4128 END IF 4129 GO TO 330 4130 END IF 4131 310 CONTINUE 4132 320 CONTINUE 4133 END IF 4134 330 CONTINUE 4135 4136C CHECK BETA FINITE DIFFERENCE STEP SIZES 4137 4138 IF (ANAJAC .AND. STPB(1).GT.0) THEN 4139 DO 410 K=1,NP 4140 IF (STPB(K).LE.0) THEN 4141 IF (INFO.EQ.0) THEN 4142 INFO = 31000 4143 ELSE 4144 INFO = INFO + 1000 4145 END IF 4146 GO TO 420 4147 END IF 4148 410 CONTINUE 4149 END IF 4150 420 CONTINUE 4151 4152 RETURN 4153 END 4154*DODCNT 4155 SUBROUTINE DODCNT 4156 + (SHORT, FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, 4157 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, 4158 + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, IPRINT,LUNERR,LUNRPT, 4159 + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, 4160 + WORK,LWORK,IWORK,LIWORK, 4161 + INFO) 4162C***BEGIN PROLOGUE DODCNT 4163C***REFER TO DODR,DODRC 4164C***ROUTINES CALLED DODDRV 4165C***DATE WRITTEN 860529 (YYMMDD) 4166C***REVISION DATE 920304 (YYMMDD) 4167C***PURPOSE DOUBLE PRECISION DRIVER ROUTINE FOR FINDING 4168C THE WEIGHTED EXPLICIT OR IMPLICIT ORTHOGONAL DISTANCE 4169C REGRESSION (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST 4170C SQUARES (OLS) SOLUTION 4171C***END PROLOGUE DODCNT 4172 4173C...SCALAR ARGUMENTS 4174 DOUBLE PRECISION 4175 + PARTOL,SSTOL,TAUFAC 4176 INTEGER 4177 + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, 4178 + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP,NQ 4179 LOGICAL 4180 + SHORT 4181 4182C...ARRAY ARGUMENTS 4183 DOUBLE PRECISION 4184 + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), 4185 + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WORK(LWORK), 4186 + X(LDX,M),Y(LDY,NQ) 4187 INTEGER 4188 + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) 4189 4190C...SUBROUTINE ARGUMENTS 4191 EXTERNAL 4192 + FCN 4193 4194C...LOCAL SCALARS 4195 DOUBLE PRECISION 4196 + CNVTOL,ONE,PCHECK,PFAC,PSTART,THREE,TSTIMP,ZERO 4197 INTEGER 4198 + IPRNTI,IPR1,IPR2,IPR2F,IPR3,JOBI,JOB1,JOB2,JOB3,JOB4,JOB5, 4199 + MAXITI,MAXIT1 4200 LOGICAL 4201 + DONE,FSTITR,HEAD,IMPLCT,PRTPEN 4202 4203C...LOCAL ARRAYS 4204 DOUBLE PRECISION 4205 + PNLTY(1,1,1) 4206 4207C...EXTERNAL SUBROUTINES 4208 EXTERNAL 4209 + DODDRV 4210 4211C...EXTERNAL FUNCTIONS 4212 DOUBLE PRECISION 4213 + DMPREC 4214 EXTERNAL 4215 + DMPREC 4216 4217C...DATA STATEMENTS 4218 DATA 4219 + PCHECK,PSTART,PFAC,ZERO,ONE,THREE 4220 + /1.0D3,1.0D1,1.0D1,0.0D0,1.0D0,3.0D0/ 4221 4222C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 4223C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 4224 4225C...VARIABLE DEFINITIONS (ALPHABETICALLY) 4226C BETA: THE FUNCTION PARAMETERS. 4227C CNVTOL: THE CONVERGENCE TOLERANCE FOR IMPLICIT MODELS. 4228C DONE: THE VARIABLE DESIGNATING WHETHER THE INPLICIT SOLUTION HAS 4229C BEEN FOUND (DONE=TRUE) OR NOT (DONE=FALSE). 4230C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 4231C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). 4232C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 4233C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). 4234C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 4235C FIXED AT THEIR INPUT VALUES OR NOT. 4236C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 4237C FIXED AT THEIR INPUT VALUES OR NOT. 4238C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 4239C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 4240C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 4241C IPRINT: THE PRINT CONTROL VARIABLES. 4242C IPRNTI: THE PRINT CONTROL VARIABLES. 4243C IPR1: THE 1ST DIGIT OF THE PRINT CONTROL VARIABLE. 4244C IPR2: THE 2ND DIGIT OF THE PRINT CONTROL VARIABLE. 4245C IPR3: THE 3RD DIGIT OF THE PRINT CONTROL VARIABLE. 4246C IPR4: THE 4TH DIGIT OF THE PRINT CONTROL VARIABLE. 4247C IWORK: THE INTEGER WORK SPACE. 4248C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 4249C COMPUTATIONAL METHOD. 4250C JOBI: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 4251C COMPUTATIONAL METHOD. 4252C JOB1: THE 1ST DIGIT OF THE VARIABLE CONTROLLING PROBLEM 4253C INITIALIZATION AND COMPUTATIONAL METHOD. 4254C JOB2: THE 2ND DIGIT OF THE VARIABLE CONTROLLING PROBLEM 4255C INITIALIZATION AND COMPUTATIONAL METHOD. 4256C JOB3: THE 3RD DIGIT OF THE VARIABLE CONTROLLING PROBLEM 4257C INITIALIZATION AND COMPUTATIONAL METHOD. 4258C JOB4: THE 4TH DIGIT OF THE VARIABLE CONTROLLING PROBLEM 4259C INITIALIZATION AND COMPUTATIONAL METHOD. 4260C JOB5: THE 5TH DIGIT OF THE VARIABLE CONTROLLING PROBLEM 4261C INITIALIZATION AND COMPUTATIONAL METHOD. 4262C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 4263C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. 4264C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 4265C LDWD: THE LEADING DIMENSION OF ARRAY WD. 4266C LDWE: THE LEADING DIMENSION OF ARRAY WE. 4267C LDX: THE LEADING DIMENSION OF ARRAY X. 4268C LDY: THE LEADING DIMENSION OF ARRAY Y. 4269C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 4270C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 4271C LIWORK: THE LENGTH OF VECTOR IWORK. 4272C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. 4273C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. 4274C LWORK: THE LENGTH OF VECTOR WORK. 4275C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. 4276C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 4277C MAXITI: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR 4278C THE CURRENT PENALTY PARAMETER VALUE. 4279C MAXIT1: FOR IMPLICIT MODELS, THE NUMBER OF ITERATIONS ALLOWED FOR 4280C THE NEXT PENALTY PARAMETER VALUE. 4281C N: THE NUMBER OF OBSERVATIONS. 4282C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS 4283C SUPPLIED BY THE USER. 4284C NP: THE NUMBER OF FUNCTION PARAMETERS. 4285C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 4286C ONE: THE VALUE 1.0D0. 4287C PARTOL: THE USER SUPPLIED PARAMETER CONVERGENCE STOPPING TOLERANCE. 4288C PCHECK: THE VALUE DESIGNATING THE MINIMUM PENALTY PARAMETER ALLOWED 4289C BEFORE THE IMPLICIT PROBLEM CAN BE CONSIDERED SOLVED. 4290C PFAC: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. 4291C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. 4292C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO BE 4293C PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 4294C (PRTPEN=FALSE). 4295C PSTART: THE FACTOR FOR INCREASING THE PENALTY PARAMETER. 4296C SCLB: THE SCALING VALUES FOR BETA. 4297C SCLD: THE SCALING VALUES FOR DELTA. 4298C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 4299C DERIVATIVES WITH RESPECT TO BETA. 4300C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 4301C DERIVATIVES WITH RESPECT TO DELTA. 4302C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 4303C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL 4304C (SHORT=.FALSE.). 4305C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. 4306C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 4307C DIAMETER. 4308C THREE: THE VALUE 3.0D0. 4309C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL 4310C VALUES AND THE SOLUTION. 4311C WD: THE DELTA WEIGHTS. 4312C WE: THE EPSILON WEIGHTS. 4313C WORK: THE DOUBLE PRECISION WORK SPACE. 4314C X: THE INDEPENDENT VARIABLE. 4315C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. 4316C ZERO: THE VALUE 0.0D0. 4317 4318 4319C***FIRST EXECUTABLE STATEMENT DODCNT 4320 4321 4322 IMPLCT = MOD(JOB,10).EQ.1 4323 FSTITR = .TRUE. 4324 HEAD = .TRUE. 4325 PRTPEN = .FALSE. 4326 4327 IF (IMPLCT) THEN 4328 4329C SET UP FOR IMPLICIT PROBLEM 4330 4331 IF (IPRINT.GE.0) THEN 4332 IPR1 = MOD(IPRINT,10000)/1000 4333 IPR2 = MOD(IPRINT,1000)/100 4334 IPR2F = MOD(IPRINT,100)/10 4335 IPR3 = MOD(IPRINT,10) 4336 ELSE 4337 IPR1 = 2 4338 IPR2 = 0 4339 IPR2F = 0 4340 IPR3 = 1 4341 END IF 4342 IPRNTI = IPR1*1000 + IPR2*100 + IPR2F*10 4343 4344 JOB5 = MOD(JOB,100000)/10000 4345 JOB4 = MOD(JOB,10000)/1000 4346 JOB3 = MOD(JOB,1000)/100 4347 JOB2 = MOD(JOB,100)/10 4348 JOB1 = MOD(JOB,10) 4349 JOBI = JOB5*10000 + JOB4*1000 + JOB3*100 + JOB2*10 + JOB1 4350 4351 IF (WE(1,1,1).LE.ZERO) THEN 4352 PNLTY(1,1,1) = -PSTART 4353 ELSE 4354 PNLTY(1,1,1) = -WE(1,1,1) 4355 END IF 4356 4357 IF (PARTOL.LT.ZERO) THEN 4358 CNVTOL = DMPREC()**(ONE/THREE) 4359 ELSE 4360 CNVTOL = MIN(PARTOL,ONE) 4361 END IF 4362 4363 IF (MAXIT.GE.1) THEN 4364 MAXITI = MAXIT 4365 ELSE 4366 MAXITI = 100 4367 END IF 4368 4369 DONE = MAXITI.EQ.0 4370 PRTPEN = .TRUE. 4371 4372 10 CONTINUE 4373 CALL DODDRV 4374 + (SHORT,HEAD,FSTITR,PRTPEN, 4375 + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, 4376 + PNLTY,1,1,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, 4377 + JOBI,NDIGIT,TAUFAC, SSTOL,CNVTOL,MAXITI, 4378 + IPRNTI,LUNERR,LUNRPT, 4379 + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, 4380 + WORK,LWORK,IWORK,LIWORK, 4381 + MAXIT1,TSTIMP, INFO) 4382 4383 IF (DONE) THEN 4384 RETURN 4385 ELSE 4386 DONE = MAXIT1.LE.0 .OR. 4387 + (ABS(PNLTY(1,1,1)).GE.PCHECK .AND. 4388 + TSTIMP.LE.CNVTOL) 4389 END IF 4390 4391 IF (DONE) THEN 4392 IF (TSTIMP.LE.CNVTOL) THEN 4393 INFO = (INFO/10)*10 + 2 4394 ELSE 4395 INFO = (INFO/10)*10 + 4 4396 END IF 4397 JOBI = 10000 + 1000 + JOB3*100 + JOB2*10 + JOB1 4398 MAXITI = 0 4399 IPRNTI = IPR3 4400 ELSE 4401 PRTPEN = .TRUE. 4402 PNLTY(1,1,1) = PFAC*PNLTY(1,1,1) 4403 JOBI = 10000 + 1000 + 000 + JOB2*10 + JOB1 4404 MAXITI = MAXIT1 4405 IPRNTI = 0000 + IPR2*100 + IPR2F*10 4406 END IF 4407 GO TO 10 4408 ELSE 4409 CALL DODDRV 4410 + (SHORT,HEAD,FSTITR,PRTPEN, 4411 + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, 4412 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, 4413 + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, 4414 + IPRINT,LUNERR,LUNRPT, 4415 + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, 4416 + WORK,LWORK,IWORK,LIWORK, 4417 + MAXIT1,TSTIMP, INFO) 4418 END IF 4419 4420 RETURN 4421 4422 END 4423*DODDRV 4424 SUBROUTINE DODDRV 4425 + (SHORT,HEAD,FSTITR,PRTPEN, 4426 + FCN, N,M,NP,NQ, BETA, Y,LDY,X,LDX, 4427 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, IFIXB,IFIXX,LDIFX, 4428 + JOB,NDIGIT,TAUFAC, SSTOL,PARTOL,MAXIT, 4429 + IPRINT,LUNERR,LUNRPT, 4430 + STPB,STPD,LDSTPD, SCLB,SCLD,LDSCLD, 4431 + WORK,LWORK,IWORK,LIWORK, 4432 + MAXIT1,TSTIMP, INFO) 4433C***BEGIN PROLOGUE DODDRV 4434C***REFER TO DODR,DODRC 4435C***ROUTINES CALLED FCN,DCOPY,DDOT,DETAF,DFCTRW,DFLAGS, 4436C DINIWK,DIWINF,DJCK,DNRM2,DODCHK,DODMN, 4437C DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY 4438C***DATE WRITTEN 860529 (YYMMDD) 4439C***REVISION DATE 920619 (YYMMDD) 4440C***PURPOSE PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN 4441C PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION 4442C (ODR) OR ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) 4443C***END PROLOGUE DODDRV 4444 4445C...SCALAR ARGUMENTS 4446 DOUBLE PRECISION 4447 + PARTOL,SSTOL,TAUFAC,TSTIMP 4448 INTEGER 4449 + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY, 4450 + LD2WD,LD2WE,LIWORK,LUNERR,LUNRPT,LWORK,M,MAXIT,MAXIT1, 4451 + N,NDIGIT,NP,NQ 4452 LOGICAL 4453 + FSTITR,HEAD,PRTPEN,SHORT 4454 4455C...ARRAY ARGUMENTS 4456 DOUBLE PRECISION 4457 + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),STPB(NP),STPD(LDSTPD,M), 4458 + WE(LDWE,LD2WE,NQ),WD(LDWD,LD2WD,M),WORK(LWORK), 4459 + X(LDX,M),Y(LDY,NQ) 4460 INTEGER 4461 + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) 4462 4463C...SUBROUTINE ARGUMENTS 4464 EXTERNAL 4465 + FCN 4466 4467C...LOCAL SCALARS 4468 DOUBLE PRECISION 4469 + EPSMAC,ETA,P5,ONE,TEN,ZERO 4470 INTEGER 4471 + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, 4472 + DIFFI,EPSMAI,ETAI,FI,FJACBI,FJACDI,FNI,FSI,I,IDFI,INT2I,IPRINI, 4473 + IRANKI,ISTOP,ISTOPI,JOBI,JPVTI,K,LDTT,LDTTI,LIWKMN, 4474 + LUNERI,LUNRPI,LWKMN,LWRK,MAXITI,MSGB,MSGD,NETA,NETAI, 4475 + NFEV,NFEVI,NITERI,NJEV,NJEVI,NNZW,NNZWI,NPP,NPPI,NROW,NROWI, 4476 + NTOL,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, 4477 + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI, 4478 + VCVI,WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,WRK, 4479 + WSSI,WSSDEI,WSSEPI,XPLUSI 4480 LOGICAL 4481 + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT 4482 4483C...EXTERNAL FUNCTIONS 4484 DOUBLE PRECISION 4485 + DDOT,DNRM2 4486 EXTERNAL 4487 + DDOT,DNRM2 4488 4489C...EXTERNAL SUBROUTINES 4490 EXTERNAL 4491 + DCOPY,DETAF,DFCTRW,DFLAGS,DINIWK,DIWINF,DJCK,DODCHK, 4492 + DODMN,DODPER,DPACK,DSETN,DUNPAC,DWGHT,DWINF,DXMY,DXPY 4493 4494C...DATA STATEMENTS 4495 DATA 4496 + ZERO,P5,ONE,TEN 4497 + /0.0D0,0.5D0,1.0D0,10.0D0/ 4498 4499C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 4500C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 4501 4502C...VARIABLE DEFINITIONS (ALPHABETICALLY) 4503C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. 4504C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. 4505C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 4506C COMPUTED BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT 4507C (ANAJAC=TRUE). 4508C BETA: THE FUNCTION PARAMETERS. 4509C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. 4510C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. 4511C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. 4512C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. 4513C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE 4514C COMPUTED BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD 4515C DIFFERENCES (CDJAC=FALSE). 4516C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED 4517C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT 4518C (CHKJAC=FALSE). 4519C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. 4520C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. 4521C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. 4522C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. 4523C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 4524C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). 4525C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. 4526C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. 4527C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. 4528C FI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY F. 4529C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. 4530C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. 4531C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. 4532C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. 4533C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 4534C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). 4535C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 4536C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). 4537C I: AN INDEX VARIABLE. 4538C IDFI: THE LOCATION IN ARRAY IWORK OF VARIABLE IDF. 4539C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 4540C FIXED AT THEIR INPUT VALUES OR NOT. 4541C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 4542C FIXED AT THEIR INPUT VALUES OR NOT. 4543C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 4544C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 4545C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 4546C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS TO BE INITIALIZED 4547C TO ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M 4548C ELEMENTS OF ARRAY WORK (INITD=FALSE). 4549C INT2I: THE IN ARRAY IWORK OF VARIABLE INT2. 4550C IPRINI: THE LOCATION IN ARRAY IWORK OF VARIABLE IPRINT. 4551C IPRINT: THE PRINT CONTROL VARIABLE. 4552C IRANKI: THE LOCATION IN ARRAY IWORK OF VARIABLE IRANK. 4553C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 4554C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 4555C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 4556C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 4557C ISTOPI: THE LOCATION IN ARRAY IWORK OF VARIABLE ISTOP. 4558C IWORK: THE INTEGER WORK SPACE. 4559C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 4560C COMPUTATIONAL METHOD. 4561C JOBI: THE LOCATION IN ARRAY IWORK OF VARIABLE JOB. 4562C JPVTI: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY JPVT. 4563C K: AN INDEX VARIABLE. 4564C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 4565C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. 4566C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 4567C LDTT: THE LEADING DIMENSION OF ARRAY TT. 4568C LDTTI: THE LOCATION IN ARRAY IWORK OF VARIABLE LDTT. 4569C LDWD: THE LEADING DIMENSION OF ARRAY WD. 4570C LDWE: THE LEADING DIMENSION OF ARRAY WE. 4571C LDX: THE LEADING DIMENSION OF ARRAY X. 4572C LDY: THE LEADING DIMENSION OF ARRAY Y. 4573C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 4574C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 4575C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. 4576C LIWORK: THE LENGTH OF VECTOR IWORK. 4577C LUNERI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNERR. 4578C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. 4579C LUNRPI: THE LOCATION IN ARRAY IWORK OF VARIABLE LUNRPT. 4580C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. 4581C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. 4582C LWORK: THE LENGTH OF VECTOR WORK. 4583C LWRK: THE LENGTH OF VECTOR WRK. 4584C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 4585C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 4586C MAXIT1: FOR IMPLICIT MODELS, THE ITERATIONS ALLOWED FOR THE NEXT 4587C PENALTY PARAMETER VALUE. 4588C MAXITI: THE LOCATION IN ARRAY IWORK OF VARIABLE MAXIT. 4589C MSGB: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGB. 4590C MSGD: THE STARTING LOCATION IN ARRAY IWORK OF ARRAY MSGD. 4591C N: THE NUMBER OF OBSERVATIONS. 4592C NDIGIT: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS 4593C SUPPLIED BY THE USER. 4594C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. 4595C NETAI: THE LOCATION IN ARRAY IWORK OF VARIABLE NETA. 4596C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 4597C NFEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NFEV. 4598C NITERI: THE LOCATION IN ARRAY IWORK OF VARIABLE NITER. 4599C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. 4600C NJEVI: THE LOCATION IN ARRAY IWORK OF VARIABLE NJEV. 4601C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. 4602C NNZWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NNZW. 4603C NP: THE NUMBER OF FUNCTION PARAMETERS. 4604C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. 4605C NPPI: THE LOCATION IN ARRAY IWORK OF VARIABLE NPP. 4606C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 4607C NROW: THE ROW NUMBER AT WHICH THE DERIVATIVE IS TO BE CHECKED. 4608C NROWI: THE LOCATION IN ARRAY IWORK OF VARIABLE NROW. 4609C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE 4610C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, 4611C SET BY DJCK. 4612C NTOLI: THE LOCATION IN ARRAY IWORK OF VARIABLE NTOL. 4613C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. 4614C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. 4615C ONE: THE VALUE 1.0D0. 4616C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. 4617C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. 4618C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. 4619C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. 4620C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. 4621C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS 4622C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 4623C (PRTPEN=FALSE). 4624C P5: THE VALUE 0.5D0. 4625C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. 4626C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCOND. 4627C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO 4628C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 4629C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). 4630C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 4631C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). 4632C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. 4633C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. 4634C SCLB: THE SCALING VALUES FOR BETA. 4635C SCLD: THE SCALING VALUES FOR DELTA. 4636C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. 4637C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 4638C ODRPACK BY THE SHORT-CALL (SHORT=TRUE) OR THE LONG-CALL 4639C (SHORT=FALSE). 4640C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. 4641C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. 4642C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. 4643C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. 4644C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. 4645C STPB: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT BETA. 4646C STPD: THE STEP SIZE FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA. 4647C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 4648C DIAMETER. 4649C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. 4650C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. 4651C TEN: THE VALUE 10.0D0. 4652C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. 4653C TSTIMP: THE RELATIVE CHANGE IN THE PARAMETERS BETWEEN THE INITIAL 4654C VALUES AND THE SOLUTION. 4655C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. 4656C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. 4657C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. 4658C WD: THE DELTA WEIGHTS. 4659C WE: THE EPSILON WEIGHTS. 4660C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. 4661C WORK: THE DOUBLE PRECISION WORK SPACE. 4662C WRK: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK, 4663C EQUIVALENCED TO WRK1 AND WRK2. 4664C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. 4665C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. 4666C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. 4667C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. 4668C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. 4669C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. 4670C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. 4671C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. 4672C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. 4673C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. 4674C X: THE EXPLANATORY VARIABLE. 4675C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. 4676C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. 4677C ZERO: THE VALUE 0.0D0. 4678 4679 4680C***FIRST EXECUTABLE STATEMENT DODDRV 4681 4682 4683C INITIALIZE NECESSARY VARIABLES 4684 4685 CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, 4686 + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) 4687 4688C SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE 4689C (INVALID VALUES OF M, NP AND/OR NQ ARE HANDLED REASONABLY BY DIWINF) 4690 4691 CALL DIWINF(M,NP,NQ, 4692 + MSGB,MSGD,JPVTI,ISTOPI, 4693 + NNZWI,NPPI,IDFI, 4694 + JOBI,IPRINI,LUNERI,LUNRPI, 4695 + NROWI,NTOLI,NETAI, 4696 + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, 4697 + LIWKMN) 4698 4699C SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE 4700C (INVALID VALUES OF N, M, NP, NQ, LDWE AND/OR LD2WE 4701C ARE HANDLED REASONABLY BY DWINF) 4702 4703 CALL DWINF(N,M,NP,NQ,LDWE,LD2WE,ISODR, 4704 + DELTAI,FI,XPLUSI,FNI,SDI,VCVI, 4705 + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, 4706 + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, 4707 + PARTLI,SSTOLI,TAUFCI,EPSMAI, 4708 + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, 4709 + FSI,FJACBI,WE1I,DIFFI, 4710 + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, 4711 + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, 4712 + LWKMN) 4713 IF (ISODR) THEN 4714 WRK = WRK1I 4715 LWRK = N*M*NQ + N*NQ 4716 ELSE 4717 WRK = WRK2I 4718 LWRK = N*NQ 4719 END IF 4720 4721C UPDATE THE PENALTY PARAMETERS 4722C (WE(1,1,1) IS NOT A USER SUPPLIED ARRAY IN THIS CASE) 4723 IF (RESTRT .AND. IMPLCT) THEN 4724 WE(1,1,1) = MAX(WORK(WE1I)**2,ABS(WE(1,1,1))) 4725 WORK(WE1I) = -SQRT(ABS(WE(1,1,1))) 4726 END IF 4727 4728 IF (RESTRT) THEN 4729 4730C RESET MAXIMUM NUMBER OF ITERATIONS 4731 4732 IF (MAXIT.GE.0) THEN 4733 IWORK(MAXITI) = IWORK(NITERI) + MAXIT 4734 ELSE 4735 IWORK(MAXITI) = IWORK(NITERI) + 10 4736 END IF 4737 4738 IF (IWORK(NITERI).LT.IWORK(MAXITI)) THEN 4739 INFO = 0 4740 END IF 4741 4742 IF (JOB.GE.0) IWORK(JOBI) = JOB 4743 IF (IPRINT.GE.0) IWORK(IPRINI) = IPRINT 4744 IF (PARTOL.GE.ZERO .AND. PARTOL.LT.ONE) WORK(PARTLI) = PARTOL 4745 IF (SSTOL.GE.ZERO .AND. SSTOL.LT.ONE) WORK(SSTOLI) = SSTOL 4746 4747 WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI) 4748 4749 IF (IMPLCT) THEN 4750 CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) 4751 ELSE 4752 CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) 4753 END IF 4754 CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) 4755 WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) 4756 WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) 4757 4758 ELSE 4759 4760C PERFORM ERROR CHECKING 4761 4762 INFO = 0 4763 4764 CALL DODCHK(N,M,NP,NQ, 4765 + ISODR,ANAJAC,IMPLCT, 4766 + IFIXB, 4767 + LDX,LDIFX,LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, 4768 + LDY, 4769 + LWORK,LWKMN,LIWORK,LIWKMN, 4770 + SCLB,SCLD,STPB,STPD, 4771 + INFO) 4772 IF (INFO.GT.0) THEN 4773 GO TO 50 4774 END IF 4775 4776C INITIALIZE WORK VECTORS AS NECESSARY 4777 4778 DO 10 I=N*M+N*NQ+1,LWORK 4779 WORK(I) = ZERO 4780 10 CONTINUE 4781 DO 20 I=1,LIWORK 4782 IWORK(I) = 0 4783 20 CONTINUE 4784 4785 CALL DINIWK(N,M,NP, 4786 + WORK,LWORK,IWORK,LIWORK, 4787 + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, 4788 + BETA,SCLB, 4789 + SSTOL,PARTOL,MAXIT,TAUFAC, 4790 + JOB,IPRINT,LUNERR,LUNRPT, 4791 + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, 4792 + JOBI,IPRINI,LUNERI,LUNRPI, 4793 + SSFI,TTI,LDTTI,DELTAI) 4794 4795 IWORK(MSGB) = -1 4796 IWORK(MSGD) = -1 4797 WORK(TAUI) = -WORK(TAUFCI) 4798 4799C SET UP FOR PARAMETER ESTIMATION - 4800C PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES 4801C AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY 4802 4803 CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB) 4804 CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB) 4805 NPP = IWORK(NPPI) 4806 4807C CHECK THAT WD IS POSITIVE DEFINITE AND WE IS POSITIVE SEMIDEFINITE, 4808C SAVING FACTORIZATION OF WE, AND COUNTING NUMBER OF NONZERO WEIGHTS 4809 4810 CALL DFCTRW(N,M,NQ,NPP, 4811 + ISODR, 4812 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, 4813 + WORK(WRK2I),WORK(WRK4I), 4814 + WORK(WE1I),NNZW,INFO) 4815 IWORK(NNZWI) = NNZW 4816 4817 IF (INFO.NE.0) THEN 4818 GO TO 50 4819 END IF 4820 4821C EVALUATE THE PREDICTED VALUES AND 4822C WEIGHTED EPSILONS AT THE STARTING POINT 4823 4824 CALL DUNPAC(NP,WORK(BETACI),BETA,IFIXB) 4825 CALL DXPY(N,M,X,LDX,WORK(DELTAI),N,WORK(XPLUSI),N) 4826 ISTOP = 0 4827 CALL FCN(N,M,NP,NQ, 4828 + N,M,NP, 4829 + BETA,WORK(XPLUSI), 4830 + IFIXB,IFIXX,LDIFX, 4831 + 002,WORK(FNI),WORK(WRK6I),WORK(WRK1I), 4832 + ISTOP) 4833 IWORK(ISTOPI) = ISTOP 4834 IF (ISTOP.EQ.0) THEN 4835 IWORK(NFEVI) = IWORK(NFEVI) + 1 4836 IF (IMPLCT) THEN 4837 CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FI),1) 4838 ELSE 4839 CALL DXMY(N,NQ,WORK(FNI),N,Y,LDY,WORK(FI),N) 4840 END IF 4841 CALL DWGHT(N,NQ,WORK(WE1I),LDWE,LD2WE,WORK(FI),N,WORK(FI),N) 4842 ELSE 4843 INFO = 52000 4844 GO TO 50 4845 END IF 4846 4847C COMPUTE NORM OF THE INITIAL ESTIMATES 4848 4849 CALL DWGHT(NPP,1,WORK(SSI),NPP,1,WORK(BETACI),NPP, 4850 + WORK(WRK),NPP) 4851 IF (ISODR) THEN 4852 CALL DWGHT(N,M,WORK(TTI),IWORK(LDTTI),1,WORK(DELTAI),N, 4853 + WORK(WRK+NPP),N) 4854 WORK(PNORMI) = DNRM2(NPP+N*M,WORK(WRK),1) 4855 ELSE 4856 WORK(PNORMI) = DNRM2(NPP,WORK(WRK),1) 4857 END IF 4858 4859C COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS 4860 4861 WORK(WSSEPI) = DDOT(N*NQ,WORK(FI),1,WORK(FI),1) 4862 IF (ISODR) THEN 4863 CALL DWGHT(N,M,WD,LDWD,LD2WD,WORK(DELTAI),N,WORK(WRK),N) 4864 WORK(WSSDEI) = DDOT(N*M,WORK(DELTAI),1,WORK(WRK),1) 4865 ELSE 4866 WORK(WSSDEI) = ZERO 4867 END IF 4868 WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) 4869 4870C SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS 4871 4872 NROW = -1 4873 CALL DSETN(N,M,WORK(XPLUSI),N,NROW) 4874 IWORK(NROWI) = NROW 4875 4876C SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS 4877 4878 EPSMAC = WORK(EPSMAI) 4879 IF (NDIGIT.LT.2) THEN 4880 IWORK(NETAI) = -1 4881 NFEV = IWORK(NFEVI) 4882 CALL DETAF(FCN, 4883 + N,M,NP,NQ, 4884 + WORK(XPLUSI),BETA,EPSMAC,NROW, 4885 + WORK(BETANI),WORK(FNI), 4886 + IFIXB,IFIXX,LDIFX, 4887 + ISTOP,NFEV,ETA,NETA, 4888 + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I),WORK(WRK7I)) 4889 IWORK(ISTOPI) = ISTOP 4890 IWORK(NFEVI) = NFEV 4891 IF (ISTOP.NE.0) THEN 4892 INFO = 53000 4893 IWORK(NETAI) = 0 4894 WORK(ETAI) = ZERO 4895 GO TO 50 4896 ELSE 4897 IWORK(NETAI) = -NETA 4898 WORK(ETAI) = ETA 4899 END IF 4900 ELSE 4901 IWORK(NETAI) = MIN(NDIGIT,INT(P5-LOG10(EPSMAC))) 4902 WORK(ETAI) = MAX(EPSMAC,TEN**(-NDIGIT)) 4903 END IF 4904 4905C CHECK DERIVATIVES IF NECESSARY 4906 4907 IF (CHKJAC .AND. ANAJAC) THEN 4908 NTOL = -1 4909 NFEV = IWORK(NFEVI) 4910 NJEV = IWORK(NJEVI) 4911 NETA = IWORK(NETAI) 4912 LDTT = IWORK(LDTTI) 4913 ETA = WORK(ETAI) 4914 EPSMAC = WORK(EPSMAI) 4915 CALL DJCK(FCN, 4916 + N,M,NP,NQ, 4917 + BETA,WORK(XPLUSI), 4918 + IFIXB,IFIXX,LDIFX,STPB,STPD,LDSTPD, 4919 + WORK(SSFI),WORK(TTI),LDTT, 4920 + ETA,NETA,NTOL,NROW,ISODR,EPSMAC, 4921 + WORK(FNI),WORK(FJACBI),WORK(FJACDI), 4922 + IWORK(MSGB),IWORK(MSGD),WORK(DIFFI), 4923 + ISTOP,NFEV,NJEV, 4924 + WORK(WRK1I),WORK(WRK2I),WORK(WRK6I)) 4925 IWORK(ISTOPI) = ISTOP 4926 IWORK(NFEVI) = NFEV 4927 IWORK(NJEVI) = NJEV 4928 IWORK(NTOLI) = NTOL 4929 IF (ISTOP.NE.0) THEN 4930 INFO = 54000 4931 ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGD).NE.0) THEN 4932 INFO = 40000 4933 END IF 4934 ELSE 4935 4936C INDICATE USER SUPPLIED DERIVATIVES WERE NOT CHECKED 4937 IWORK(MSGB) = -1 4938 IWORK(MSGD) = -1 4939 END IF 4940 4941C PRINT APPROPRIATE ERROR MESSAGES 4942 4943 50 IF ((INFO.NE.0) .OR. (IWORK(MSGB).NE.-1)) THEN 4944 IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN 4945 CALL DODPER 4946 + (INFO,LUNERR,SHORT, 4947 + N,M,NP,NQ, 4948 + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, 4949 + LWKMN,LIWKMN, 4950 + WORK(FJACBI),WORK(FJACDI), 4951 + WORK(DIFFI),IWORK(MSGB),ISODR,IWORK(MSGD), 4952 + WORK(XPLUSI),IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI)) 4953 END IF 4954 4955C SET INFO TO REFLECT ERRORS IN THE USER SUPPLIED JACOBIANS 4956 4957 IF (INFO.EQ.40000) THEN 4958 IF (IWORK(MSGB).EQ.2 .OR. IWORK(MSGD).EQ.2) THEN 4959 IF (IWORK(MSGB).EQ.2) THEN 4960 INFO = INFO + 1000 4961 END IF 4962 IF (IWORK(MSGD).EQ.2) THEN 4963 INFO = INFO + 100 4964 END IF 4965 ELSE 4966 INFO = 0 4967 END IF 4968 END IF 4969 IF (INFO.NE.0) THEN 4970 RETURN 4971 END IF 4972 END IF 4973 END IF 4974 4975C SAVE THE INITIAL VALUES OF BETA 4976 CALL DCOPY(NP,BETA,1,WORK(BETA0I),1) 4977 4978C FIND LEAST SQUARES SOLUTION 4979 4980 CALL DCOPY(N*NQ,WORK(FNI),1,WORK(FSI),1) 4981 LDTT = IWORK(LDTTI) 4982 CALL DODMN(HEAD,FSTITR,PRTPEN, 4983 + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, 4984 + WE,WORK(WE1I),LDWE,LD2WE,WD,LDWD,LD2WD, 4985 + IFIXB,IFIXX,LDIFX, 4986 + WORK(BETACI),WORK(BETANI),WORK(BETASI),WORK(SI), 4987 + WORK(DELTAI),WORK(DELTNI),WORK(DELTSI), 4988 + WORK(TI),WORK(FI),WORK(FNI),WORK(FSI), 4989 + WORK(FJACBI),IWORK(MSGB),WORK(FJACDI),IWORK(MSGD), 4990 + WORK(SSFI),WORK(SSI),WORK(TTI),LDTT, 4991 + STPB,STPD,LDSTPD, 4992 + WORK(XPLUSI),WORK(WRK),LWRK, 4993 + WORK,LWORK,IWORK,LIWORK,INFO) 4994 MAXIT1 = IWORK(MAXITI) - IWORK(NITERI) 4995 TSTIMP = ZERO 4996 DO 100 K=1,NP 4997 IF (BETA(K).EQ.ZERO) THEN 4998 TSTIMP = MAX(TSTIMP, 4999 + ABS(BETA(K)-WORK(BETA0I-1+K))/WORK(SSFI-1+K)) 5000 ELSE 5001 TSTIMP = MAX(TSTIMP, 5002 + ABS(BETA(K)-WORK(BETA0I-1+K))/ABS(BETA(K))) 5003 END IF 5004 100 CONTINUE 5005 5006 RETURN 5007 5008 END 5009*DODLM 5010 SUBROUTINE DODLM 5011 + (N,M,NP,NQ,NPP, 5012 + F,FJACB,FJACD, 5013 + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, 5014 + ALPHA2,TAU,EPSFCN,ISODR, 5015 + TFJACB,OMEGA,U,QRAUX,JPVT, 5016 + S,T,NLMS,RCOND,IRANK, 5017 + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) 5018C***BEGIN PROLOGUE DODLM 5019C***REFER TO DODR,DODRC 5020C***ROUTINES CALLED DDOT,DNRM2,DODSTP,DSCALE,DWGHT 5021C***DATE WRITTEN 860529 (YYMMDD) 5022C***REVISION DATE 920619 (YYMMDD) 5023C***PURPOSE COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T 5024C USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT 5025C ALGORITHM 5026C***END PROLOGUE DODLM 5027 5028C...SCALAR ARGUMENTS 5029 DOUBLE PRECISION 5030 + ALPHA2,EPSFCN,RCOND,TAU 5031 INTEGER 5032 + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NLMS,NP,NPP,NQ 5033 LOGICAL 5034 + ISODR 5035 5036C...ARRAY ARGUMENTS 5037 DOUBLE PRECISION 5038 + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), 5039 + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), 5040 + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), 5041 + WRK(LWRK),WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M) 5042 INTEGER 5043 + JPVT(NP) 5044 5045C...LOCAL SCALARS 5046 DOUBLE PRECISION 5047 + ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO 5048 INTEGER 5049 + I,IWRK,J,K,L 5050 LOGICAL 5051 + FORVCV 5052 5053C...EXTERNAL FUNCTIONS 5054 DOUBLE PRECISION 5055 + DDOT,DNRM2 5056 EXTERNAL 5057 + DDOT,DNRM2 5058 5059C...EXTERNAL SUBROUTINES 5060 EXTERNAL 5061 + DODSTP,DSCALE,DWGHT 5062 5063C...INTRINSIC FUNCTIONS 5064 INTRINSIC 5065 + ABS,MAX,MIN,SQRT 5066 5067C...DATA STATEMENTS 5068 DATA 5069 + ZERO,P001,P1 5070 + /0.0D0,0.001D0,0.1D0/ 5071 5072C...VARIABLE DEFINITIONS (ALPHABETICALLY) 5073C ALPHAN: THE NEW LEVENBERG-MARQUARDT PARAMETER. 5074C ALPHA1: THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER. 5075C ALPHA2: THE CURRENT LEVENBERG-MARQUARDT PARAMETER. 5076C BOT: THE LOWER LIMIT FOR SETTING ALPHA. 5077C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 5078C EPSFCN: THE FUNCTION'S PRECISION. 5079C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. 5080C FJACB: THE JACOBIAN WITH RESPECT TO BETA. 5081C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. 5082C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS 5083C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS 5084C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). 5085C I: AN INDEXING VARIABLE. 5086C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. 5087C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 5088C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 5089C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE 5090C STOPED DUE TO SOME NUMERICAL ERROR DETECTED WITHIN 5091C SUBROUTINE DODSTP. 5092C IWRK: AN INDEXING VARIABLE. 5093C J: AN INDEXING VARIABLE. 5094C K: AN INDEXING VARIABLE. 5095C L: AN INDEXING VARIABLE. 5096C JPVT: THE PIVOT VECTOR. 5097C LDTT: THE LEADING DIMENSION OF ARRAY TT. 5098C LDWD: THE LEADING DIMENSION OF ARRAY WD. 5099C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 5100C LWRK: THE LENGTH OF VECTOR WRK. 5101C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 5102C N: THE NUMBER OF OBSERVATIONS. 5103C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. 5104C NP: THE NUMBER OF FUNCTION PARAMETERS. 5105C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. 5106C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 5107C OMEGA: THE ARRAY (I-FJACD*INV(P)*TRANS(FJACD))**(-1/2) WHERE 5108C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 5109C P001: THE VALUE 0.001D0 5110C P1: THE VALUE 0.1D0 5111C PHI1: THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP 5112C AND THE TRUST REGION DIAMETER. 5113C PHI2: THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP 5114C AND THE TRUST REGION DIAMETER. 5115C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE 5116C Q-R DECOMPOSITION. 5117C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. 5118C S: THE STEP FOR BETA. 5119C SA: THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2). 5120C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. 5121C T: THE STEP FOR DELTA. 5122C TAU: THE TRUST REGION DIAMETER. 5123C TFJACB: THE ARRAY OMEGA*FJACB. 5124C TOP: THE UPPER LIMIT FOR SETTING ALPHA. 5125C TT: THE SCALE USED FOR THE DELTA'S. 5126C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. 5127C WD: THE DELTA WEIGHTS. 5128C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, 5129C EQUIVALENCED TO WRK1 AND WRK2. 5130C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. 5131C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 5132C WRK3: A WORK ARRAY OF (NP) ELEMENTS. 5133C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. 5134C WRK5: A WORK ARRAY OF (M) ELEMENTS. 5135C ZERO: THE VALUE 0.0D0. 5136 5137 5138C***FIRST EXECUTABLE STATEMENT DODLM 5139 5140 FORVCV = .FALSE. 5141 ISTOPC = 0 5142 5143C COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0) 5144 5145 ALPHA1 = ZERO 5146 CALL DODSTP(N,M,NP,NQ,NPP, 5147 + F,FJACB,FJACD, 5148 + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, 5149 + ALPHA1,EPSFCN,ISODR, 5150 + TFJACB,OMEGA,U,QRAUX,JPVT, 5151 + S,T,PHI1,IRANK,RCOND,FORVCV, 5152 + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) 5153 IF (ISTOPC.NE.0) THEN 5154 RETURN 5155 END IF 5156 5157C INITIALIZE TAU IF NECESSARY 5158 5159 IF (TAU.LT.ZERO) THEN 5160 TAU = ABS(TAU)*PHI1 5161 END IF 5162 5163C CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL 5164 5165 IF ((PHI1-TAU).LE.P1*TAU) THEN 5166 NLMS = 1 5167 ALPHA2 = ZERO 5168 RETURN 5169 END IF 5170 5171C FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION - 5172C FIND LOCALLY CONSTRAINED OPTIMAL STEP 5173 5174 PHI1 = PHI1 - TAU 5175 5176C INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA 5177 5178 BOT = ZERO 5179 5180 DO 30 K=1,NPP 5181 DO 20 L=1,NQ 5182 DO 10 I=1,N 5183 TFJACB(I,L,K) = FJACB(I,K,L) 5184 10 CONTINUE 5185 20 CONTINUE 5186 WRK(K) = DDOT(N*NQ,TFJACB(1,1,K),1,F(1,1),1) 5187 30 CONTINUE 5188 CALL DSCALE(NPP,1,SS,NPP,WRK,NPP,WRK,NPP) 5189 5190 IF (ISODR) THEN 5191 CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(NPP+1),N) 5192 IWRK = NPP 5193 DO 50 J=1,M 5194 DO 40 I=1,N 5195 IWRK = IWRK + 1 5196 WRK(IWRK) = WRK(IWRK) + 5197 + DDOT(NQ,FJACD(I,J,1),N*M,F(I,1),N) 5198 40 CONTINUE 5199 50 CONTINUE 5200 CALL DSCALE(N,M,TT,LDTT,WRK(NPP+1),N,WRK(NPP+1),N) 5201 TOP = DNRM2(NPP+N*M,WRK,1)/TAU 5202 ELSE 5203 TOP = DNRM2(NPP,WRK,1)/TAU 5204 END IF 5205 5206 IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN 5207 ALPHA2 = P001*TOP 5208 END IF 5209 5210C MAIN LOOP 5211 5212 DO 60 I=1,10 5213 5214C COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR 5215C CURRENT VALUE OF ALPHA 5216 5217 CALL DODSTP(N,M,NP,NQ,NPP, 5218 + F,FJACB,FJACD, 5219 + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, 5220 + ALPHA2,EPSFCN,ISODR, 5221 + TFJACB,OMEGA,U,QRAUX,JPVT, 5222 + S,T,PHI2,IRANK,RCOND,FORVCV, 5223 + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) 5224 IF (ISTOPC.NE.0) THEN 5225 RETURN 5226 END IF 5227 PHI2 = PHI2-TAU 5228 5229C CHECK WHETHER CURRENT STEP IS OPTIMAL 5230 5231 IF (ABS(PHI2).LE.P1*TAU .OR. 5232 + (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN 5233 NLMS = I+1 5234 RETURN 5235 END IF 5236 5237C CURRENT STEP IS NOT OPTIMAL 5238 5239C UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA 5240 5241 IF (PHI1-PHI2.EQ.ZERO) THEN 5242 NLMS = 12 5243 RETURN 5244 END IF 5245 SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2) 5246 IF (PHI2.LT.ZERO) THEN 5247 TOP = MIN(TOP,ALPHA2) 5248 ELSE 5249 BOT = MAX(BOT,ALPHA2) 5250 END IF 5251 IF (PHI1*PHI2.GT.ZERO) THEN 5252 BOT = MAX(BOT,ALPHA2-SA) 5253 ELSE 5254 TOP = MIN(TOP,ALPHA2-SA) 5255 END IF 5256 5257 ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU 5258 IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN 5259 ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT)) 5260 END IF 5261 5262C GET READY FOR NEXT ITERATION 5263 5264 ALPHA1 = ALPHA2 5265 ALPHA2 = ALPHAN 5266 PHI1 = PHI2 5267 60 CONTINUE 5268 5269C SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS 5270 5271 NLMS = 12 5272 5273 RETURN 5274 END 5275*DODMN 5276 SUBROUTINE DODMN 5277 + (HEAD,FSTITR,PRTPEN, 5278 + FCN, N,M,NP,NQ, JOB, BETA,Y,LDY,X,LDX, 5279 + WE,WE1,LDWE,LD2WE,WD,LDWD,LD2WD, 5280 + IFIXB,IFIXX,LDIFX, 5281 + BETAC,BETAN,BETAS,S,DELTA,DELTAN,DELTAS, 5282 + T,F,FN,FS,FJACB,MSGB,FJACD,MSGD, 5283 + SSF,SS,TT,LDTT,STPB,STPD,LDSTPD, 5284 + XPLUSD,WRK,LWRK,WORK,LWORK,IWORK,LIWORK,INFO) 5285C***BEGIN PROLOGUE DODMN 5286C***REFER TO DODR,DODRC 5287C***ROUTINES CALLED FCN,DACCES,DCOPY,DDOT,DEVJAC,DFLAGS,DNRM2,DODLM, 5288C DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY 5289C***DATE WRITTEN 860529 (YYMMDD) 5290C***REVISION DATE 920619 (YYMMDD) 5291C***PURPOSE ITERATIVELY COMPUTE LEAST SQUARES SOLUTION 5292C***END PROLOGUE DODMN 5293 5294C...SCALAR ARGUMENTS 5295 INTEGER 5296 + INFO,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, 5297 + LIWORK,LWORK,LWRK,M,N,NP,NQ 5298 5299C...ARRAY ARGUMENTS 5300 DOUBLE PRECISION 5301 + BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP), 5302 + DELTA(N,M),DELTAN(N,M),DELTAS(N,M), 5303 + F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ),FN(N,NQ),FS(N,NQ), 5304 + S(NP),SS(NP),SSF(NP),STPB(NP),STPD(LDSTPD,M), 5305 + T(N,M),TT(LDTT,M), 5306 + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WE1(LDWE,LD2WE,NQ), 5307 + WORK(LWORK),X(LDX,M),XPLUSD(N,M),WRK(LWRK),Y(LDY,NQ) 5308 INTEGER 5309 + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK), 5310 + MSGB(NQ*NP+1),MSGD(NQ*M+1) 5311 LOGICAL 5312 + FSTITR,HEAD,PRTPEN 5313 5314C...SUBROUTINE ARGUMENTS 5315 EXTERNAL 5316 + FCN 5317 5318C...LOCAL SCALARS 5319 DOUBLE PRECISION 5320 + ACTRED,ACTRS,ALPHA,DIRDER,ETA,OLMAVG,ONE, 5321 + P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS, 5322 + RATIO,RCOND,RNORM,RNORMN,RNORMS,RSS,RVAR,SSTOL,TAU,TAUFAC, 5323 + TEMP,TEMP1,TEMP2,TSNORM,ZERO 5324 INTEGER 5325 + I,IDF,IFLAG,INT2,IPR,IPR1,IPR2,IPR2F,IPR3,IRANK, 5326 + ISTOP,ISTOPC,IWRK,J,JPVT,L,LOOPED,LUDFLT,LUNR,LUNRPT, 5327 + MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW,NPP,NPR,OMEGA,QRAUX, 5328 + SD,U,VCV,WRK1,WRK2,WRK3,WRK4,WRK5,WRK6 5329 LOGICAL 5330 + ACCESS,ANAJAC,CDJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV, 5331 + IMPLCT,INITD,INTDBL,ISODR,LSTEP,REDOJ,RESTRT 5332 5333C...LOCAL ARRAYS 5334 DOUBLE PRECISION 5335 + WSS(3) 5336 5337C...EXTERNAL FUNCTIONS 5338 DOUBLE PRECISION 5339 + DDOT,DNRM2 5340 EXTERNAL 5341 + DDOT,DNRM2 5342 5343C...EXTERNAL SUBROUTINES 5344 EXTERNAL 5345 + DACCES,DCOPY,DEVJAC,DFLAGS, 5346 + DODLM,DODPCR,DODVCV,DUNPAC,DWGHT,DXMY,DXPY 5347 5348C...INTRINSIC FUNCTIONS 5349 INTRINSIC 5350 + ABS,MIN,MOD,SQRT 5351 5352C...DATA STATEMENTS 5353 DATA 5354 + ZERO,P0001,P1,P25,P5,P75,ONE 5355 + /0.0D0,0.00010D0,0.10D0,0.250D0, 5356 + 0.50D0,0.750D0,1.0D0/ 5357 DATA 5358 + LUDFLT 5359 + /6/ 5360 5361C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 5362C FCN: THE USER SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 5363 5364C...VARIABLE DEFINITIONS (ALPHABETICALLY) 5365C ACCESS: THE VARIABLE DESIGNATING WHETHER INFORMATION IS TO BE 5366C ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR STORED IN 5367C THEM (ACCESS=FALSE). 5368C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. 5369C ACTRS: THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. 5370C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. 5371C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED 5372C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). 5373C BETA: THE FUNCTION PARAMETERS. 5374C BETAC: THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. 5375C BETAN: THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. 5376C BETAS: THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. 5377C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED 5378C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD 5379C DIFFERENCES (CDJAC=FALSE). 5380C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED 5381C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT 5382C (CHKJAC=FALSE). 5383C CNVPAR: THE VARIABLE DESIGNATING WHETHER PARAMETER CONVERGENCE WAS 5384C ATTAINED (CNVPAR=TRUE) OR NOT (CNVPAR=FALSE). 5385C CNVSS: THE VARIABLE DESIGNATING WHETHER SUM-OF-SQUARES CONVERGENCE 5386C WAS ATTAINED (CNVSS=TRUE) OR NOT (CNVSS=FALSE). 5387C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 5388C DELTAN: THE NEW ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 5389C DELTAS: THE SAVED ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 5390C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS 5391C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). 5392C DIRDER: THE DIRECTIONAL DERIVATIVE. 5393C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX 5394C SHOULD TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). 5395C ETA: THE RELATIVE NOISE IN THE FUNCTION RESULTS. 5396C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. 5397C FJACB: THE JACOBIAN WITH RESPECT TO BETA. 5398C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. 5399C FN: THE NEW PREDICTED VALUES FROM THE FUNCTION. 5400C FS: THE SAVED PREDICTED VALUES FROM THE FUNCTION. 5401C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 5402C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). 5403C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 5404C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). 5405C I: AN INDEXING VARIABLE. 5406C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF 5407C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE 5408C NUMBER OF PARAMETERS BEING ESTIMATED. 5409C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 5410C FIXED AT THEIR INPUT VALUES OR NOT. 5411C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 5412C FIXED AT THEIR INPUT VALUES OR NOT. 5413C IFLAG: THE VARIABLE DESIGNATING WHICH REPORT IS TO BE PRINTED. 5414C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 5415C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 5416C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 5417C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO 5418C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M 5419C ELEMENTS OF ARRAY WORK (INITD=FALSE). 5420C INT2: THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN. 5421C INTDBL: THE VARIABLE DESIGNATING WHETHER INTERNAL DOUBLING IS TO BE 5422C USED (INTDBL=TRUE) OR NOT (INTDBL=FALSE). 5423C IPR: THE VALUES DESIGNATING THE LENGTH OF THE PRINTED REPORT. 5424C IPR1: THE VALUE OF THE 4TH DIGIT (FROM THE RIGHT) OF IPRINT, 5425C WHICH CONTROLS THE INITIAL SUMMARY REPORT. 5426C IPR2: THE VALUE OF THE 3RD DIGIT (FROM THE RIGHT) OF IPRINT, 5427C WHICH CONTROLS THE ITERATION REPORT. 5428C IPR2F: THE VALUE OF THE 2ND DIGIT (FROM THE RIGHT) OF IPRINT, 5429C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. 5430C IPR3: THE VALUE OF THE 1ST DIGIT (FROM THE RIGHT) OF IPRINT, 5431C WHICH CONTROLS THE FINAL SUMMARY REPORT. 5432C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. 5433C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 5434C (ISODR=TRUE) OR OLS (ISODR=FALSE). 5435C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 5436C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 5437C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE 5438C STOPED DUE TO SOME NUMERICAL ERROR WITHIN ROUTINE DODSTP. 5439C IWORK: THE INTEGER WORK SPACE. 5440C IWRK: AN INDEX VARIABLE. 5441C J: AN INDEX VARIABLE. 5442C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 5443C COMPUTATIONAL METHOD. 5444C JPVT: THE STARTING LOCATION IN IWORK OF ARRAY JPVT. 5445C L: AN INDEX VARIABLE. 5446C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 5447C LDTT: THE LEADING DIMENSION OF ARRAY TT. 5448C LDWD: THE LEADING DIMENSION OF ARRAY WD. 5449C LDWE: THE LEADING DIMENSION OF ARRAY WE AND WE1. 5450C LDX: THE LEADING DIMENSION OF ARRAY X. 5451C LDY: THE LEADING DIMENSION OF ARRAY Y. 5452C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 5453C LD2WE: THE SECOND DIMENSION OF ARRAY WE AND WE1. 5454C LIWORK: THE LENGTH OF VECTOR IWORK. 5455C LOOPED: A COUNTER USED TO DETERMINE HOW MANY TIMES THE SUBLOOP 5456C HAS BEEN EXECUTED, WHERE IF THE COUNT BECOMES LARGE 5457C ENOUGH THE COMPUTATIONS WILL BE STOPPED. 5458C LSTEP: THE VARIABLE DESIGNATING WHETHER A SUCCESSFUL STEP HAS 5459C BEEN FOUND (LSTEP=TRUE) OR NOT (LSTEP=FALSE). 5460C LUDFLT: THE DEFAULT LOGICAL UNIT NUMBER, USED FOR COMPUTATION 5461C REPORTS TO THE SCREEN. 5462C LUNR: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. 5463C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. 5464C LWORK: THE LENGTH OF VECTOR WORK. 5465C LWRK: THE LENGTH OF VECTOR WRK. 5466C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 5467C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 5468C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. 5469C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. 5470C N: THE NUMBER OF OBSERVATIONS. 5471C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. 5472C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 5473C NITER: THE NUMBER OF ITERATIONS TAKEN. 5474C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. 5475C NLMS: THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. 5476C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. 5477C NP: THE NUMBER OF FUNCTION PARAMETERS. 5478C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. 5479C NPR: THE NUMBER OF TIMES THE REPORT IS TO BE WRITTEN. 5480C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 5481C OLMAVG: THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER 5482C ITERATION. 5483C OMEGA: THE STARTING LOCATION IN WORK OF ARRAY OMEGA. 5484C ONE: THE VALUE 1.0D0. 5485C P0001: THE VALUE 0.0001D0. 5486C P1: THE VALUE 0.1D0. 5487C P25: THE VALUE 0.25D0. 5488C P5: THE VALUE 0.5D0. 5489C P75: THE VALUE 0.75D0. 5490C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. 5491C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. 5492C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. 5493C PRERS: THE OLD PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. 5494C PRTPEN: THE VALUE DESIGNATING WHETHER THE PENALTY PARAMETER IS TO 5495C BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 5496C (PRTPEN=FALSE). 5497C QRAUX: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. 5498C RATIO: THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED 5499C RELATIVE REDUCTION IN THE SUM-OF-SQUARES. 5500C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. 5501C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO 5502C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 5503C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). 5504C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 5505C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). 5506C RNORM: THE NORM OF THE WEIGHTED ERRORS. 5507C RNORMN: THE NEW NORM OF THE WEIGHTED ERRORS. 5508C RNORMS: THE SAVED NORM OF THE WEIGHTED ERRORS. 5509C RSS: THE RESIDUAL SUM OF SQUARES. 5510C RVAR: THE RESIDUAL VARIANCE. 5511C S: THE STEP FOR BETA. 5512C SD: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. 5513C SS: THE SCALING VALUES USED FOR THE UNFIXED BETAS. 5514C SSF: THE SCALING VALUES USED FOR BETA. 5515C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. 5516C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE 5517C DERIVATIVES WITH RESPECT TO EACH BETA. 5518C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE 5519C DERIVATIVES WITH RESPECT TO DELTA. 5520C T: THE STEP FOR DELTA. 5521C TAU: THE TRUST REGION DIAMETER. 5522C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 5523C DIAMETER. 5524C TEMP: A TEMPORARY STORAGE LOCATION. 5525C TEMP1: A TEMPORARY STORAGE LOCATION. 5526C TEMP2: A TEMPORARY STORAGE LOCATION. 5527C TSNORM: THE NORM OF THE SCALED STEP. 5528C TT: THE SCALING VALUES USED FOR DELTA. 5529C U: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. 5530C VCV: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. 5531C WE: THE EPSILON WEIGHTS. 5532C WE1: THE SQUARE ROOT OF THE EPSILON WEIGHTS. 5533C WD: THE DELTA WEIGHTS. 5534C WORK: THE DOUBLE PRECISION WORK SPACE. 5535C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, 5536C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND 5537C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. 5538C WRK: A WORK ARRAY, EQUIVALENCED TO WRK1 AND WRK2 5539C WRK1: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. 5540C WRK2: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. 5541C WRK3: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. 5542C WRK4: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. 5543C WRK5: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. 5544C WRK6: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. 5545C X: THE EXPLANATORY VARIABLE. 5546C XPLUSD: THE VALUES OF X + DELTA. 5547C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. 5548C ZERO: THE VALUE 0.0D0. 5549 5550 5551C***FIRST EXECUTABLE STATEMENT DODMN 5552 5553 5554C INITIALIZE NECESSARY VARIABLES 5555 5556 CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, 5557 + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) 5558 ACCESS = .TRUE. 5559 CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, 5560 + WORK,LWORK,IWORK,LIWORK, 5561 + ACCESS,ISODR, 5562 + JPVT,OMEGA,U,QRAUX,SD,VCV, 5563 + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, 5564 + NNZW,NPP, 5565 + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, 5566 + LUNRPT,IPR1,IPR2,IPR2F,IPR3, 5567 + WSS,RVAR,IDF, 5568 + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, 5569 + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) 5570 RNORM = SQRT(WSS(1)) 5571 5572 DIDVCV = .FALSE. 5573 INTDBL = .FALSE. 5574 LSTEP = .TRUE. 5575 5576C PRINT INITIAL SUMMARY IF DESIRED 5577 5578 IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN 5579 IFLAG = 1 5580 IF (IPR1.GE.3 .AND. LUNRPT.NE.LUDFLT) THEN 5581 NPR = 2 5582 ELSE 5583 NPR = 1 5584 END IF 5585 IF (IPR1.GE.6) THEN 5586 IPR = 2 5587 ELSE 5588 IPR = 2 - MOD(IPR1,2) 5589 END IF 5590 LUNR = LUNRPT 5591 DO 10 I=1,NPR 5592 CALL DODPCR(IPR,LUNR, 5593 + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, 5594 + N,M,NP,NQ,NPP,NNZW, 5595 + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, 5596 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, 5597 + IFIXB,IFIXX,LDIFX, 5598 + SSF,TT,LDTT,STPB,STPD,LDSTPD, 5599 + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, 5600 + WSS,RVAR,IDF,WORK(SD), 5601 + NITER,NFEV,NJEV,ACTRED,PRERED, 5602 + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) 5603 IF (IPR1.GE.5) THEN 5604 IPR = 2 5605 ELSE 5606 IPR = 1 5607 END IF 5608 LUNR = LUDFLT 5609 10 CONTINUE 5610 5611 END IF 5612 5613C STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION 5614 5615 IF (RNORM.EQ.ZERO) THEN 5616 INFO = 1 5617 OLMAVG = ZERO 5618 ISTOP = 0 5619 GO TO 150 5620 END IF 5621 5622C STOP IF NUMBER OF ITERATIONS ALREADY EQUALS MAXIMUM PERMITTED 5623 5624 IF (RESTRT .AND. (NITER.GE.MAXIT)) THEN 5625 ISTOP = 0 5626 GO TO 150 5627 ELSE IF (NITER.GE.MAXIT) THEN 5628 INFO = 4 5629 ISTOP = 0 5630 GO TO 150 5631 END IF 5632 5633C MAIN LOOP 5634 5635 100 CONTINUE 5636 5637 NITER = NITER + 1 5638 RNORMS = RNORM 5639 LOOPED = 0 5640 5641C EVALUATE JACOBIAN USING BEST ESTIMATE OF FUNCTION (FS) 5642 5643 IF ((NITER.EQ.1) .AND. (ANAJAC.AND.CHKJAC)) THEN 5644 ISTOP = 0 5645 ELSE 5646 CALL DEVJAC(FCN, 5647 + ANAJAC,CDJAC, 5648 + N,M,NP,NQ, 5649 + BETAC,BETA,STPB, 5650 + IFIXB,IFIXX,LDIFX, 5651 + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, 5652 + SSF,TT,LDTT,NETA,FS, 5653 + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), 5654 + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, 5655 + NJEV,NFEV,ISTOP,INFO) 5656 END IF 5657 IF (ISTOP.NE.0) THEN 5658 INFO = 51000 5659 GO TO 200 5660 ELSE IF (INFO.EQ.50300) THEN 5661 GO TO 200 5662 END IF 5663 5664C SUB LOOP FOR 5665C INTERNAL DOUBLING OR 5666C COMPUTING NEW STEP WHEN OLD FAILED 5667 5668 110 CONTINUE 5669 5670C COMPUTE STEPS S AND T 5671 5672 IF (LOOPED.GT.100) THEN 5673 INFO = 60000 5674 GO TO 200 5675 ELSE 5676 LOOPED = LOOPED + 1 5677 CALL DODLM(N,M,NP,NQ,NPP, 5678 + F,FJACB,FJACD, 5679 + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, 5680 + ALPHA,TAU,ETA,ISODR, 5681 + WORK(WRK6),WORK(OMEGA), 5682 + WORK(U),WORK(QRAUX),IWORK(JPVT), 5683 + S,T,NLMS,RCOND,IRANK, 5684 + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), 5685 + WORK(WRK5),WRK,LWRK,ISTOPC) 5686 END IF 5687 IF (ISTOPC.NE.0) THEN 5688 INFO = ISTOPC 5689 GO TO 200 5690 END IF 5691 OLMAVG = OLMAVG+NLMS 5692 5693C COMPUTE BETAN = BETAC + S 5694C DELTAN = DELTA + T 5695 5696 CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP) 5697 IF (ISODR) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N) 5698 5699C COMPUTE NORM OF SCALED STEPS S AND T (TSNORM) 5700 5701 CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) 5702 IF (ISODR) THEN 5703 CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) 5704 TSNORM = DNRM2(NPP+N*M,WRK,1) 5705 ELSE 5706 TSNORM = DNRM2(NPP,WRK,1) 5707 END IF 5708 5709C COMPUTE SCALED PREDICTED REDUCTION 5710 5711 IWRK = 0 5712 DO 130 L=1,NQ 5713 DO 120 I=1,N 5714 IWRK = IWRK + 1 5715 WRK(IWRK) = DDOT(NPP,FJACB(I,1,L),N,S,1) 5716 IF (ISODR) WRK(IWRK) = WRK(IWRK) + 5717 + DDOT(M,FJACD(I,1,L),N,T(I,1),N) 5718 120 CONTINUE 5719 130 CONTINUE 5720 IF (ISODR) THEN 5721 CALL DWGHT(N,M,WD,LDWD,LD2WD,T,N,WRK(N*NQ+1),N) 5722 TEMP1 = DDOT(N*NQ,WRK,1,WRK,1) + DDOT(N*M,T,1,WRK(N*NQ+1),1) 5723 TEMP1 = SQRT(TEMP1)/RNORM 5724 ELSE 5725 TEMP1 = DNRM2(N*NQ,WRK,1)/RNORM 5726 END IF 5727 TEMP2 = SQRT(ALPHA)*TSNORM/RNORM 5728 PRERED = TEMP1**2+TEMP2**2/P5 5729 5730 DIRDER = -(TEMP1**2+TEMP2**2) 5731 5732C EVALUATE PREDICTED VALUES AT NEW POINT 5733 5734 CALL DUNPAC(NP,BETAN,BETA,IFIXB) 5735 CALL DXPY(N,M,X,LDX,DELTAN,N,XPLUSD,N) 5736 ISTOP = 0 5737 CALL FCN(N,M,NP,NQ, 5738 + N,M,NP, 5739 + BETA,XPLUSD, 5740 + IFIXB,IFIXX,LDIFX, 5741 + 002,FN,WORK(WRK6),WORK(WRK1), 5742 + ISTOP) 5743 IF (ISTOP.EQ.0) THEN 5744 NFEV = NFEV + 1 5745 END IF 5746 5747 IF (ISTOP.LT.0) THEN 5748 5749C SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FCN 5750 5751 INFO = 51000 5752 GO TO 200 5753 ELSE IF (ISTOP.GT.0) THEN 5754 5755C SET NORM TO INDICATE STEP SHOULD BE REJECTED 5756 5757 RNORMN = RNORM/(P1*P75) 5758 ELSE 5759 5760C COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN) 5761 5762 IF (IMPLCT) THEN 5763 CALL DCOPY(N*NQ,FN,1,WRK,1) 5764 ELSE 5765 CALL DXMY(N,NQ,FN,N,Y,LDY,WRK,N) 5766 END IF 5767 CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,WRK,N,WRK,N) 5768 IF (ISODR) THEN 5769 CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTAN,N,WRK(N*NQ+1),N) 5770 RNORMN = SQRT(DDOT(N*NQ,WRK,1,WRK,1) + 5771 + DDOT(N*M,DELTAN,1,WRK(N*NQ+1),1)) 5772 ELSE 5773 RNORMN = DNRM2(N*NQ,WRK,1) 5774 END IF 5775 END IF 5776 5777C COMPUTE SCALED ACTUAL REDUCTION 5778 5779 IF (P1*RNORMN.LT.RNORM) THEN 5780 ACTRED = ONE - (RNORMN/RNORM)**2 5781 ELSE 5782 ACTRED = -ONE 5783 END IF 5784 5785C COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION 5786 5787 IF(PRERED .EQ. ZERO) THEN 5788 RATIO = ZERO 5789 ELSE 5790 RATIO = ACTRED/PRERED 5791 END IF 5792 5793C CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE 5794 5795 IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN 5796 ISTOP = 0 5797 TAU = TAU*P5 5798 ALPHA = ALPHA/P5 5799 CALL DCOPY(NPP,BETAS,1,BETAN,1) 5800 CALL DCOPY(N*M,DELTAS,1,DELTAN,1) 5801 CALL DCOPY(N*NQ,FS,1,FN,1) 5802 ACTRED = ACTRS 5803 PRERED = PRERS 5804 RNORMN = RNORMS 5805 RATIO = P5 5806 END IF 5807 5808C UPDATE STEP BOUND 5809 5810 INTDBL = .FALSE. 5811 IF (RATIO.LT.P25) THEN 5812 IF (ACTRED.GE.ZERO) THEN 5813 TEMP = P5 5814 ELSE 5815 TEMP = P5*DIRDER/(DIRDER+P5*ACTRED) 5816 END IF 5817 IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN 5818 TEMP = P1 5819 END IF 5820 TAU = TEMP*MIN(TAU,TSNORM/P1) 5821 ALPHA = ALPHA/TEMP 5822 5823 ELSE IF (ALPHA.EQ.ZERO) THEN 5824 TAU = TSNORM/P5 5825 5826 ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN 5827 5828C STEP QUALIFIES FOR INTERNAL DOUBLING 5829C - UPDATE TAU AND ALPHA 5830C - SAVE INFORMATION FOR CURRENT POINT 5831 5832 INTDBL = .TRUE. 5833 5834 TAU = TSNORM/P5 5835 ALPHA = ALPHA*P5 5836 5837 CALL DCOPY(NPP,BETAN,1,BETAS,1) 5838 CALL DCOPY(N*M,DELTAN,1,DELTAS,1) 5839 CALL DCOPY(N*NQ,FN,1,FS,1) 5840 ACTRS = ACTRED 5841 PRERS = PRERED 5842 RNORMS = RNORMN 5843 END IF 5844 5845C IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS 5846 5847 IF (INTDBL .AND. TAU.GT.ZERO) THEN 5848 INT2 = INT2+1 5849 GO TO 110 5850 END IF 5851 5852C CHECK ACCEPTANCE 5853 5854 IF (RATIO.GE.P0001) THEN 5855 CALL DCOPY(N*NQ,FN,1,FS,1) 5856 IF (IMPLCT) THEN 5857 CALL DCOPY(N*NQ,FS,1,F,1) 5858 ELSE 5859 CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) 5860 END IF 5861 CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,F,N) 5862 CALL DCOPY(NPP,BETAN,1,BETAC,1) 5863 CALL DCOPY(N*M,DELTAN,1,DELTA,1) 5864 RNORM = RNORMN 5865 CALL DWGHT(NPP,1,SS,NPP,1,BETAC,NPP,WRK,NPP) 5866 IF (ISODR) THEN 5867 CALL DWGHT(N,M,TT,LDTT,1,DELTA,N,WRK(NPP+1),N) 5868 PNORM = DNRM2(NPP+N*M,WRK,1) 5869 ELSE 5870 PNORM = DNRM2(NPP,WRK,1) 5871 END IF 5872 LSTEP = .TRUE. 5873 ELSE 5874 LSTEP = .FALSE. 5875 END IF 5876 5877C TEST CONVERGENCE 5878 5879 INFO = 0 5880 CNVSS = RNORM.EQ.ZERO 5881 + .OR. 5882 + (ABS(ACTRED).LE.SSTOL .AND. 5883 + PRERED.LE.SSTOL .AND. 5884 + P5*RATIO.LE.ONE) 5885 CNVPAR = (TAU.LE.PARTOL*PNORM) .AND. (.NOT.IMPLCT) 5886 IF (CNVSS) INFO = 1 5887 IF (CNVPAR) INFO = 2 5888 IF (CNVSS .AND. CNVPAR) INFO = 3 5889 5890C PRINT ITERATION REPORT 5891 5892 IF (INFO.NE.0 .OR. LSTEP) THEN 5893 IF (IPR2.NE.0 .AND. IPR2F.NE.0 .AND. LUNRPT.NE.0) THEN 5894 IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN 5895 IFLAG = 2 5896 CALL DUNPAC(NP,BETAC,BETA,IFIXB) 5897 WSS(1) = RNORM*RNORM 5898 IF (IPR2.GE.3. AND. LUNRPT.NE.LUDFLT) THEN 5899 NPR = 2 5900 ELSE 5901 NPR = 1 5902 END IF 5903 IF (IPR2.GE.6) THEN 5904 IPR = 2 5905 ELSE 5906 IPR = 2 - MOD(IPR2,2) 5907 END IF 5908 LUNR = LUNRPT 5909 DO 140 I=1,NPR 5910 CALL DODPCR(IPR,LUNR, 5911 + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, 5912 + N,M,NP,NQ,NPP,NNZW, 5913 + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, 5914 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, 5915 + IFIXB,IFIXX,LDIFX, 5916 + SSF,TT,LDTT,STPB,STPD,LDSTPD, 5917 + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, 5918 + WSS,RVAR,IDF,WORK(SD), 5919 + NITER,NFEV,NJEV,ACTRED,PRERED, 5920 + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) 5921 IF (IPR2.GE.5) THEN 5922 IPR = 2 5923 ELSE 5924 IPR = 1 5925 END IF 5926 LUNR = LUDFLT 5927 140 CONTINUE 5928 FSTITR = .FALSE. 5929 PRTPEN = .FALSE. 5930 END IF 5931 END IF 5932 END IF 5933 5934C CHECK IF FINISHED 5935 5936 IF (INFO.EQ.0) THEN 5937 IF (LSTEP) THEN 5938 5939C BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET 5940 5941 IF (NITER.GE.MAXIT) THEN 5942 INFO = 4 5943 ELSE 5944 GO TO 100 5945 END IF 5946 ELSE 5947 5948C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET 5949 5950 GO TO 110 5951 END IF 5952 END IF 5953 5954 150 CONTINUE 5955 5956 IF (ISTOP.GT.0) INFO = INFO + 100 5957 5958C STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER 5959 5960 IF (IMPLCT) THEN 5961 CALL DCOPY(N*NQ,FS,1,F,1) 5962 ELSE 5963 CALL DXMY(N,NQ,FS,N,Y,LDY,F,N) 5964 END IF 5965 CALL DUNPAC(NP,BETAC,BETA,IFIXB) 5966 CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N) 5967 5968C COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS 5969C IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED 5970 5971 IF (DOVCV .AND. ISTOP.EQ.0) THEN 5972 5973C RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED 5974C OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED 5975C TO COMPUTE COVARIANCE MATRIX 5976 5977 IF (REDOJ) THEN 5978 CALL DEVJAC(FCN, 5979 + ANAJAC,CDJAC, 5980 + N,M,NP,NQ, 5981 + BETAC,BETA,STPB, 5982 + IFIXB,IFIXX,LDIFX, 5983 + X,LDX,DELTA,XPLUSD,STPD,LDSTPD, 5984 + SSF,TT,LDTT,NETA,FS, 5985 + T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6), 5986 + FJACB,ISODR,FJACD,WE1,LDWE,LD2WE, 5987 + NJEV,NFEV,ISTOP,INFO) 5988 5989 5990 IF (ISTOP.NE.0) THEN 5991 INFO = 51000 5992 GO TO 200 5993 ELSE IF (INFO.EQ.50300) THEN 5994 GO TO 200 5995 END IF 5996 END IF 5997 5998 IF (IMPLCT) THEN 5999 CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) 6000 RSS = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) 6001 ELSE 6002 RSS = RNORM*RNORM 6003 END IF 6004 IF (REDOJ .OR. NITER.GE.1) THEN 6005 CALL DODVCV(N,M,NP,NQ,NPP, 6006 + F,FJACB,FJACD, 6007 + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, 6008 + ETA,ISODR, 6009 + WORK(VCV),WORK(SD), 6010 + WORK(WRK6),WORK(OMEGA), 6011 + WORK(U),WORK(QRAUX),IWORK(JPVT), 6012 + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, 6013 + WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK4), 6014 + WORK(WRK5),WRK,LWRK,ISTOPC) 6015 IF (ISTOPC.NE.0) THEN 6016 INFO = ISTOPC 6017 GO TO 200 6018 END IF 6019 DIDVCV = .TRUE. 6020 END IF 6021 6022 END IF 6023 6024C SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS 6025 6026 200 DO 210 I=0,NP-1 6027 WORK(WRK3+I) = IWORK(JPVT+I) 6028 IWORK(JPVT+I) = -2 6029 210 CONTINUE 6030 IF (REDOJ .OR. NITER.GE.1) THEN 6031 DO 220 I=0,NPP-1 6032 J = WORK(WRK3+I) - 1 6033 IF (I.LE.NPP-IRANK-1) THEN 6034 IWORK(JPVT+J) = 1 6035 ELSE 6036 IWORK(JPVT+J) = -1 6037 END IF 6038 220 CONTINUE 6039 IF (NPP.LT.NP) THEN 6040 J = NPP-1 6041 DO 230 I=NP-1,0,-1 6042 IF (IFIXB(I+1).EQ.0) THEN 6043 IWORK(JPVT+I) = 0 6044 ELSE 6045 IWORK(JPVT+I) = IWORK(JPVT+J) 6046 J = J - 1 6047 END IF 6048 230 CONTINUE 6049 END IF 6050 END IF 6051 6052C STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER 6053 6054 IF (NITER.GE.1) THEN 6055 OLMAVG = OLMAVG/NITER 6056 ELSE 6057 OLMAVG = ZERO 6058 END IF 6059 6060C COMPUTE WEIGHTED SUMS OF SQUARES FOR RETURN TO USER 6061 6062 CALL DWGHT(N,NQ,WE1,LDWE,LD2WE,F,N,WRK,N) 6063 WSS(3) = DDOT(N*NQ,WRK,1,WRK,1) 6064 IF (ISODR) THEN 6065 CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N) 6066 WSS(2) = DDOT(N*M,DELTA,1,WRK(N*NQ+1),1) 6067 ELSE 6068 WSS(2) = ZERO 6069 END IF 6070 WSS(1) = WSS(2) + WSS(3) 6071 6072 ACCESS = .FALSE. 6073 CALL DACCES(N,M,NP,NQ,LDWE,LD2WE, 6074 + WORK,LWORK,IWORK,LIWORK, 6075 + ACCESS,ISODR, 6076 + JPVT,OMEGA,U,QRAUX,SD,VCV, 6077 + WRK1,WRK2,WRK3,WRK4,WRK5,WRK6, 6078 + NNZW,NPP, 6079 + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,ETA,NETA, 6080 + LUNRPT,IPR1,IPR2,IPR2F,IPR3, 6081 + WSS,RVAR,IDF, 6082 + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, 6083 + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS,ISTOP) 6084 6085C ENCODE EXISTENCE OF QUESTIONABLE RESULTS INTO INFO 6086 6087 IF (INFO.LE.9 .OR. INFO.GE.60000) THEN 6088 IF (MSGB(1).EQ.1 .OR. MSGD(1).EQ.1) THEN 6089 INFO = INFO + 1000 6090 END IF 6091 IF (ISTOP.NE.0) THEN 6092 INFO = INFO + 100 6093 END IF 6094 IF (IRANK.GE.1) THEN 6095 IF (NPP.GT.IRANK) THEN 6096 INFO = INFO + 10 6097 ELSE 6098 INFO = INFO + 20 6099 END IF 6100 END IF 6101 END IF 6102 6103C PRINT FINAL SUMMARY 6104 6105 IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN 6106 IFLAG = 3 6107 6108 IF (IPR3.GE.3. AND. LUNRPT.NE.LUDFLT) THEN 6109 NPR = 2 6110 ELSE 6111 NPR = 1 6112 END IF 6113 IF (IPR3.GE.6) THEN 6114 IPR = 2 6115 ELSE 6116 IPR = 2 - MOD(IPR3,2) 6117 END IF 6118 LUNR = LUNRPT 6119 DO 240 I=1,NPR 6120 CALL DODPCR(IPR,LUNR, 6121 + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, 6122 + N,M,NP,NQ,NPP,NNZW, 6123 + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, 6124 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, 6125 + IWORK(JPVT),IFIXX,LDIFX, 6126 + SSF,TT,LDTT,STPB,STPD,LDSTPD, 6127 + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, 6128 + WSS,RVAR,IDF,WORK(SD), 6129 + NITER,NFEV,NJEV,ACTRED,PRERED, 6130 + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) 6131 IF (IPR3.GE.5) THEN 6132 IPR = 2 6133 ELSE 6134 IPR = 1 6135 END IF 6136 LUNR = LUDFLT 6137 240 CONTINUE 6138 END IF 6139 6140 RETURN 6141 6142 END 6143*DODPC1 6144 SUBROUTINE DODPC1 6145 + (IPR,LUNRPT, 6146 + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, 6147 + MSGB1,MSGB,MSGD1,MSGD, 6148 + N,M,NP,NQ,NPP,NNZW, 6149 + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, 6150 + Y,LDY,WE,LDWE,LD2WE,PNLTY, 6151 + BETA,IFIXB,SSF,STPB, 6152 + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, 6153 + WSS,WSSDEL,WSSEPS) 6154C***BEGIN PROLOGUE DODPC1 6155C***REFER TO DODR,DODRC 6156C***ROUTINES CALLED DHSTEP 6157C***DATE WRITTEN 860529 (YYMMDD) 6158C***REVISION DATE 920619 (YYMMDD) 6159C***PURPOSE GENERATE INITIAL SUMMARY REPORT 6160C***END PROLOGUE DODPC1 6161 6162C...SCALAR ARGUMENTS 6163 DOUBLE PRECISION 6164 + PARTOL,PNLTY,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS 6165 INTEGER 6166 + IPR,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE, 6167 + LUNRPT,M,MAXIT,MSGB1,MSGD1,N,NETA,NNZW,NP,NPP,NQ 6168 LOGICAL 6169 + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT 6170 6171C...ARRAY ARGUMENTS 6172 DOUBLE PRECISION 6173 + BETA(NP),DELTA(N,M),SSF(NP),STPB(NP),STPD(LDSTPD,M), 6174 + TT(LDTT,M),WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),X(LDX,M), 6175 + Y(LDY,NQ) 6176 INTEGER 6177 + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ,NP),MSGD(NQ,M) 6178 6179C...LOCAL SCALARS 6180 DOUBLE PRECISION 6181 + TEMP1,TEMP2,TEMP3,ZERO 6182 INTEGER 6183 + I,ITEMP,J,JOB1,JOB2,JOB3,JOB4,JOB5,L 6184 6185C...LOCAL ARRAYS 6186 CHARACTER TEMPC0*2,TEMPC1*5,TEMPC2*13 6187 6188C...EXTERNAL FUNCTIONS 6189 DOUBLE PRECISION 6190 + DHSTEP 6191 EXTERNAL 6192 + DHSTEP 6193 6194 6195C...INTRINSIC FUNCTIONS 6196 INTRINSIC 6197 + ABS,MIN 6198 6199C...DATA STATEMENTS 6200 DATA 6201 + ZERO 6202 + /0.0D0/ 6203 6204C...VARIABLE DEFINITIONS (ALPHABETICALLY) 6205C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED 6206C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). 6207C BETA: THE FUNCTION PARAMETERS. 6208C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED 6209C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR FORWARD DIFFERENCES 6210C (CDJAC=FALSE). 6211C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED 6212C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT 6213C (CHKJAC=FALSE). 6214C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 6215C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 6216C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). 6217C I: AN INDEXING VARIABLE. 6218C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 6219C FIXED AT THEIR INPUT VALUES OR NOT. 6220C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 6221C FIXED AT THEIR INPUT VALUES OR NOT. 6222C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 6223C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 6224C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO 6225C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M 6226C ELEMENTS OF ARRAY WORK (INITD=FALSE). 6227C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. 6228C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 6229C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 6230C ITEMP: A TEMPORARY INTEGER VALUE. 6231C J: AN INDEXING VARIABLE. 6232C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 6233C COMPUTATIONAL METHOD. 6234C JOB1: THE 1ST DIGIT (FROM THE LEFT) OF VARIABLE JOB. 6235C JOB2: THE 2ND DIGIT (FROM THE LEFT) OF VARIABLE JOB. 6236C JOB3: THE 3RD DIGIT (FROM THE LEFT) OF VARIABLE JOB. 6237C JOB4: THE 4TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. 6238C JOB5: THE 5TH DIGIT (FROM THE LEFT) OF VARIABLE JOB. 6239C L: AN INDEXING VARIABLE. 6240C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 6241C LDTT: THE LEADING DIMENSION OF ARRAY TT. 6242C LDWD: THE LEADING DIMENSION OF ARRAY WD. 6243C LDWE: THE LEADING DIMENSION OF ARRAY WE. 6244C LDX: THE LEADING DIMENSION OF ARRAY X. 6245C LDY: THE LEADING DIMENSION OF ARRAY Y. 6246C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 6247C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 6248C LUNRPT: THE LOGICAL UNIT NUMBER FOR THE COMPUTATION REPORTS. 6249C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 6250C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 6251C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. 6252C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. 6253C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. 6254C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. 6255C N: THE NUMBER OF OBSERVATIONS. 6256C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. 6257C A NEGATIVE VALUE INDICATES THAT NETA WAS ESTIMATED BY 6258C ODRPACK. A POSITIVE VALUE INDICTES THE VALUE WAS SUPPLIED 6259C BY THE USER. 6260C NNZW: THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. 6261C NP: THE NUMBER OF FUNCTION PARAMETERS. 6262C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. 6263C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 6264C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. 6265C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. 6266C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO 6267C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 6268C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). 6269C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 6270C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). 6271C SSF: THE SCALING VALUES FOR BETA. 6272C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. 6273C STPB: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE 6274C DERIVATIVES WITH RESPECT TO BETA. 6275C STPD: THE RELATIVE STEP USED FOR COMPUTING FINITE DIFFERENCE 6276C DERIVATIVES WITH RESPECT TO DELTA. 6277C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 6278C DIAMETER. 6279C TEMPC0: A TEMPORARY CHARACTER*2 VALUE. 6280C TEMPC1: A TEMPORARY CHARACTER*5 VALUE. 6281C TEMPC2: A TEMPORARY CHARACTER*13 VALUE. 6282C TEMP1: A TEMPORARY DOUBLE PRECISION VALUE. 6283C TEMP2: A TEMPORARY DOUBLE PRECISION VALUE. 6284C TEMP3: A TEMPORARY DOUBLE PRECISION VALUE. 6285C TT: THE SCALING VALUES FOR DELTA. 6286C WD: THE DELTA WEIGHTS. 6287C WE: THE EPSILON WEIGHTS. 6288C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. 6289C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. 6290C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. 6291C X: THE EXPLANATORY VARIABLE. 6292C Y: THE RESPONSE VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. 6293C ZERO: THE VALUE 0.0D0. 6294 6295 6296C***FIRST EXECUTABLE STATEMENT DODPC1 6297 6298 6299C PRINT PROBLEM SIZE SPECIFICATION 6300 6301 WRITE (LUNRPT,1000) N,NNZW,NQ,M,NP,NPP 6302 6303 6304C PRINT CONTROL VALUES 6305 6306 JOB1 = JOB/10000 6307 JOB2 = MOD(JOB,10000)/1000 6308 JOB3 = MOD(JOB,1000)/100 6309 JOB4 = MOD(JOB,100)/10 6310 JOB5 = MOD(JOB,10) 6311 WRITE (LUNRPT,1100) JOB 6312 IF (RESTRT) THEN 6313 WRITE (LUNRPT,1110) JOB1 6314 ELSE 6315 WRITE (LUNRPT,1111) JOB1 6316 END IF 6317 IF (ISODR) THEN 6318 IF (INITD) THEN 6319 WRITE (LUNRPT,1120) JOB2 6320 ELSE 6321 WRITE (LUNRPT,1121) JOB2 6322 END IF 6323 ELSE 6324 WRITE (LUNRPT,1122) JOB2,JOB5 6325 END IF 6326 IF (DOVCV) THEN 6327 WRITE (LUNRPT,1130) JOB3 6328 IF (REDOJ) THEN 6329 WRITE (LUNRPT,1131) 6330 ELSE 6331 WRITE (LUNRPT,1132) 6332 END IF 6333 ELSE 6334 WRITE (LUNRPT,1133) JOB3 6335 END IF 6336 IF (ANAJAC) THEN 6337 WRITE (LUNRPT,1140) JOB4 6338 IF (CHKJAC) THEN 6339 IF (MSGB1.GE.1 .OR. MSGD1.GE.1) THEN 6340 WRITE (LUNRPT,1141) 6341 ELSE 6342 WRITE (LUNRPT,1142) 6343 END IF 6344 ELSE 6345 WRITE (LUNRPT,1143) 6346 END IF 6347 ELSE IF (CDJAC) THEN 6348 WRITE (LUNRPT,1144) JOB4 6349 ELSE 6350 WRITE (LUNRPT,1145) JOB4 6351 END IF 6352 IF (ISODR) THEN 6353 IF (IMPLCT) THEN 6354 WRITE (LUNRPT,1150) JOB5 6355 ELSE 6356 WRITE (LUNRPT,1151) JOB5 6357 END IF 6358 ELSE 6359 WRITE (LUNRPT,1152) JOB5 6360 END IF 6361 IF (NETA.LT.0) THEN 6362 WRITE (LUNRPT,1200) -NETA 6363 ELSE 6364 WRITE (LUNRPT,1210) NETA 6365 END IF 6366 WRITE (LUNRPT,1300) TAUFAC 6367 6368 6369C PRINT STOPPING CRITERIA 6370 6371 WRITE (LUNRPT,1400) SSTOL,PARTOL,MAXIT 6372 6373 6374C PRINT INITIAL SUM OF SQUARES 6375 6376 IF (IMPLCT) THEN 6377 WRITE (LUNRPT,1500) WSSDEL 6378 IF (ISODR) THEN 6379 WRITE (LUNRPT,1510) WSS,WSSEPS,PNLTY 6380 END IF 6381 ELSE 6382 WRITE (LUNRPT,1600) WSS 6383 IF (ISODR) THEN 6384 WRITE (LUNRPT,1610) WSSDEL,WSSEPS 6385 END IF 6386 END IF 6387 6388 6389 IF (IPR.GE.2) THEN 6390 6391 6392C PRINT FUNCTION PARAMETER DATA 6393 6394 WRITE (LUNRPT,4000) 6395 IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN 6396 WRITE (LUNRPT,4110) 6397 ELSE IF (ANAJAC) THEN 6398 WRITE (LUNRPT,4120) 6399 ELSE 6400 WRITE (LUNRPT,4200) 6401 END IF 6402 DO 130 J=1,NP 6403 IF (IFIXB(1).LT.0) THEN 6404 TEMPC1 = ' NO' 6405 ELSE 6406 IF (IFIXB(J).NE.0) THEN 6407 TEMPC1 = ' NO' 6408 ELSE 6409 TEMPC1 = ' YES' 6410 END IF 6411 END IF 6412 IF (ANAJAC) THEN 6413 IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN 6414 ITEMP = -1 6415 DO 110 L=1,NQ 6416 ITEMP = MAX(ITEMP,MSGB(L,J)) 6417 110 CONTINUE 6418 IF (ITEMP.LE.-1) THEN 6419 TEMPC2 = ' UNCHECKED' 6420 ELSE IF (ITEMP.EQ.0) THEN 6421 TEMPC2 = ' VERIFIED' 6422 ELSE IF (ITEMP.GE.1) THEN 6423 TEMPC2 = ' QUESTIONABLE' 6424 END IF 6425 ELSE 6426 TEMPC2 = ' ' 6427 END IF 6428 ELSE 6429 TEMPC2 = ' ' 6430 END IF 6431 IF (SSF(1).LT.ZERO) THEN 6432 TEMP1 = ABS(SSF(1)) 6433 ELSE 6434 TEMP1 = SSF(J) 6435 END IF 6436 IF (ANAJAC) THEN 6437 WRITE (LUNRPT,4310) J,BETA(J),TEMPC1,TEMP1,TEMPC2 6438 ELSE 6439 IF (CDJAC) THEN 6440 TEMP2 = DHSTEP(1,NETA,1,J,STPB,1) 6441 ELSE 6442 TEMP2 = DHSTEP(0,NETA,1,J,STPB,1) 6443 END IF 6444 WRITE (LUNRPT,4320) J,BETA(J),TEMPC1,TEMP1,TEMP2 6445 END IF 6446 130 CONTINUE 6447 6448C PRINT EXPLANATORY VARIABLE DATA 6449 6450 IF (ISODR) THEN 6451 WRITE (LUNRPT,2010) 6452 IF (CHKJAC .AND. ((MSGB1.GE.1) .OR. (MSGD1.GE.1))) THEN 6453 WRITE (LUNRPT,2110) 6454 ELSE IF (ANAJAC) THEN 6455 WRITE (LUNRPT,2120) 6456 ELSE 6457 WRITE (LUNRPT,2130) 6458 END IF 6459 ELSE 6460 WRITE (LUNRPT,2020) 6461 WRITE (LUNRPT,2140) 6462 END IF 6463 IF (ISODR) THEN 6464 DO 240 J = 1,M 6465 TEMPC0 = '1,' 6466 DO 230 I=1,N,N-1 6467 6468 IF (IFIXX(1,1).LT.0) THEN 6469 TEMPC1 = ' NO' 6470 ELSE 6471 IF (LDIFX.EQ.1) THEN 6472 IF (IFIXX(1,J).EQ.0) THEN 6473 TEMPC1 = ' YES' 6474 ELSE 6475 TEMPC1 = ' NO' 6476 END IF 6477 ELSE 6478 IF (IFIXX(I,J).EQ.0) THEN 6479 TEMPC1 = ' YES' 6480 ELSE 6481 TEMPC1 = ' NO' 6482 END IF 6483 END IF 6484 END IF 6485 6486 IF (TT(1,1).LT.ZERO) THEN 6487 TEMP1 = ABS(TT(1,1)) 6488 ELSE 6489 IF (LDTT.EQ.1) THEN 6490 TEMP1 = TT(1,J) 6491 ELSE 6492 TEMP1 = TT(I,J) 6493 END IF 6494 END IF 6495 6496 IF (WD(1,1,1).LT.ZERO) THEN 6497 TEMP2 = ABS(WD(1,1,1)) 6498 ELSE 6499 IF (LDWD.EQ.1) THEN 6500 IF (LD2WD.EQ.1) THEN 6501 TEMP2 = WD(1,1,J) 6502 ELSE 6503 TEMP2 = WD(1,J,J) 6504 END IF 6505 ELSE 6506 IF (LD2WD.EQ.1) THEN 6507 TEMP2 = WD(I,1,J) 6508 ELSE 6509 TEMP2 = WD(I,J,J) 6510 END IF 6511 END IF 6512 END IF 6513 6514 IF (ANAJAC) THEN 6515 IF (CHKJAC .AND. 6516 + (((MSGB1.GE.1) .OR. (MSGD1.GE.1)) .AND. 6517 + (I.EQ.1))) THEN 6518 ITEMP = -1 6519 DO 210 L=1,NQ 6520 ITEMP = MAX(ITEMP,MSGD(L,J)) 6521 210 CONTINUE 6522 IF (ITEMP.LE.-1) THEN 6523 TEMPC2 = ' UNCHECKED' 6524 ELSE IF (ITEMP.EQ.0) THEN 6525 TEMPC2 = ' VERIFIED' 6526 ELSE IF (ITEMP.GE.1) THEN 6527 TEMPC2 = ' QUESTIONABLE' 6528 END IF 6529 ELSE 6530 TEMPC2 = ' ' 6531 END IF 6532 IF (M.LE.9) THEN 6533 WRITE (LUNRPT,5110) 6534 + TEMPC0,J,X(I,J), 6535 + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 6536 ELSE 6537 WRITE (LUNRPT,5120) 6538 + TEMPC0,J,X(I,J), 6539 + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMPC2 6540 END IF 6541 ELSE 6542 TEMPC2 = ' ' 6543 IF (CDJAC) THEN 6544 TEMP3 = DHSTEP(1,NETA,I,J,STPD,LDSTPD) 6545 ELSE 6546 TEMP3 = DHSTEP(0,NETA,I,J,STPD,LDSTPD) 6547 END IF 6548 IF (M.LE.9) THEN 6549 WRITE (LUNRPT,5210) 6550 + TEMPC0,J,X(I,J), 6551 + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 6552 ELSE 6553 WRITE (LUNRPT,5220) 6554 + TEMPC0,J,X(I,J), 6555 + DELTA(I,J),TEMPC1,TEMP1,TEMP2,TEMP3 6556 END IF 6557 END IF 6558 6559 TEMPC0 = 'N,' 6560 6561 230 CONTINUE 6562 IF (J.LT.M) WRITE (LUNRPT,6000) 6563 240 CONTINUE 6564 ELSE 6565 6566 DO 260 J = 1,M 6567 TEMPC0 = '1,' 6568 DO 250 I=1,N,N-1 6569 IF (M.LE.9) THEN 6570 WRITE (LUNRPT,5110) 6571 + TEMPC0,J,X(I,J) 6572 ELSE 6573 WRITE (LUNRPT,5120) 6574 + TEMPC0,J,X(I,J) 6575 END IF 6576 TEMPC0 = 'N,' 6577 250 CONTINUE 6578 IF (J.LT.M) WRITE (LUNRPT,6000) 6579 260 CONTINUE 6580 END IF 6581 6582C PRINT RESPONSE VARIABLE DATA AND OBSERVATION ERROR WEIGHTS 6583 6584 IF (.NOT.IMPLCT) THEN 6585 WRITE (LUNRPT,3000) 6586 WRITE (LUNRPT,3100) 6587 DO 310 L=1,NQ 6588 TEMPC0 = '1,' 6589 DO 300 I=1,N,N-1 6590 IF (WE(1,1,1).LT.ZERO) THEN 6591 TEMP1 = ABS(WE(1,1,1)) 6592 ELSE IF (LDWE.EQ.1) THEN 6593 IF (LD2WE.EQ.1) THEN 6594 TEMP1 = WE(1,1,L) 6595 ELSE 6596 TEMP1 = WE(1,L,L) 6597 END IF 6598 ELSE 6599 IF (LD2WE.EQ.1) THEN 6600 TEMP1 = WE(I,1,L) 6601 ELSE 6602 TEMP1 = WE(I,L,L) 6603 END IF 6604 END IF 6605 IF (NQ.LE.9) THEN 6606 WRITE (LUNRPT,5110) 6607 + TEMPC0,L,Y(I,L),TEMP1 6608 ELSE 6609 WRITE (LUNRPT,5120) 6610 + TEMPC0,L,Y(I,L),TEMP1 6611 END IF 6612 TEMPC0 = 'N,' 6613 300 CONTINUE 6614 IF (L.LT.NQ) WRITE (LUNRPT,6000) 6615 310 CONTINUE 6616 END IF 6617 END IF 6618 6619 RETURN 6620 6621C FORMAT STATEMENTS 6622 6623 1000 FORMAT 6624 + (/' --- PROBLEM SIZE:'/ 6625 + ' N = ',I5, 6626 + ' (NUMBER WITH NONZERO WEIGHT = ',I5,')'/ 6627 + ' NQ = ',I5/ 6628 + ' M = ',I5/ 6629 + ' NP = ',I5, 6630 + ' (NUMBER UNFIXED = ',I5,')') 6631 1100 FORMAT 6632 + (/' --- CONTROL VALUES:'/ 6633 + ' JOB = ',I5.5/ 6634 + ' = ABCDE, WHERE') 6635 1110 FORMAT 6636 + (' A=',I1,' ==> FIT IS A RESTART.') 6637 1111 FORMAT 6638 + (' A=',I1,' ==> FIT IS NOT A RESTART.') 6639 1120 FORMAT 6640 + (' B=',I1,' ==> DELTAS ARE INITIALIZED', 6641 + ' TO ZERO.') 6642 1121 FORMAT 6643 + (' B=',I1,' ==> DELTAS ARE INITIALIZED', 6644 + ' BY USER.') 6645 1122 FORMAT 6646 + (' B=',I1,' ==> DELTAS ARE FIXED AT', 6647 + ' ZERO SINCE E=',I1,'.') 6648 1130 FORMAT 6649 + (' C=',I1,' ==> COVARIANCE MATRIX WILL', 6650 + ' BE COMPUTED USING') 6651 1131 FORMAT 6652 + (' DERIVATIVES RE-', 6653 + 'EVALUATED AT THE SOLUTION.') 6654 1132 FORMAT 6655 + (' DERIVATIVES FROM THE', 6656 + ' LAST ITERATION.') 6657 1133 FORMAT 6658 + (' C=',I1,' ==> COVARIANCE MATRIX WILL', 6659 + ' NOT BE COMPUTED.') 6660 1140 FORMAT 6661 + (' D=',I1,' ==> DERIVATIVES ARE', 6662 + ' SUPPLIED BY USER.') 6663 1141 FORMAT 6664 + (' DERIVATIVES WERE CHECKED.'/ 6665 + ' RESULTS APPEAR QUESTIONABLE.') 6666 1142 FORMAT 6667 + (' DERIVATIVES WERE CHECKED.'/ 6668 + ' RESULTS APPEAR CORRECT.') 6669 1143 FORMAT 6670 + (' DERIVATIVES WERE NOT', 6671 + ' CHECKED.') 6672 1144 FORMAT 6673 + (' D=',I1,' ==> DERIVATIVES ARE', 6674 + ' ESTIMATED BY CENTRAL', 6675 + ' DIFFERENCES.') 6676 1145 FORMAT 6677 + (' D=',I1,' ==> DERIVATIVES ARE', 6678 + ' ESTIMATED BY FORWARD', 6679 + ' DIFFERENCES.') 6680 1150 FORMAT 6681 + (' E=',I1,' ==> METHOD IS IMPLICIT ODR.') 6682 1151 FORMAT 6683 + (' E=',I1,' ==> METHOD IS EXPLICIT ODR.') 6684 1152 FORMAT 6685 + (' E=',I1,' ==> METHOD IS EXPLICIT OLS.') 6686 1200 FORMAT 6687 + (' NDIGIT = ',I5,' (ESTIMATED BY ODRPACK)') 6688 1210 FORMAT 6689 + (' NDIGIT = ',I5,' (SUPPLIED BY USER)') 6690 1300 FORMAT 6691 + (' TAUFAC = ',1P,D12.2) 6692 1400 FORMAT 6693 + (/' --- STOPPING CRITERIA:'/ 6694 + ' SSTOL = ',1P,D12.2, 6695 + ' (SUM OF SQUARES STOPPING TOLERANCE)'/ 6696 + ' PARTOL = ',1P,D12.2, 6697 + ' (PARAMETER STOPPING TOLERANCE)'/ 6698 + ' MAXIT = ',I5, 6699 + ' (MAXIMUM NUMBER OF ITERATIONS)') 6700 1500 FORMAT 6701 + (/' --- INITIAL SUM OF SQUARED WEIGHTED DELTAS =', 6702 + 17X,1P,D17.8) 6703 1510 FORMAT 6704 + ( ' INITIAL PENALTY FUNCTION VALUE =',1P,D17.8/ 6705 + ' PENALTY TERM =',1P,D17.8/ 6706 + ' PENALTY PARAMETER =',1P,D10.1) 6707 1600 FORMAT 6708 + (/' --- INITIAL WEIGHTED SUM OF SQUARES =', 6709 + 17X,1P,D17.8) 6710 1610 FORMAT 6711 + ( ' SUM OF SQUARED WEIGHTED DELTAS =',1P,D17.8/ 6712 + ' SUM OF SQUARED WEIGHTED EPSILONS =',1P,D17.8) 6713 2010 FORMAT 6714 + (/' --- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:') 6715 2020 FORMAT 6716 + (/' --- EXPLANATORY VARIABLE SUMMARY:') 6717 2110 FORMAT 6718 + (/' INDEX X(I,J) DELTA(I,J) FIXED', 6719 + ' SCALE WEIGHT DERIVATIVE'/ 6720 + ' ', 6721 + ' ASSESSMENT'/, 6722 + ' (I,J) (IFIXX)', 6723 + ' (SCLD) (WD) '/) 6724 2120 FORMAT 6725 + (/' INDEX X(I,J) DELTA(I,J) FIXED', 6726 + ' SCALE WEIGHT '/ 6727 + ' ', 6728 + ' '/, 6729 + ' (I,J) (IFIXX)', 6730 + ' (SCLD) (WD) '/) 6731 2130 FORMAT 6732 + (/' INDEX X(I,J) DELTA(I,J) FIXED', 6733 + ' SCALE WEIGHT DERIVATIVE'/ 6734 + ' ', 6735 + ' STEP SIZE'/, 6736 + ' (I,J) (IFIXX)', 6737 + ' (SCLD) (WD) (STPD)'/) 6738 2140 FORMAT 6739 + (/' INDEX X(I,J)'/ 6740 + ' (I,J) '/) 6741 3000 FORMAT 6742 + (/' --- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT', 6743 + ' SUMMARY:') 6744 3100 FORMAT 6745 + (/' INDEX Y(I,L) WEIGHT'/ 6746 + ' (I,L) (WE)'/) 6747 4000 FORMAT 6748 + (/' --- FUNCTION PARAMETER SUMMARY:') 6749 4110 FORMAT 6750 + (/' INDEX BETA(K) FIXED SCALE', 6751 + ' DERIVATIVE'/ 6752 + ' ', 6753 + ' ASSESSMENT'/, 6754 + ' (K) (IFIXB) (SCLB)', 6755 + ' '/) 6756 4120 FORMAT 6757 + (/' INDEX BETA(K) FIXED SCALE', 6758 + ' '/ 6759 + ' ', 6760 + ' '/, 6761 + ' (K) (IFIXB) (SCLB)', 6762 + ' '/) 6763 4200 FORMAT 6764 + (/' INDEX BETA(K) FIXED SCALE', 6765 + ' DERIVATIVE'/ 6766 + ' ', 6767 + ' STEP SIZE'/, 6768 + ' (K) (IFIXB) (SCLB)', 6769 + ' (STPB)'/) 6770 4310 FORMAT 6771 + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,A13) 6772 4320 FORMAT 6773 + (7X,I5,1P,D16.8,4X,A5,D16.8,1X,D13.5) 6774 5110 FORMAT 6775 + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,A13) 6776 5120 FORMAT 6777 + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,A13) 6778 5210 FORMAT 6779 + (9X,A2,I1,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) 6780 5220 FORMAT 6781 + (8X,A2,I2,1P,2D12.3,4X,A5,2D10.2,1X,D13.5) 6782 6000 FORMAT 6783 + (' ') 6784 END 6785*DODPC2 6786 SUBROUTINE DODPC2 6787 + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, 6788 + PNLTY, 6789 + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) 6790C***BEGIN PROLOGUE DODPC2 6791C***REFER TO DODR,DODRC 6792C***ROUTINES CALLED (NONE) 6793C***DATE WRITTEN 860529 (YYMMDD) 6794C***REVISION DATE 920304 (YYMMDD) 6795C***PURPOSE GENERATE ITERATION REPORTS 6796C***END PROLOGUE DODPC2 6797 6798C...SCALAR ARGUMENTS 6799 DOUBLE PRECISION 6800 + ACTRED,ALPHA,PNLTY,PNORM,PRERED,TAU,WSS 6801 INTEGER 6802 + IPR,LUNRPT,NFEV,NITER,NP 6803 LOGICAL 6804 + FSTITR,IMPLCT,PRTPEN 6805 6806C...ARRAY ARGUMENTS 6807 DOUBLE PRECISION 6808 + BETA(NP) 6809 6810C...LOCAL SCALARS 6811 DOUBLE PRECISION 6812 + RATIO,ZERO 6813 INTEGER 6814 + J,K,L 6815 CHARACTER GN*3 6816 6817C...INTRINSIC FUNCTIONS 6818 INTRINSIC 6819 + MIN 6820 6821C...DATA STATEMENTS 6822 DATA 6823 + ZERO 6824 + /0.0D0/ 6825 6826C...VARIABLE DEFINITIONS (ALPHABETICALLY) 6827C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. 6828C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. 6829C BETA: THE FUNCTION PARAMETERS. 6830C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 6831C ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). 6832C GN: THE CHARACTER*3 VARIABLE INDICATING WHETHER A GAUSS-NEWTON 6833C STEP WAS TAKEN. 6834C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 6835C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 6836C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. 6837C J: AN INDEXING VARIABLE. 6838C K: AN INDEXING VARIABLE. 6839C L: AN INDEXING VARIABLE. 6840C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. 6841C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 6842C NITER: THE NUMBER OF ITERATIONS. 6843C NP: THE NUMBER OF FUNCTION PARAMETERS. 6844C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. 6845C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. 6846C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. 6847C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS 6848C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 6849C (PRTPEN=FALSE). 6850C RATIO: THE RATIO OF TAU TO PNORM. 6851C TAU: THE TRUST REGION DIAMETER. 6852C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. 6853C ZERO: THE VALUE 0.0D0. 6854 6855 6856C***FIRST EXECUTABLE STATEMENT DODPC2 6857 6858 6859 IF (FSTITR) THEN 6860 IF (IPR.EQ.1) THEN 6861 IF (IMPLCT) THEN 6862 WRITE (LUNRPT,1121) 6863 ELSE 6864 WRITE (LUNRPT,1122) 6865 END IF 6866 ELSE 6867 IF (IMPLCT) THEN 6868 WRITE (LUNRPT,1131) 6869 ELSE 6870 WRITE (LUNRPT,1132) 6871 END IF 6872 END IF 6873 END IF 6874 IF (PRTPEN) THEN 6875 WRITE (LUNRPT,1133) PNLTY 6876 END IF 6877 6878 IF (ALPHA.EQ.ZERO) THEN 6879 GN = 'YES' 6880 ELSE 6881 GN = ' NO' 6882 END IF 6883 IF (PNORM.NE.ZERO) THEN 6884 RATIO = TAU/PNORM 6885 ELSE 6886 RATIO = ZERO 6887 END IF 6888 IF (IPR.EQ.1) THEN 6889 WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, 6890 + RATIO,GN 6891 ELSE 6892 J = 1 6893 K = MIN(3,NP) 6894 IF (J.EQ.K) THEN 6895 WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, 6896 + RATIO,GN,J,BETA(J) 6897 ELSE 6898 WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED, 6899 + RATIO,GN,J,K,(BETA(L),L=J,K) 6900 END IF 6901 IF (NP.GT.3) THEN 6902 DO 10 J=4,NP,3 6903 K = MIN(J+2,NP) 6904 IF (J.EQ.K) THEN 6905 WRITE (LUNRPT,1151) J,BETA(J) 6906 ELSE 6907 WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K) 6908 END IF 6909 10 CONTINUE 6910 END IF 6911 END IF 6912 6913 RETURN 6914 6915C FORMAT STATEMENTS 6916 6917 1121 FORMAT 6918 + (// 6919 + ' CUM. PENALTY ACT. REL. PRED. REL.'/ 6920 + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', 6921 + ' G-N'/ 6922 + ' NUM. EVALS VALUE REDUCTION REDUCTION', 6923 + ' TAU/PNORM STEP'/ 6924 + ' ---- ------ ----------- ----------- -----------', 6925 + ' --------- ----') 6926 1122 FORMAT 6927 + (// 6928 + ' CUM. ACT. REL. PRED. REL.'/ 6929 + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', 6930 + ' G-N'/ 6931 + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', 6932 + ' TAU/PNORM STEP'/ 6933 + ' ---- ------ ----------- ----------- -----------', 6934 + ' --------- ----'/) 6935 1131 FORMAT 6936 + (// 6937 + ' CUM. PENALTY ACT. REL. PRED. REL.'/ 6938 + ' IT. NO. FN FUNCTION SUM-OF-SQS SUM-OF-SQS', 6939 + ' G-N BETA -------------->'/ 6940 + ' NUM. EVALS VALUE REDUCTION REDUCTION', 6941 + ' TAU/PNORM STEP INDEX VALUE'/ 6942 + ' ---- ------ ----------- ----------- -----------', 6943 + ' --------- ---- ----- -----') 6944 1132 FORMAT 6945 + (// 6946 + ' CUM. ACT. REL. PRED. REL.'/ 6947 + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', 6948 + ' G-N BETA -------------->'/ 6949 + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', 6950 + ' TAU/PNORM STEP INDEX VALUE'/ 6951 + ' ---- ------ ----------- ----------- -----------', 6952 + ' --------- ---- ----- -----'/) 6953 1133 FORMAT 6954 + (/' PENALTY PARAMETER VALUE = ', 1P,E10.1) 6955 1141 FORMAT 6956 + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8) 6957 1142 FORMAT 6958 + (1X,I4,I8,1X,1P,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8) 6959 1151 FORMAT 6960 + (76X,I3,1P,D16.8) 6961 1152 FORMAT 6962 + (70X,I3,' TO',I3,1P,3D16.8) 6963 END 6964*DODPC3 6965 SUBROUTINE DODPC3 6966 + (IPR,LUNRPT, 6967 + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, 6968 + N,M,NP,NQ,NPP, 6969 + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, 6970 + WSS,WSSDEL,WSSEPS,PNLTY,RVAR,IDF, 6971 + BETA,SDBETA,IFIXB2,F,DELTA) 6972C***BEGIN PROLOGUE DODPC3 6973C***REFER TO DODR,DODRC 6974C***ROUTINES CALLED DPPT 6975C***DATE WRITTEN 860529 (YYMMDD) 6976C***REVISION DATE 920619 (YYMMDD) 6977C***PURPOSE GENERATE FINAL SUMMARY REPORT 6978C***END PROLOGUE DODPC3 6979 6980C...SCALAR ARGUMENTS 6981 DOUBLE PRECISION 6982 + PNLTY,RCOND,RVAR,WSS,WSSDEL,WSSEPS 6983 INTEGER 6984 + IDF,INFO,IPR,IRANK,ISTOP,LUNRPT,M, 6985 + N,NFEV,NITER,NJEV,NP,NPP,NQ 6986 LOGICAL 6987 + ANAJAC,DIDVCV,DOVCV,IMPLCT,ISODR,REDOJ 6988 6989C...ARRAY ARGUMENTS 6990 DOUBLE PRECISION 6991 + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP) 6992 INTEGER 6993 + IFIXB2(NP) 6994 6995C...LOCAL SCALARS 6996 DOUBLE PRECISION 6997 + TVAL 6998 INTEGER 6999 + D1,D2,D3,D4,D5,I,J,K,L,NPLM1 7000 CHARACTER FMT1*90 7001 7002C...EXTERNAL FUNCTIONS 7003 DOUBLE PRECISION 7004 + DPPT 7005 EXTERNAL 7006 + DPPT 7007 7008C...INTRINSIC FUNCTIONS 7009 INTRINSIC 7010 + MIN,MOD 7011 7012C...VARIABLE DEFINITIONS (ALPHABETICALLY) 7013C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED 7014C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). 7015C BETA: THE FUNCTION PARAMETERS. 7016C D1: THE FIRST DIGIT OF INFO. 7017C D2: THE SECOND DIGIT OF INFO. 7018C D3: THE THIRD DIGIT OF INFO. 7019C D4: THE FOURTH DIGIT OF INFO. 7020C D5: THE FIFTH DIGIT OF INFO. 7021C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 7022C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS 7023C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). 7024C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS 7025C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). 7026C F: THE ESTIMATED VALUES OF EPSILON. 7027C FMT1: A CHARACTER*90 VARIABLE USED FOR FORMATS. 7028C I: AN INDEXING VARIABLE. 7029C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF 7030C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE 7031C NUMBER OF PARAMETERS BEING ESTIMATED. 7032C IFIXB2: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA WERE 7033C ESTIMATED, FIXED, OR DROPPED BECAUSE THEY CAUSED RANK 7034C DEFICIENCY, CORRESPONDING TO VALUES OF IFIXB2 EQUALING 1, 7035C 0, AND -1, RESPECTIVELY. IF IFIXB2 IS -2, THEN NO ATTEMPT 7036C WAS MADE TO ESTIMATE THE PARAMETERS BECAUSE MAXIT = 0. 7037C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 7038C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 7039C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 7040C IPR: THE VARIABLE INDICATING WHAT IS TO BE PRINTED. 7041C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. 7042C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 7043C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 7044C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 7045C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 7046C J: AN INDEXING VARIABLE. 7047C K: AN INDEXING VARIABLE. 7048C L: AN INDEXING VARIABLE. 7049C LUNRPT: THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. 7050C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 7051C N: THE NUMBER OF OBSERVATIONS. 7052C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 7053C NITER: THE NUMBER OF ITERATIONS. 7054C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. 7055C NP: THE NUMBER OF FUNCTION PARAMETERS. 7056C NPLM1: THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE. 7057C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. 7058C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 7059C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. 7060C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. 7061C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS 7062C TO BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE 7063C MATRIX (REDOJ=TRUE) OR NOT (REDOJ=FALSE). 7064C RVAR: THE RESIDUAL VARIANCE. 7065C SDBETA: THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS. 7066C TVAL: THE VALUE OF THE 97.5 PERCENT POINT FUNCTION FOR THE 7067C T DISTRIBUTION. 7068C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. 7069C WSSDEL: THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS. 7070C WSSEPS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. 7071 7072 7073C***FIRST EXECUTABLE STATEMENT DODPC3 7074 7075 7076 D1 = INFO/10000 7077 D2 = MOD(INFO,10000)/1000 7078 D3 = MOD(INFO,1000)/100 7079 D4 = MOD(INFO,100)/10 7080 D5 = MOD(INFO,10) 7081 7082C PRINT STOPPING CONDITIONS 7083 7084 WRITE (LUNRPT,1000) 7085 IF (INFO.LE.9) THEN 7086 IF (INFO.EQ.1) THEN 7087 WRITE (LUNRPT,1011) INFO 7088 ELSE IF (INFO.EQ.2) THEN 7089 WRITE (LUNRPT,1012) INFO 7090 ELSE IF (INFO.EQ.3) THEN 7091 WRITE (LUNRPT,1013) INFO 7092 ELSE IF (INFO.EQ.4) THEN 7093 WRITE (LUNRPT,1014) INFO 7094 ELSE IF (INFO.LE.9) THEN 7095 WRITE (LUNRPT,1015) INFO 7096 END IF 7097 ELSE IF (INFO.LE.9999) THEN 7098 7099C PRINT WARNING DIAGNOSTICS 7100 7101 WRITE (LUNRPT,1020) INFO 7102 IF (D2.EQ.1) WRITE (LUNRPT,1021) 7103 IF (D3.EQ.1) WRITE (LUNRPT,1022) 7104 IF (D4.EQ.1) WRITE (LUNRPT,1023) 7105 IF (D4.EQ.2) WRITE (LUNRPT,1024) 7106 IF (D5.EQ.1) THEN 7107 WRITE (LUNRPT,1031) 7108 ELSE IF (D5.EQ.2) THEN 7109 WRITE (LUNRPT,1032) 7110 ELSE IF (D5.EQ.3) THEN 7111 WRITE (LUNRPT,1033) 7112 ELSE IF (D5.EQ.4) THEN 7113 WRITE (LUNRPT,1034) 7114 ELSE IF (D5.LE.9) THEN 7115 WRITE (LUNRPT,1035) D5 7116 END IF 7117 ELSE 7118 7119C PRINT ERROR MESSAGES 7120 7121 WRITE (LUNRPT,1040) INFO 7122 IF (D1.EQ.5) THEN 7123 WRITE (LUNRPT,1042) 7124 IF (D2.NE.0) WRITE (LUNRPT,1043) D2 7125 IF (D3.EQ.3) THEN 7126 WRITE (LUNRPT,1044) D3 7127 ELSE IF (D3.NE.0) THEN 7128 WRITE (LUNRPT,1045) D3 7129 END IF 7130 ELSE IF (D1.EQ.6) THEN 7131 WRITE (LUNRPT,1050) 7132 ELSE 7133 WRITE (LUNRPT,1060) D1 7134 END IF 7135 END IF 7136 7137C PRINT MISC. STOPPING INFO 7138 7139 WRITE (LUNRPT,1300) NITER 7140 WRITE (LUNRPT,1310) NFEV 7141 IF (ANAJAC) WRITE (LUNRPT,1320) NJEV 7142 WRITE (LUNRPT,1330) IRANK 7143 WRITE (LUNRPT,1340) RCOND 7144 WRITE (LUNRPT,1350) ISTOP 7145 7146C PRINT FINAL SUM OF SQUARES 7147 7148 IF (IMPLCT) THEN 7149 WRITE (LUNRPT,2000) WSSDEL 7150 IF (ISODR) THEN 7151 WRITE (LUNRPT,2010) WSS,WSSEPS,PNLTY 7152 END IF 7153 ELSE 7154 WRITE (LUNRPT,2100) WSS 7155 IF (ISODR) THEN 7156 WRITE (LUNRPT,2110) WSSDEL,WSSEPS 7157 END IF 7158 END IF 7159 IF (DIDVCV) THEN 7160 WRITE (LUNRPT,2200) SQRT(RVAR),IDF 7161 END IF 7162 7163 NPLM1 = 3 7164 7165C PRINT ESTIMATED BETA'S, AND, 7166C IF, FULL RANK, THEIR STANDARD ERRORS 7167 7168 WRITE (LUNRPT,3000) 7169 IF (DIDVCV) THEN 7170 WRITE (LUNRPT,7300) 7171 TVAL = DPPT(0.975D0,IDF) 7172 DO 10 J=1,NP 7173 IF (IFIXB2(J).GE.1) THEN 7174 WRITE (LUNRPT,8400) J,BETA(J),SDBETA(J), 7175 + BETA(J)-TVAL*SDBETA(J), 7176 + BETA(J)+TVAL*SDBETA(J) 7177 ELSE IF (IFIXB2(J).EQ.0) THEN 7178 WRITE (LUNRPT,8600) J,BETA(J) 7179 ELSE 7180 WRITE (LUNRPT,8700) J,BETA(J) 7181 END IF 7182 10 CONTINUE 7183 IF (.NOT.REDOJ) WRITE (LUNRPT,7310) 7184 ELSE 7185 IF (DOVCV) THEN 7186 IF (D1.LE.5) THEN 7187 WRITE (LUNRPT,7410) 7188 ELSE 7189 WRITE (LUNRPT,7420) 7190 END IF 7191 END IF 7192 7193 IF ((IRANK.EQ.0 .AND. NPP.EQ.NP) .OR. NITER.EQ.0) THEN 7194 IF (NP.EQ.1) THEN 7195 WRITE (LUNRPT,7100) 7196 ELSE 7197 WRITE (LUNRPT,7200) 7198 END IF 7199 DO 20 J=1,NP,NPLM1+1 7200 K = MIN(J+NPLM1,NP) 7201 IF (K.EQ.J) THEN 7202 WRITE (LUNRPT,8100) J,BETA(J) 7203 ELSE 7204 WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K) 7205 END IF 7206 20 CONTINUE 7207 IF (NITER.GE.1) THEN 7208 WRITE (LUNRPT,8800) 7209 ELSE 7210 WRITE (LUNRPT,8900) 7211 END IF 7212 ELSE 7213 WRITE (LUNRPT,7500) 7214 DO 30 J=1,NP 7215 IF (IFIXB2(J).GE.1) THEN 7216 WRITE (LUNRPT,8500) J,BETA(J) 7217 ELSE IF (IFIXB2(J).EQ.0) THEN 7218 WRITE (LUNRPT,8600) J,BETA(J) 7219 ELSE 7220 WRITE (LUNRPT,8700) J,BETA(J) 7221 END IF 7222 30 CONTINUE 7223 END IF 7224 END IF 7225 7226 IF (IPR.EQ.1) RETURN 7227 7228 7229C PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF 7230C COLUMNS OF DATA IN EPSILON AND DELTA IS LESS THAN OR EQUAL TO THREE. 7231 7232 IF (IMPLCT .AND. (M.LE.4)) THEN 7233 WRITE (LUNRPT,4100) 7234 WRITE (FMT1,9110) M 7235 WRITE (LUNRPT,FMT1) (J,J=1,M) 7236 DO 40 I=1,N 7237 WRITE (LUNRPT,4130) I,(DELTA(I,J),J=1,M) 7238 40 CONTINUE 7239 7240 ELSE IF (ISODR .AND. (NQ+M.LE.4)) THEN 7241 WRITE (LUNRPT,4110) 7242 WRITE (FMT1,9120) NQ,M 7243 WRITE (LUNRPT,FMT1) (L,L=1,NQ),(J,J=1,M) 7244 DO 50 I=1,N 7245 WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ),(DELTA(I,J),J=1,M) 7246 50 CONTINUE 7247 7248 ELSE IF (.NOT.ISODR .AND. ((NQ.GE.2) .AND. (NQ.LE.4))) THEN 7249 WRITE (LUNRPT,4120) 7250 WRITE (FMT1,9130) NQ 7251 WRITE (LUNRPT,FMT1) (L,L=1,NQ) 7252 DO 60 I=1,N 7253 WRITE (LUNRPT,4130) I,(F(I,L),L=1,NQ) 7254 60 CONTINUE 7255 ELSE 7256 7257C PRINT EPSILON'S AND DELTA'S SEPARATELY 7258 7259 IF (.NOT.IMPLCT) THEN 7260 7261C PRINT EPSILON'S 7262 7263 DO 80 J=1,NQ 7264 WRITE (LUNRPT,4200) J 7265 IF (N.EQ.1) THEN 7266 WRITE (LUNRPT,7100) 7267 ELSE 7268 WRITE (LUNRPT,7200) 7269 END IF 7270 DO 70 I=1,N,NPLM1+1 7271 K = MIN(I+NPLM1,N) 7272 IF (I.EQ.K) THEN 7273 WRITE (LUNRPT,8100) I,F(I,J) 7274 ELSE 7275 WRITE (LUNRPT,8200) I,K,(F(L,J),L=I,K) 7276 END IF 7277 70 CONTINUE 7278 80 CONTINUE 7279 END IF 7280 7281C PRINT DELTA'S 7282 7283 IF (ISODR) THEN 7284 DO 100 J=1,M 7285 WRITE (LUNRPT,4300) J 7286 IF (N.EQ.1) THEN 7287 WRITE (LUNRPT,7100) 7288 ELSE 7289 WRITE (LUNRPT,7200) 7290 END IF 7291 DO 90 I=1,N,NPLM1+1 7292 K = MIN(I+NPLM1,N) 7293 IF (I.EQ.K) THEN 7294 WRITE (LUNRPT,8100) I,DELTA(I,J) 7295 ELSE 7296 WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K) 7297 END IF 7298 90 CONTINUE 7299 100 CONTINUE 7300 END IF 7301 END IF 7302 7303 RETURN 7304 7305C FORMAT STATEMENTS 7306 7307 1000 FORMAT 7308 + (/' --- STOPPING CONDITIONS:') 7309 1011 FORMAT 7310 + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE.') 7311 1012 FORMAT 7312 + (' INFO = ',I5,' ==> PARAMETER CONVERGENCE.') 7313 1013 FORMAT 7314 + (' INFO = ',I5,' ==> SUM OF SQUARES CONVERGENCE AND', 7315 + ' PARAMETER CONVERGENCE.') 7316 1014 FORMAT 7317 + (' INFO = ',I5,' ==> ITERATION LIMIT REACHED.') 7318 1015 FORMAT 7319 + (' INFO = ',I5,' ==> UNEXPECTED VALUE,', 7320 + ' PROBABLY INDICATING'/ 7321 + ' INCORRECTLY SPECIFIED', 7322 + ' USER INPUT.') 7323 1020 FORMAT 7324 + (' INFO = ',I5.4/ 7325 + ' = ABCD, WHERE A NONZERO VALUE FOR DIGIT A,', 7326 + ' B, OR C INDICATES WHY'/ 7327 + ' THE RESULTS MIGHT BE QUESTIONABLE,', 7328 + ' AND DIGIT D INDICATES'/ 7329 + ' THE ACTUAL STOPPING CONDITION.') 7330 1021 FORMAT 7331 + (' A=1 ==> DERIVATIVES ARE', 7332 + ' QUESTIONABLE.') 7333 1022 FORMAT 7334 + (' B=1 ==> USER SET ISTOP TO', 7335 + ' NONZERO VALUE DURING LAST'/ 7336 + ' CALL TO SUBROUTINE FCN.') 7337 1023 FORMAT 7338 + (' C=1 ==> DERIVATIVES ARE NOT', 7339 + ' FULL RANK AT THE SOLUTION.') 7340 1024 FORMAT 7341 + (' C=2 ==> DERIVATIVES ARE ZERO', 7342 + ' RANK AT THE SOLUTION.') 7343 1031 FORMAT 7344 + (' D=1 ==> SUM OF SQUARES CONVERGENCE.') 7345 1032 FORMAT 7346 + (' D=2 ==> PARAMETER CONVERGENCE.') 7347 1033 FORMAT 7348 + (' D=3 ==> SUM OF SQUARES CONVERGENCE', 7349 + ' AND PARAMETER CONVERGENCE.') 7350 1034 FORMAT 7351 + (' D=4 ==> ITERATION LIMIT REACHED.') 7352 1035 FORMAT 7353 + (' D=',I1,' ==> UNEXPECTED VALUE,', 7354 + ' PROBABLY INDICATING'/ 7355 + ' INCORRECTLY SPECIFIED', 7356 + ' USER INPUT.') 7357 1040 FORMAT 7358 + (' INFO = ',I5.5/ 7359 + ' = ABCDE, WHERE A NONZERO VALUE FOR A GIVEN', 7360 + ' DIGIT INDICATES AN'/ 7361 + ' ABNORMAL STOPPING CONDITION.') 7362 1042 FORMAT 7363 + (' A=5 ==> USER STOPPED COMPUTATIONS', 7364 + ' IN SUBROUTINE FCN.') 7365 1043 FORMAT 7366 + (' B=',I1,' ==> COMPUTATIONS WERE', 7367 + ' STOPPED DURING THE'/ 7368 + ' FUNCTION EVALUATION.') 7369 1044 FORMAT 7370 + (' C=',I1,' ==> COMPUTATIONS WERE', 7371 + ' STOPPED BECAUSE'/ 7372 + ' DERIVATIVES WITH', 7373 + ' RESPECT TO DELTA WERE'/ 7374 + ' COMPUTED BY', 7375 + ' SUBROUTINE FCN WHEN'/ 7376 + ' FIT IS OLS.') 7377 1045 FORMAT 7378 + (' C=',I1,' ==> COMPUTATIONS WERE', 7379 + ' STOPPED DURING THE'/ 7380 + ' JACOBIAN EVALUATION.') 7381 1050 FORMAT 7382 + (' A=6 ==> NUMERICAL INSTABILITIES', 7383 + ' HAVE BEEN DETECTED,'/ 7384 + ' POSSIBLY INDICATING', 7385 + ' A DISCONTINUITY IN THE'/ 7386 + ' DERIVATIVES OR A POOR', 7387 + ' POOR CHOICE OF PROBLEM'/ 7388 + ' SCALE OR WEIGHTS.') 7389 1060 FORMAT 7390 + (' A=',I1,' ==> UNEXPECTED VALUE,', 7391 + ' PROBABLY INDICATING'/ 7392 + ' INCORRECTLY SPECIFIED', 7393 + ' USER INPUT.') 7394 1300 FORMAT 7395 + (' NITER = ',I5, 7396 + ' (NUMBER OF ITERATIONS)') 7397 1310 FORMAT 7398 + (' NFEV = ',I5, 7399 + ' (NUMBER OF FUNCTION EVALUATIONS)') 7400 1320 FORMAT 7401 + (' NJEV = ',I5, 7402 + ' (NUMBER OF JACOBIAN EVALUATIONS)') 7403 1330 FORMAT 7404 + (' IRANK = ',I5, 7405 + ' (RANK DEFICIENCY)') 7406 1340 FORMAT 7407 + (' RCOND = ',1P,D12.2, 7408 + ' (INVERSE CONDITION NUMBER)') 7409*1341 FORMAT 7410* + (' ==> POSSIBLY FEWER THAN 2 SIGNIFICANT', 7411* + ' DIGITS IN RESULTS;'/ 7412* + ' SEE ODRPACK REFERENCE', 7413* + ' GUIDE, SECTION 4.C.') 7414 1350 FORMAT 7415 + (' ISTOP = ',I5, 7416 + ' (RETURNED BY USER FROM', 7417 + ' SUBROUTINE FCN)') 7418 2000 FORMAT 7419 + (/' --- FINAL SUM OF SQUARED WEIGHTED DELTAS = ', 7420 + 17X,1P,D17.8) 7421 2010 FORMAT 7422 + ( ' FINAL PENALTY FUNCTION VALUE = ',1P,D17.8/ 7423 + ' PENALTY TERM = ',1P,D17.8/ 7424 + ' PENALTY PARAMETER = ',1P,D10.1) 7425 2100 FORMAT 7426 + (/' --- FINAL WEIGHTED SUMS OF SQUARES = ',17X,1P,D17.8) 7427 2110 FORMAT 7428 + ( ' SUM OF SQUARED WEIGHTED DELTAS = ',1P,D17.8/ 7429 + ' SUM OF SQUARED WEIGHTED EPSILONS = ',1P,D17.8) 7430 2200 FORMAT 7431 + (/' --- RESIDUAL STANDARD DEVIATION = ', 7432 + 17X,1P,D17.8/ 7433 + ' DEGREES OF FREEDOM =',I5) 7434 3000 FORMAT 7435 + (/' --- ESTIMATED BETA(J), J = 1, ..., NP:') 7436 4100 FORMAT 7437 + (/' --- ESTIMATED DELTA(I,*), I = 1, ..., N:') 7438 4110 FORMAT 7439 + (/' --- ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:') 7440 4120 FORMAT 7441 + (/' --- ESTIMATED EPSILON(I), I = 1, ..., N:') 7442 4130 FORMAT(5X,I5,1P,5D16.8) 7443 4200 FORMAT 7444 + (/' --- ESTIMATED EPSILON(I,',I3,'), I = 1, ..., N:') 7445 4300 FORMAT 7446 + (/' --- ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:') 7447 7100 FORMAT 7448 + (/' INDEX VALUE'/) 7449 7200 FORMAT 7450 + (/' INDEX VALUE -------------->'/) 7451 7300 FORMAT 7452 + (/' BETA S.D. BETA', 7453 + ' ---- 95% CONFIDENCE INTERVAL ----'/) 7454 7310 FORMAT 7455 + (/' N.B. STANDARD ERRORS AND CONFIDENCE INTERVALS ARE', 7456 + ' COMPUTED USING'/ 7457 + ' DERIVATIVES CALCULATED AT THE BEGINNING', 7458 + ' OF THE LAST ITERATION,'/ 7459 + ' AND NOT USING DERIVATIVES RE-EVALUATED AT THE', 7460 + ' FINAL SOLUTION.') 7461 7410 FORMAT 7462 + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', 7463 + ' NOT COMPUTED BECAUSE'/ 7464 + ' THE DERIVATIVES WERE NOT AVAILABLE. EITHER MAXIT', 7465 + ' IS 0 AND THE THIRD'/ 7466 + ' DIGIT OF JOB IS GREATER THAN 1, OR THE MOST', 7467 + ' RECENTLY TRIED VALUES OF'/ 7468 + ' BETA AND/OR X+DELTA WERE IDENTIFIED AS', 7469 + ' UNACCEPTABLE BY USER SUPPLIED'/ 7470 + ' SUBROUTINE FCN.') 7471 7420 FORMAT 7472 + (/' N.B. THE STANDARD ERRORS OF THE ESTIMATED BETAS WERE', 7473 + ' NOT COMPUTED.'/ 7474 + ' (SEE INFO ABOVE.)') 7475 7500 FORMAT 7476 + (/' BETA STATUS') 7477 8100 FORMAT 7478 + (11X,I5,1P,D16.8) 7479 8200 FORMAT 7480 + (3X,I5,' TO',I5,1P,7D16.8) 7481 8400 FORMAT 7482 + (3X,I5,1X,1P,D16.8,3X,D12.4,3X,D16.8,1X,'TO',D16.8) 7483 8500 FORMAT 7484 + (3X,I5,1X,1P,D16.8,6X,'ESTIMATED') 7485 8600 FORMAT 7486 + (3X,I5,1X,1P,D16.8,6X,' FIXED') 7487 8700 FORMAT 7488 + (3X,I5,1X,1P,D16.8,6X,' DROPPED') 7489 8800 FORMAT 7490 + (/' N.B. NO PARAMETERS WERE FIXED BY THE USER OR', 7491 + ' DROPPED AT THE LAST'/ 7492 + ' ITERATION BECAUSE THEY CAUSED THE MODEL TO BE', 7493 + ' RANK DEFICIENT.') 7494 8900 FORMAT 7495 + (/' N.B. NO CHANGE WAS MADE TO THE USER SUPPLIED PARAMETER', 7496 + ' VALUES BECAUSE'/ 7497 + ' MAXIT=0.') 7498 9110 FORMAT 7499 + ('(/'' I'',', 7500 + I2,'('' DELTA(I,'',I1,'')'')/)') 7501 9120 FORMAT 7502 + ('(/'' I'',', 7503 + I2,'('' EPSILON(I,'',I1,'')''),', 7504 + I2,'('' DELTA(I,'',I1,'')'')/)') 7505 9130 FORMAT 7506 + ('(/'' I'',', 7507 + I2,'('' EPSILON(I,'',I1,'')'')/)') 7508 7509 END 7510*DODPCR 7511 SUBROUTINE DODPCR 7512 + (IPR,LUNRPT, 7513 + HEAD,PRTPEN,FSTITR,DIDVCV,IFLAG, 7514 + N,M,NP,NQ,NPP,NNZW, 7515 + MSGB,MSGD, BETA,Y,LDY,X,LDX,DELTA, 7516 + WE,LDWE,LD2WE,WD,LDWD,LD2WD, 7517 + IFIXB,IFIXX,LDIFX, 7518 + SSF,TT,LDTT,STPB,STPD,LDSTPD, 7519 + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, 7520 + WSS,RVAR,IDF,SDBETA, 7521 + NITER,NFEV,NJEV,ACTRED,PRERED, 7522 + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO,ISTOP) 7523C***BEGIN PROLOGUE DODPCR 7524C***REFER TO DODR,DODRC 7525C***ROUTINES CALLED DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD 7526C***DATE WRITTEN 860529 (YYMMDD) 7527C***REVISION DATE 920619 (YYMMDD) 7528C***PURPOSE GENERATE COMPUTATION REPORTS 7529C***END PROLOGUE DODPCR 7530 7531C...SCALAR ARGUMENTS 7532 DOUBLE PRECISION 7533 + ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR, 7534 + SSTOL,TAU,TAUFAC 7535 INTEGER 7536 + IDF,IFLAG,INFO,IPR,IRANK,ISTOP,JOB,LDIFX,LDSTPD,LDTT,LDWD,LDWE, 7537 + LDX,LDY,LD2WD,LD2WE,LUNRPT,M,MAXIT,N,NETA,NFEV, 7538 + NITER,NJEV,NNZW,NP,NPP,NQ 7539 LOGICAL 7540 + DIDVCV,FSTITR,HEAD,PRTPEN 7541 7542C...ARRAY ARGUMENTS 7543 DOUBLE PRECISION 7544 + BETA(NP),DELTA(N,M),F(N,NQ),SDBETA(NP),SSF(NP), 7545 + STPB(NP),STPD(LDSTPD,M),TT(LDTT,M), 7546 + WD(LDWD,LD2WD,M),WE(LDWE,LD2WE,NQ),WSS(3),X(LDX,M),Y(LDY,NQ) 7547 INTEGER 7548 + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NQ*NP+1),MSGD(NQ*M+1) 7549 7550C...LOCAL SCALARS 7551 DOUBLE PRECISION 7552 + PNLTY 7553 LOGICAL 7554 + ANAJAC,CDJAC,CHKJAC,DOVCV,IMPLCT,INITD,ISODR,REDOJ,RESTRT 7555 CHARACTER TYP*3 7556 7557C...EXTERNAL SUBROUTINES 7558 EXTERNAL 7559 + DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD 7560 7561C...VARIABLE DEFINITIONS (ALPHABETICALLY) 7562C ACTRED: THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES. 7563C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. 7564C ANAJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED 7565C BY FINITE DIFFERENCES (ANAJAC=FALSE) OR NOT (ANAJAC=TRUE). 7566C BETA: THE FUNCTION PARAMETERS. 7567C CDJAC: THE VARIABLE DESIGNATING WHETHER THE JACOBIANS ARE COMPUTED 7568C BY CENTRAL DIFFERENCES (CDJAC=TRUE) OR BY FORWARD 7569C DIFFERENCES (CDJAC=FALSE). 7570C CHKJAC: THE VARIABLE DESIGNATING WHETHER THE USER SUPPLIED 7571C JACOBIANS ARE TO BE CHECKED (CHKJAC=TRUE) OR NOT 7572C (CHKJAC=FALSE). 7573C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 7574C DIDVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX WAS 7575C COMPUTED (DIDVCV=TRUE) OR NOT (DIDVCV=FALSE). 7576C DOVCV: THE VARIABLE DESIGNATING WHETHER THE COVARIANCE MATRIX IS 7577C TO BE COMPUTED (DOVCV=TRUE) OR NOT (DOVCV=FALSE). 7578C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. 7579C FSTITR: THE VARIABLE DESIGNATING WHETHER THIS IS THE FIRST 7580C ITERATION (FSTITR=TRUE) OR NOT (FSTITR=FALSE). 7581C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 7582C PRINTED (HEAD=TRUE) OR NOT (HEAD=FALSE). 7583C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF 7584C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE 7585C NUMBER OF PARAMETERS BEING ESTIMATED. 7586C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 7587C FIXED AT THEIR INPUT VALUES OR NOT. 7588C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 7589C FIXED AT THEIR INPUT VALUES OR NOT. 7590C IFLAG: THE VARIABLE DESIGNATING WHAT IS TO BE PRINTED. 7591C IMPLCT: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY 7592C IMPLICIT ODR (IMPLCT=TRUE) OR EXPLICIT ODR (IMPLCT=FALSE). 7593C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 7594C INITD: THE VARIABLE DESIGNATING WHETHER DELTA IS INITIALIZED TO 7595C ZERO (INITD=TRUE) OR TO THE VALUES IN THE FIRST N BY M 7596C ELEMENTS OF ARRAY WORK (INITD=FALSE). 7597C IPR: THE VALUE INDICATING THE REPORT TO BE PRINTED. 7598C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. 7599C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 7600C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 7601C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 7602C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 7603C JOB: THE VARIABLE CONTROLLING PROBLEM INITIALIZATION AND 7604C COMPUTATIONAL METHOD. 7605C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 7606C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 7607C LDTT: THE LEADING DIMENSION OF ARRAY TT. 7608C LDWD: THE LEADING DIMENSION OF ARRAY WD. 7609C LDWE: THE LEADING DIMENSION OF ARRAY WE. 7610C LDX: THE LEADING DIMENSION OF ARRAY X. 7611C LDY: THE LEADING DIMENSION OF ARRAY Y. 7612C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 7613C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 7614C LUNRPT: THE LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS. 7615C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 7616C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. 7617C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. 7618C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. 7619C N: THE NUMBER OF OBSERVATIONS. 7620C NETA: THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. 7621C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 7622C NITER: THE NUMBER OF ITERATIONS. 7623C NJEV: THE NUMBER OF JACOBIAN EVALUATIONS. 7624C NNZW: THE NUMBER OF NONZERO WEIGHTED OBSERVATIONS. 7625C NP: THE NUMBER OF FUNCTION PARAMETERS. 7626C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 7627C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. 7628C PARTOL: THE PARAMETER CONVERGENCE STOPPING TOLERANCE. 7629C PNLTY: THE PENALTY PARAMETER FOR AN IMPLICIT MODEL. 7630C PNORM: THE NORM OF THE SCALED ESTIMATED PARAMETERS. 7631C PRERED: THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES. 7632C PRTPEN: THE VARIABLE DESIGNATING WHETHER THE PENALTY PARAMETER IS 7633C TO BE PRINTED IN THE ITERATION REPORT (PRTPEN=TRUE) OR NOT 7634C (PRTPEN=FALSE). 7635C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. 7636C REDOJ: THE VARIABLE DESIGNATING WHETHER THE JACOBIAN MATRIX IS TO 7637C BE RECOMPUTED FOR THE COMPUTATION OF THE COVARIANCE MATRIX 7638C (REDOJ=TRUE) OR NOT (REDOJ=FALSE). 7639C RESTRT: THE VARIABLE DESIGNATING WHETHER THE CALL IS A RESTART 7640C (RESTRT=TRUE) OR NOT (RESTRT=FALSE). 7641C RVAR: THE RESIDUAL VARIANCE. 7642C SDBETA: THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S. 7643C SSF: THE SCALING VALUES FOR BETA. 7644C SSTOL: THE SUM-OF-SQUARES CONVERGENCE STOPPING TOLERANCE. 7645C STPB: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 7646C DERIVATIVES WITH RESPECT TO BETA. 7647C STPD: THE RELATIVE STEP FOR COMPUTING FINITE DIFFERENCE 7648C DERIVATIVES WITH RESPECT TO DELTA. 7649C TAU: THE TRUST REGION DIAMETER. 7650C TAUFAC: THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION 7651C DIAMETER. 7652C TT: THE SCALING VALUES FOR DELTA. 7653C TYP: THE CHARACTER*3 STRING "ODR" OR "OLS". 7654C WE: THE EPSILON WEIGHTS. 7655C WD: THE DELTA WEIGHTS. 7656C WSS: THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS AND DELTAS, 7657C THE SUM-OF-SQUARES OF THE WEIGHTED DELTAS, AND 7658C THE SUM-OF-SQUARES OF THE WEIGHTED EPSILONS. 7659C X: THE EXPLANATORY VARIABLE. 7660C Y: THE DEPENDENT VARIABLE. UNUSED WHEN THE MODEL IS IMPLICIT. 7661 7662 7663C***FIRST EXECUTABLE STATEMENT DODPCR 7664 7665 7666 CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ, 7667 + ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT) 7668 PNLTY = ABS(WE(1,1,1)) 7669 7670 IF (HEAD) THEN 7671 CALL DODPHD(HEAD,LUNRPT) 7672 END IF 7673 IF (ISODR) THEN 7674 TYP = 'ODR' 7675 ELSE 7676 TYP = 'OLS' 7677 END IF 7678 7679C PRINT INITIAL SUMMARY 7680 7681 IF (IFLAG.EQ.1) THEN 7682 WRITE (LUNRPT,1200) TYP 7683 CALL DODPC1 7684 + (IPR,LUNRPT, 7685 + ANAJAC,CDJAC,CHKJAC,INITD,RESTRT,ISODR,IMPLCT,DOVCV,REDOJ, 7686 + MSGB(1),MSGB(2),MSGD(1),MSGD(2), 7687 + N,M,NP,NQ,NPP,NNZW, 7688 + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,LD2WD,TT,LDTT,STPD,LDSTPD, 7689 + Y,LDY,WE,LDWE,LD2WE,PNLTY, 7690 + BETA,IFIXB,SSF,STPB, 7691 + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, 7692 + WSS(1),WSS(2),WSS(3)) 7693 7694C PRINT ITERATION REPORTS 7695 7696 ELSE IF (IFLAG.EQ.2) THEN 7697 7698 IF (FSTITR) THEN 7699 WRITE (LUNRPT,1300) TYP 7700 END IF 7701 CALL DODPC2 7702 + (IPR,LUNRPT, FSTITR,IMPLCT,PRTPEN, 7703 + PNLTY, 7704 + NITER,NFEV,WSS(1),ACTRED,PRERED,ALPHA,TAU,PNORM,NP,BETA) 7705 7706C PRINT FINAL SUMMARY 7707 7708 ELSE IF (IFLAG.EQ.3) THEN 7709 7710 WRITE (LUNRPT,1400) TYP 7711 CALL DODPC3 7712 + (IPR,LUNRPT, 7713 + ISODR,IMPLCT,DIDVCV,DOVCV,REDOJ,ANAJAC, 7714 + N,M,NP,NQ,NPP, 7715 + INFO,NITER,NFEV,NJEV,IRANK,RCOND,ISTOP, 7716 + WSS(1),WSS(2),WSS(3),PNLTY,RVAR,IDF, 7717 + BETA,SDBETA,IFIXB,F,DELTA) 7718 END IF 7719 7720 RETURN 7721 7722C FORMAT STATEMENTS 7723 7724 1200 FORMAT 7725 + (/' *** INITIAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') 7726 1300 FORMAT 7727 + (/' *** ITERATION REPORTS FOR FIT BY METHOD OF ',A3, ' ***') 7728 1400 FORMAT 7729 + (/' *** FINAL SUMMARY FOR FIT BY METHOD OF ',A3, ' ***') 7730 7731 END 7732*DODPE1 7733 SUBROUTINE DODPE1 7734 + (UNIT,D1,D2,D3,D4,D5, 7735 + N,M,NQ, 7736 + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, 7737 + LWKMN,LIWKMN) 7738C***BEGIN PROLOGUE DODPE1 7739C***REFER TO DODR,DODRC 7740C***ROUTINES CALLED (NONE) 7741C***DATE WRITTEN 860529 (YYMMDD) 7742C***REVISION DATE 920619 (YYMMDD) 7743C***PURPOSE PRINT ERROR REPORTS 7744C***END PROLOGUE DODPE1 7745 7746C...SCALAR ARGUMENTS 7747 INTEGER 7748 + D1,D2,D3,D4,D5,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE, 7749 + LIWKMN,LWKMN,M,N,NQ,UNIT 7750 7751C...VARIABLE DEFINITIONS (ALPHABETICALLY) 7752C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. 7753C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. 7754C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. 7755C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. 7756C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. 7757C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. 7758C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 7759C LDWD: THE LEADING DIMENSION OF ARRAY WD. 7760C LDWE: THE LEADING DIMENSION OF ARRAY WE. 7761C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. 7762C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. 7763C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 7764C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 7765C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 7766C N: THE NUMBER OF OBSERVATIONS. 7767C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 7768C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. 7769 7770 7771C***FIRST EXECUTABLE STATEMENT DODPE1 7772 7773 7774C PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION 7775C PARAMETERS 7776 7777 IF (D1.EQ.1) THEN 7778 IF (D2.NE.0) THEN 7779 WRITE(UNIT,1100) 7780 END IF 7781 IF (D3.NE.0) THEN 7782 WRITE(UNIT,1200) 7783 END IF 7784 IF (D4.NE.0) THEN 7785 WRITE(UNIT,1300) 7786 END IF 7787 IF (D5.NE.0) THEN 7788 WRITE(UNIT,1400) 7789 END IF 7790 7791C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION 7792C PARAMETERS 7793 7794 ELSE IF (D1.EQ.2) THEN 7795 7796 IF (D2.NE.0) THEN 7797 IF (D2.EQ.1 .OR. D2.EQ.3) THEN 7798 WRITE(UNIT,2110) 7799 END IF 7800 IF (D2.EQ.2 .OR. D2.EQ.3) THEN 7801 WRITE(UNIT,2120) 7802 END IF 7803 END IF 7804 7805 IF (D3.NE.0) THEN 7806 IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN 7807 WRITE(UNIT,2210) 7808 END IF 7809 IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN 7810 WRITE(UNIT,2220) 7811 END IF 7812 IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN 7813 WRITE(UNIT,2230) 7814 END IF 7815 END IF 7816 7817 IF (D4.NE.0) THEN 7818 IF (D4.EQ.1 .OR. D4.EQ.3) THEN 7819 WRITE(UNIT,2310) 7820 END IF 7821 IF (D4.EQ.2 .OR. D4.EQ.3) THEN 7822 WRITE(UNIT,2320) 7823 END IF 7824 END IF 7825 7826 IF (D5.NE.0) THEN 7827 IF (D5.EQ.1 .OR. D5.EQ.3) THEN 7828 WRITE(UNIT,2410) LWKMN 7829 END IF 7830 IF (D5.EQ.2 .OR. D5.EQ.3) THEN 7831 WRITE(UNIT,2420) LIWKMN 7832 END IF 7833 END IF 7834 7835 ELSE IF (D1.EQ.3) THEN 7836 7837C PRINT APPROPRIATE MESSAGES FOR ERRORS IN SCALE VALUES 7838 7839 IF (D2.NE.0) THEN 7840 IF (D2.EQ.1 .OR. D2.EQ.3) THEN 7841 IF (LDSCLD.GE.N) THEN 7842 WRITE(UNIT,3110) 7843 ELSE 7844 WRITE(UNIT,3120) 7845 END IF 7846 END IF 7847 IF (D2.EQ.2 .OR. D2.EQ.3) THEN 7848 WRITE(UNIT,3130) 7849 END IF 7850 END IF 7851 7852C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DERIVATIVE STEP VALUES 7853 7854 IF (D3.NE.0) THEN 7855 IF (D3.EQ.1 .OR. D3.EQ.3) THEN 7856 IF (LDSTPD.GE.N) THEN 7857 WRITE(UNIT,3210) 7858 ELSE 7859 WRITE(UNIT,3220) 7860 END IF 7861 END IF 7862 IF (D3.EQ.2 .OR. D3.EQ.3) THEN 7863 WRITE(UNIT,3230) 7864 END IF 7865 END IF 7866 7867C PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS 7868 7869 IF (D4.NE.0) THEN 7870 IF (D4.EQ.1) THEN 7871 IF (LDWE.GE.N) THEN 7872 IF (LD2WE.GE.NQ) THEN 7873 WRITE(UNIT,3310) 7874 ELSE 7875 WRITE(UNIT,3320) 7876 END IF 7877 ELSE 7878 IF (LD2WE.GE.NQ) THEN 7879 WRITE(UNIT,3410) 7880 ELSE 7881 WRITE(UNIT,3420) 7882 END IF 7883 END IF 7884 END IF 7885 IF (D4.EQ.2) THEN 7886 WRITE(UNIT,3500) 7887 END IF 7888 END IF 7889 7890C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS 7891 7892 IF (D5.NE.0) THEN 7893 IF (LDWD.GE.N) THEN 7894 IF (LD2WD.GE.M) THEN 7895 WRITE(UNIT,4310) 7896 ELSE 7897 WRITE(UNIT,4320) 7898 END IF 7899 ELSE 7900 IF (LD2WD.GE.M) THEN 7901 WRITE(UNIT,4410) 7902 ELSE 7903 WRITE(UNIT,4420) 7904 END IF 7905 END IF 7906 END IF 7907 7908 END IF 7909 7910C FORMAT STATEMENTS 7911 7912 1100 FORMAT 7913 + (/' ERROR : N IS LESS THAN ONE.') 7914 1200 FORMAT 7915 + (/' ERROR : M IS LESS THAN ONE.') 7916 1300 FORMAT 7917 + (/' ERROR : NP IS LESS THAN ONE'/ 7918 + ' OR NP IS GREATER THAN N.') 7919 1400 FORMAT 7920 + (/' ERROR : NQ IS LESS THAN ONE.') 7921 2110 FORMAT 7922 + (/' ERROR : LDX IS LESS THAN N.') 7923 2120 FORMAT 7924 + (/' ERROR : LDY IS LESS THAN N.') 7925 2210 FORMAT 7926 + (/' ERROR : LDIFX IS LESS THAN N'/ 7927 + ' AND LDIFX IS NOT EQUAL TO ONE.') 7928 2220 FORMAT 7929 + (/' ERROR : LDSCLD IS LESS THAN N'/ 7930 + ' AND LDSCLD IS NOT EQUAL TO ONE.') 7931 2230 FORMAT 7932 + (/' ERROR : LDSTPD IS LESS THAN N'/ 7933 + ' AND LDSTPD IS NOT EQUAL TO ONE.') 7934 2310 FORMAT 7935 + (/' ERROR : LDWE IS LESS THAN N'/ 7936 + ' AND LDWE IS NOT EQUAL TO ONE OR'/ 7937 + ' OR'/ 7938 + ' LD2WE IS LESS THAN NQ'/ 7939 + ' AND LD2WE IS NOT EQUAL TO ONE.') 7940 2320 FORMAT 7941 + (/' ERROR : LDWD IS LESS THAN N'/ 7942 + ' AND LDWD IS NOT EQUAL TO ONE.') 7943 2410 FORMAT 7944 + (/' ERROR : LWORK IS LESS THAN ',I7, ','/ 7945 + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.') 7946 2420 FORMAT 7947 + (/' ERROR : LIWORK IS LESS THAN ',I7, ','/ 7948 + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY', 7949 + ' IWORK.') 7950 3110 FORMAT 7951 + (/' ERROR : SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ 7952 + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// 7953 + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ 7954 + ' AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN'/ 7955 + ' EACH OF THE N BY M ELEMENTS OF'/ 7956 + ' SCLD MUST BE GREATER THAN ZERO.') 7957 3120 FORMAT 7958 + (/' ERROR : SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ 7959 + ' FOR SOME J = 1, ..., M.'// 7960 + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ 7961 + ' AND LDSCLD IS EQUAL TO ONE THEN'/ 7962 + ' EACH OF THE 1 BY M ELEMENTS OF'/ 7963 + ' SCLD MUST BE GREATER THAN ZERO.') 7964 3130 FORMAT 7965 + (/' ERROR : SCLB(K) IS LESS THAN OR EQUAL TO ZERO'/ 7966 + ' FOR SOME K = 1, ..., NP.'// 7967 + ' ALL NP ELEMENTS OF', 7968 + ' SCLB MUST BE GREATER THAN ZERO.') 7969 3210 FORMAT 7970 + (/' ERROR : STPD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ 7971 + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// 7972 + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ 7973 + ' AND LDSTPD IS GREATER THAN OR EQUAL TO N THEN'/ 7974 + ' EACH OF THE N BY M ELEMENTS OF'/ 7975 + ' STPD MUST BE GREATER THAN ZERO.') 7976 3220 FORMAT 7977 + (/' ERROR : STPD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ 7978 + ' FOR SOME J = 1, ..., M.'// 7979 + ' WHEN STPD(1,1) IS GREATER THAN ZERO'/ 7980 + ' AND LDSTPD IS EQUAL TO ONE THEN'/ 7981 + ' EACH OF THE 1 BY M ELEMENTS OF'/ 7982 + ' STPD MUST BE GREATER THAN ZERO.') 7983 3230 FORMAT 7984 + (/' ERROR : STPB(K) IS LESS THAN OR EQUAL TO ZERO'/ 7985 + ' FOR SOME K = 1, ..., NP.'// 7986 + ' ALL NP ELEMENTS OF', 7987 + ' STPB MUST BE GREATER THAN ZERO.') 7988 3310 FORMAT 7989 + (/' ERROR : AT LEAST ONE OF THE (NQ BY NQ) ARRAYS STARTING'/ 7990 + ' IN WE(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ 7991 + ' SEMIDEFINITE. WHEN WE(1,1,1) IS GREATER THAN'/ 7992 + ' OR EQUAL TO ZERO, AND LDWE IS GREATER THAN OR'/ 7993 + ' EQUAL TO N, AND LD2WE IS GREATER THAN OR EQUAL'/ 7994 + ' TO NQ, THEN EACH OF THE (NQ BY NQ) ARRAYS IN WE'/ 7995 + ' MUST BE POSITIVE SEMIDEFINITE.') 7996 3320 FORMAT 7997 + (/' ERROR : AT LEAST ONE OF THE (1 BY NQ) ARRAYS STARTING'/ 7998 + ' IN WE(I,1,1), I = 1, ..., N, HAS A NEGATIVE'/ 7999 + ' ELEMENT. WHEN WE(1,1,1) IS GREATER THAN OR'/ 8000 + ' EQUAL TO ZERO, AND LDWE IS GREATER THAN OR EQUAL'/ 8001 + ' TO N, AND LD2WE IS EQUAL TO 1, THEN EACH OF THE'/ 8002 + ' (1 BY NQ) ARRAYS IN WE MUST HAVE ONLY NON-'/ 8003 + ' NEGATIVE ELEMENTS.') 8004 3410 FORMAT 8005 + (/' ERROR : THE (NQ BY NQ) ARRAY STARTING IN WE(1,1,1) IS'/ 8006 + ' NOT POSITIVE SEMIDEFINITE. WHEN WE(1,1,1) IS'/ 8007 + ' GREATER THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL'/ 8008 + ' TO 1, AND LD2WE IS GREATER THAN OR EQUAL TO NQ,'/ 8009 + ' THEN THE (NQ BY NQ) ARRAY IN WE MUST BE POSITIVE'/ 8010 + ' SEMIDEFINITE.') 8011 3420 FORMAT 8012 + (/' ERROR : THE (1 BY NQ) ARRAY STARTING IN WE(1,1,1) HAS'/ 8013 + ' A NEGATIVE ELEMENT. WHEN WE(1,1,1) IS GREATER'/ 8014 + ' THAN OR EQUAL TO ZERO, AND LDWE IS EQUAL TO 1,'/ 8015 + ' AND LD2WE IS EQUAL TO 1, THEN THE (1 BY NQ)'/ 8016 + ' ARRAY IN WE MUST HAVE ONLY NONNEGATIVE ELEMENTS.') 8017 3500 FORMAT 8018 + (/' ERROR : THE NUMBER OF NONZERO ARRAYS IN ARRAY WE IS'/ 8019 + ' LESS THAN NP.') 8020 4310 FORMAT 8021 + (/' ERROR : AT LEAST ONE OF THE (M BY M) ARRAYS STARTING'/ 8022 + ' IN WD(I,1,1), I = 1, ..., N, IS NOT POSITIVE'/ 8023 + ' DEFINITE. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ 8024 + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ 8025 + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN EACH'/ 8026 + ' OF THE (M BY M) ARRAYS IN WD MUST BE POSITIVE'/ 8027 + ' DEFINITE.') 8028 4320 FORMAT 8029 + (/' ERROR : AT LEAST ONE OF THE (1 BY M) ARRAYS STARTING'/ 8030 + ' IN WD(I,1,1), I = 1, ..., N, HAS A NONPOSITIVE'/ 8031 + ' ELEMENT. WHEN WD(1,1,1) IS GREATER THAN ZERO,'/ 8032 + ' AND LDWD IS GREATER THAN OR EQUAL TO N, AND'/ 8033 + ' LD2WD IS EQUAL TO 1, THEN EACH OF THE (1 BY M)'/ 8034 + ' ARRAYS IN WD MUST HAVE ONLY POSITIVE ELEMENTS.') 8035 4410 FORMAT 8036 + (/' ERROR : THE (M BY M) ARRAY STARTING IN WD(1,1,1) IS'/ 8037 + ' NOT POSITIVE DEFINITE. WHEN WD(1,1,1) IS'/ 8038 + ' GREATER THAN ZERO, AND LDWD IS EQUAL TO 1, AND'/ 8039 + ' LD2WD IS GREATER THAN OR EQUAL TO M, THEN THE'/ 8040 + ' (M BY M) ARRAY IN WD MUST BE POSITIVE DEFINITE.') 8041 4420 FORMAT 8042 + (/' ERROR : THE (1 BY M) ARRAY STARTING IN WD(1,1,1) HAS A'/ 8043 + ' NONPOSITIVE ELEMENT. WHEN WD(1,1,1) IS GREATER'/ 8044 + ' THAN ZERO, AND LDWD IS EQUAL TO 1, AND LD2WD IS'/ 8045 + ' EQUAL TO 1, THEN THE (1 BY M) ARRAY IN WD MUST'/ 8046 + ' HAVE ONLY POSITIVE ELEMENTS.') 8047 END 8048*DODPE2 8049 SUBROUTINE DODPE2 8050 + (UNIT, 8051 + N,M,NP,NQ, 8052 + FJACB,FJACD, 8053 + DIFF,MSGB1,MSGB,ISODR,MSGD1,MSGD, 8054 + XPLUSD,NROW,NETA,NTOL) 8055C***BEGIN PROLOGUE DODPE2 8056C***REFER TO DODR,DODRC 8057C***ROUTINES CALLED (NONE) 8058C***DATE WRITTEN 860529 (YYMMDD) 8059C***REVISION DATE 920619 (YYMMDD) 8060C***PURPOSE GENERATE THE DERIVATIVE CHECKING REPORT 8061C***END PROLOGUE DODPE2 8062 8063C...SCALAR ARGUMENTS 8064 INTEGER 8065 + M,MSGB1,MSGD1,N,NETA,NP,NQ,NROW,NTOL,UNIT 8066 LOGICAL 8067 + ISODR 8068 8069C...ARRAY ARGUMENTS 8070 DOUBLE PRECISION 8071 + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) 8072 INTEGER 8073 + MSGB(NQ,NP),MSGD(NQ,M) 8074 8075C...LOCAL SCALARS 8076 INTEGER 8077 + I,J,K,L 8078 CHARACTER FLAG*1,TYP*3 8079 8080C...LOCAL ARRAYS 8081 LOGICAL 8082 + FTNOTE(0:7) 8083 8084C...VARIABLE DEFINITIONS (ALPHABETICALLY) 8085C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND 8086C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. 8087C FJACB: THE JACOBIAN WITH RESPECT TO BETA. 8088C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. 8089C FLAG: THE CHARACTER STRING INDICATING HIGHLY QUESTIONABLE RESULTS. 8090C FTNOTE: THE ARRAY CONTROLLING FOOTNOTES. 8091C I: AN INDEX VARIABLE. 8092C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 8093C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). 8094C J: AN INDEX VARIABLE. 8095C K: AN INDEX VARIABLE. 8096C L: AN INDEX VARIABLE. 8097C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 8098C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. 8099C MSGB1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. 8100C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. 8101C MSGD1: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. 8102C N: THE NUMBER OF OBSERVATIONS. 8103C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. 8104C NP: THE NUMBER OF FUNCTION PARAMETERS. 8105C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 8106C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT 8107C WHICH THE DERIVATIVE IS TO BE CHECKED. 8108C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE 8109C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. 8110C TYP: THE CHARACTER STRING INDICATING SOLUTION TYPE, ODR OR OLS. 8111C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. 8112C XPLUSD: THE VALUES OF X + DELTA. 8113 8114 8115C***FIRST EXECUTABLE STATEMENT DODPE2 8116 8117 8118C SET UP FOR FOOTNOTES 8119 8120 DO 10 I=0,7 8121 FTNOTE(I) = .FALSE. 8122 10 CONTINUE 8123 8124 DO 40 L=1,NQ 8125 IF (MSGB1.GE.1) THEN 8126 DO 20 I=1,NP 8127 IF (MSGB(L,I).GE.1) THEN 8128 FTNOTE(0) = .TRUE. 8129 FTNOTE(MSGB(L,I)) = .TRUE. 8130 END IF 8131 20 CONTINUE 8132 END IF 8133 8134 IF (MSGD1.GE.1) THEN 8135 DO 30 I=1,M 8136 IF (MSGD(L,I).GE.1) THEN 8137 FTNOTE(0) = .TRUE. 8138 FTNOTE(MSGD(L,I)) = .TRUE. 8139 END IF 8140 30 CONTINUE 8141 END IF 8142 40 CONTINUE 8143 8144C PRINT REPORT 8145 8146 IF (ISODR) THEN 8147 TYP = 'ODR' 8148 ELSE 8149 TYP = 'OLS' 8150 END IF 8151 WRITE (UNIT,1000) TYP 8152 8153 DO 70 L=1,NQ 8154 8155 WRITE (UNIT,2100) L,NROW 8156 WRITE (UNIT,2200) 8157 8158 DO 50 I=1,NP 8159 K = MSGB(L,I) 8160 IF (K.GE.7) THEN 8161 FLAG = '*' 8162 ELSE 8163 FLAG = ' ' 8164 END IF 8165 IF (K.LE.-1) THEN 8166 WRITE (UNIT,3100) I 8167 ELSE IF (K.EQ.0) THEN 8168 WRITE (UNIT,3200) I,FJACB(NROW,I,L),DIFF(L,I),FLAG 8169 ELSE IF (K.GE.1) THEN 8170 WRITE (UNIT,3300) I,FJACB(NROW,I,L),DIFF(L,I),FLAG,K 8171 END IF 8172 50 CONTINUE 8173 IF (ISODR) THEN 8174 DO 60 I=1,M 8175 K = MSGD(L,I) 8176 IF (K.GE.7) THEN 8177 FLAG = '*' 8178 ELSE 8179 FLAG = ' ' 8180 END IF 8181 IF (K.LE.-1) THEN 8182 WRITE (UNIT,4100) NROW,I 8183 ELSE IF (K.EQ.0) THEN 8184 WRITE (UNIT,4200) NROW,I, 8185 + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG 8186 ELSE IF (K.GE.1) THEN 8187 WRITE (UNIT,4300) NROW,I, 8188 + FJACD(NROW,I,L),DIFF(L,NP+I),FLAG,K 8189 END IF 8190 60 CONTINUE 8191 END IF 8192 70 CONTINUE 8193 8194C PRINT FOOTNOTES 8195 8196 IF (FTNOTE(0)) THEN 8197 8198 WRITE (UNIT,5000) 8199 IF (FTNOTE(1)) WRITE (UNIT,5100) 8200 IF (FTNOTE(2)) WRITE (UNIT,5200) 8201 IF (FTNOTE(3)) WRITE (UNIT,5300) 8202 IF (FTNOTE(4)) WRITE (UNIT,5400) 8203 IF (FTNOTE(5)) WRITE (UNIT,5500) 8204 IF (FTNOTE(6)) WRITE (UNIT,5600) 8205 IF (FTNOTE(7)) WRITE (UNIT,5700) 8206 END IF 8207 8208 IF (NETA.LT.0) THEN 8209 WRITE (UNIT,6000) -NETA 8210 ELSE 8211 WRITE (UNIT,6100) NETA 8212 END IF 8213 WRITE (UNIT,7000) NTOL 8214 8215C PRINT OUT ROW OF EXPLANATORY VARIABLE WHICH WAS CHECKED. 8216 8217 WRITE (UNIT,8100) NROW 8218 8219 DO 80 J=1,M 8220 WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J) 8221 80 CONTINUE 8222 8223 RETURN 8224 8225C FORMAT STATEMENTS 8226 8227 1000 FORMAT 8228 + (//' *** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3, 8229 + ' ***'/) 8230 2100 FORMAT (/' FOR RESPONSE ',I2,' OF OBSERVATION ', I5/) 8231 2200 FORMAT (' ',' USER', 8232 + ' ',' '/ 8233 + ' ',' SUPPLIED', 8234 + ' RELATIVE',' DERIVATIVE '/ 8235 + ' DERIVATIVE WRT',' VALUE', 8236 + ' DIFFERENCE',' ASSESSMENT '/) 8237 3100 FORMAT (' BETA(',I3,')', ' --- ', 8238 + ' --- ',' UNCHECKED') 8239 3200 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, 8240 + 'VERIFIED') 8241 3300 FORMAT (' BETA(',I3,')', 1P,2D13.2,3X,A1, 8242 + 'QUESTIONABLE (SEE NOTE ',I1,')') 8243 4100 FORMAT (' DELTA(',I2,',',I2,')', ' --- ', 8244 + ' --- ',' UNCHECKED') 8245 4200 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, 8246 + 'VERIFIED') 8247 4300 FORMAT (' DELTA(',I2,',',I2,')', 1P,2D13.2,3X,A1, 8248 + 'QUESTIONABLE (SEE NOTE ',I1,')') 8249 5000 FORMAT 8250 + (/' NOTES:') 8251 5100 FORMAT 8252 + (/' (1) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', 8253 + ' AGREE, BUT'/ 8254 + ' RESULTS ARE QUESTIONABLE BECAUSE BOTH ARE ZERO.') 8255 5200 FORMAT 8256 + (/' (2) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', 8257 + ' AGREE, BUT'/ 8258 + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', 8259 + ' IDENTICALLY ZERO'/ 8260 + ' AND THE OTHER IS ONLY APPROXIMATELY ZERO.') 8261 5300 FORMAT 8262 + (/' (3) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', 8263 + ' DISAGREE, BUT'/ 8264 + ' RESULTS ARE QUESTIONABLE BECAUSE ONE IS', 8265 + ' IDENTICALLY ZERO'/ 8266 + ' AND THE OTHER IS NOT.') 8267 5400 FORMAT 8268 + (/' (4) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', 8269 + ' DISAGREE, BUT'/ 8270 + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', 8271 + ' BECAUSE EITHER'/ 8272 + ' THE RATIO OF RELATIVE CURVATURE TO RELATIVE', 8273 + ' SLOPE IS TOO HIGH'/ 8274 + ' OR THE SCALE IS WRONG.') 8275 5500 FORMAT 8276 + (/' (5) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', 8277 + ' DISAGREE, BUT'/ 8278 + ' FINITE DIFFERENCE DERIVATIVE IS QUESTIONABLE', 8279 + ' BECAUSE THE'/ 8280 + ' RATIO OF RELATIVE CURVATURE TO RELATIVE SLOPE IS', 8281 + ' TOO HIGH.') 8282 5600 FORMAT 8283 + (/' (6) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', 8284 + ' DISAGREE, BUT'/ 8285 + ' HAVE AT LEAST 2 DIGITS IN COMMON.') 8286 5700 FORMAT 8287 + (/' (7) USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVES', 8288 + ' DISAGREE, AND'/ 8289 + ' HAVE FEWER THAN 2 DIGITS IN COMMON. DERIVATIVE', 8290 + ' CHECKING MUST'/ 8291 + ' BE TURNED OFF IN ORDER TO PROCEED.') 8292 6000 FORMAT 8293 + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', 8294 + I5/ 8295 + ' (ESTIMATED BY ODRPACK)') 8296 6100 FORMAT 8297 + (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ', 8298 + I5/ 8299 + ' (SUPPLIED BY USER)') 8300 7000 FORMAT 8301 + (/' NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN '/ 8302 + ' USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR '/ 8303 + ' USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED ', 8304 + I5) 8305 8100 FORMAT 8306 + (/' ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED ', 8307 + I5// 8308 + ' -VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW'/) 8309 8110 FORMAT 8310 + (10X,'X(',I2,',',I2,')',1X,1P,3D16.8) 8311 END 8312*DODPE3 8313 SUBROUTINE DODPE3 8314 + (UNIT,D2,D3) 8315C***BEGIN PROLOGUE DODPE3 8316C***REFER TO DODR,DODRC 8317C***ROUTINES CALLED (NONE) 8318C***DATE WRITTEN 860529 (YYMMDD) 8319C***REVISION DATE 920619 (YYMMDD) 8320C***PURPOSE PRINT ERROR REPORTS INDICATING THAT COMPUTATIONS WERE 8321C STOPPED IN USER SUPPLIED SUBROUTINES FCN 8322C***END PROLOGUE DODPE3 8323 8324C...SCALAR ARGUMENTS 8325 INTEGER 8326 + D2,D3,UNIT 8327 8328C...VARIABLE DEFINITIONS (ALPHABETICALLY) 8329C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. 8330C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. 8331C UNIT: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. 8332 8333 8334C***FIRST EXECUTABLE STATEMENT DODPE3 8335 8336 8337C PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE 8338C STOPPED 8339 8340 IF (D2.EQ.2) THEN 8341 WRITE(UNIT,1100) 8342 ELSE IF (D2.EQ.3) THEN 8343 WRITE(UNIT,1200) 8344 ELSE IF (D2.EQ.4) THEN 8345 WRITE(UNIT,1300) 8346 END IF 8347 IF (D3.EQ.2) THEN 8348 WRITE(UNIT,1400) 8349 END IF 8350 8351C FORMAT STATEMENTS 8352 8353 1100 FORMAT 8354 + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ 8355 + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED USING THE'/ 8356 + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ 8357 + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ 8358 + ' PROPER EVALUATION OF SUBROUTINE FCN BEFORE THE '/ 8359 + ' REGRESSION PROCEDURE CAN CONTINUE.') 8360 1200 FORMAT 8361 + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ 8362 + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ 8363 + ' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE '/ 8364 + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, INDI-'/ 8365 + ' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),'/ 8366 + ' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION), '/ 8367 + ' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE'/ 8368 + ' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT '/ 8369 + ' SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. THE '/ 8370 + ' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ 8371 + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ 8372 + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') 8373 1300 FORMAT 8374 + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ 8375 + ' FROM USER SUPPLIED SUBROUTINE FCN. THIS OCCURRED DURING'/ 8376 + ' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT '/ 8377 + ' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS '/ 8378 + ' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR '/ 8379 + ' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS '/ 8380 + ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA '/ 8381 + ' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN '/ 8382 + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FCN, '/ 8383 + ' PREVENT SUBROUTINE FCN FROM BEING PROPERLY EVALUATED. '/ 8384 + ' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ 8385 + ' EVALUATION OF SUBROUTINE FCN DURING THESE COMPUTATIONS '/ 8386 + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') 8387 1400 FORMAT 8388 + (//' VARIABLE ISTOP HAS BEEN RETURNED WITH A NONZERO VALUE '/ 8389 + ' FROM USER SUPPLIED SUBROUTINE FCN WHEN INVOKED FOR '/ 8390 + ' DERIVATIVE EVALUATIONS USING THE INITIAL ESTIMATES OF '/ 8391 + ' BETA AND DELTA SUPPLIED BY THE USER. THE INITIAL '/ 8392 + ' ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER EVALUATION '/ 8393 + ' OF SUBROUTINE FCN BEFORE THE REGRESSION PROCEDURE CAN '/ 8394 + ' CONTINUE.') 8395 END 8396*DODPER 8397 SUBROUTINE DODPER 8398 + (INFO,LUNERR,SHORT, 8399 + N,M,NP,NQ, 8400 + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, 8401 + LWKMN,LIWKMN, 8402 + FJACB,FJACD, 8403 + DIFF,MSGB,ISODR,MSGD, 8404 + XPLUSD,NROW,NETA,NTOL) 8405C***BEGIN PROLOGUE DODPER 8406C***REFER TO DODR,DODRC 8407C***ROUTINES CALLED DODPE1,DODPE2,DODPE3,DODPHD 8408C***DATE WRITTEN 860529 (YYMMDD) 8409C***REVISION DATE 920619 (YYMMDD) 8410C***PURPOSE CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS 8411C***END PROLOGUE DODPER 8412 8413C...SCALAR ARGUMENTS 8414 INTEGER 8415 + INFO,LDSCLD,LDSTPD,LDWD,LDWE,LD2WD,LD2WE,LIWKMN,LUNERR,LWKMN, 8416 + M,N,NETA,NP,NQ,NROW,NTOL 8417 LOGICAL 8418 + ISODR,SHORT 8419 8420C...ARRAY ARGUMENTS 8421 DOUBLE PRECISION 8422 + DIFF(NQ,NP+M),FJACB(N,NP,NQ),FJACD(N,M,NQ),XPLUSD(N,M) 8423 INTEGER 8424 + MSGB(NQ*NP+1),MSGD(NQ*M+1) 8425 8426C...LOCAL SCALARS 8427 INTEGER 8428 + D1,D2,D3,D4,D5,UNIT 8429 LOGICAL 8430 + HEAD 8431 8432C...EXTERNAL SUBROUTINES 8433 EXTERNAL 8434 + DODPE1,DODPE2,DODPE3,DODPHD 8435 8436C...INTRINSIC FUNCTIONS 8437 INTRINSIC 8438 + MOD 8439 8440C...VARIABLE DEFINITIONS (ALPHABETICALLY) 8441C D1: THE 1ST DIGIT (FROM THE LEFT) OF INFO. 8442C D2: THE 2ND DIGIT (FROM THE LEFT) OF INFO. 8443C D3: THE 3RD DIGIT (FROM THE LEFT) OF INFO. 8444C D4: THE 4TH DIGIT (FROM THE LEFT) OF INFO. 8445C D5: THE 5TH DIGIT (FROM THE LEFT) OF INFO. 8446C DIFF: THE RELATIVE DIFFERENCES BETWEEN THE USER SUPPLIED AND 8447C FINITE DIFFERENCE DERIVATIVES FOR EACH DERIVATIVE CHECKED. 8448C FJACB: THE JACOBIAN WITH RESPECT TO BETA. 8449C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. 8450C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 8451C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). 8452C INFO: THE VARIABLE DESIGNATING WHY THE COMPUTATIONS WERE STOPPED. 8453C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 8454C (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). 8455C LDSCLD: THE LEADING DIMENSION OF ARRAY SCLD. 8456C LDSTPD: THE LEADING DIMENSION OF ARRAY STPD. 8457C LDWD: THE LEADING DIMENSION OF ARRAY WD. 8458C LDWE: THE LEADING DIMENSION OF ARRAY WE. 8459C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 8460C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 8461C LIWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. 8462C LUNERR: THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. 8463C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. 8464C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 8465C MSGB: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. 8466C MSGD: THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT DELTA. 8467C N: THE NUMBER OF OBSERVATIONS. 8468C NETA: THE NUMBER OF RELIABLE DIGITS IN THE MODEL. 8469C NP: THE NUMBER OF FUNCTION PARAMETERS. 8470C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 8471C NROW: THE ROW NUMBER OF THE EXPLANATORY VARIABLE ARRAY AT 8472C WHICH THE DERIVATIVE IS TO BE CHECKED. 8473C NTOL: THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE 8474C FINITE DIFFERENCE AND THE USER SUPPLIED DERIVATIVES. 8475C SHORT: THE VARIABLE DESIGNATING WHETHER THE USER HAS INVOKED 8476C ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL 8477C (SHORT=.FALSE.). 8478C UNIT: THE LOGICAL UNIT NUMBER FOR ERROR MESSAGES. 8479C XPLUSD: THE VALUES X + DELTA. 8480 8481 8482C***FIRST EXECUTABLE STATEMENT DODPER 8483 8484 8485C SET LOGICAL UNIT NUMBER FOR ERROR REPORT 8486 8487 IF (LUNERR.EQ.0) THEN 8488 RETURN 8489 ELSE IF (LUNERR.LT.0) THEN 8490 UNIT = 6 8491 ELSE 8492 UNIT = LUNERR 8493 END IF 8494 8495C PRINT HEADING 8496 8497 HEAD = .TRUE. 8498 CALL DODPHD(HEAD,UNIT) 8499 8500C EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO 8501 8502 D1 = MOD(INFO,100000)/10000 8503 D2 = MOD(INFO,10000)/1000 8504 D3 = MOD(INFO,1000)/100 8505 D4 = MOD(INFO,100)/10 8506 D5 = MOD(INFO,10) 8507 8508C PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP 8509 8510 IF (D1.GE.1 .AND. D1.LE.3) THEN 8511 8512C PRINT APPROPRIATE MESSAGES FOR ERRORS IN 8513C PROBLEM SPECIFICATION PARAMETERS 8514C DIMENSION SPECIFICATION PARAMETERS 8515C NUMBER OF GOOD DIGITS IN X 8516C WEIGHTS 8517 8518 CALL DODPE1(UNIT,D1,D2,D3,D4,D5, 8519 + N,M,NQ, 8520 + LDSCLD,LDSTPD,LDWE,LD2WE,LDWD,LD2WD, 8521 + LWKMN,LIWKMN) 8522 8523 ELSE IF ((D1.EQ.4) .OR. (MSGB(1).GE.0)) THEN 8524 8525C PRINT APPROPRIATE MESSAGES FOR DERIVATIVE CHECKING 8526 8527 CALL DODPE2(UNIT, 8528 + N,M,NP,NQ, 8529 + FJACB,FJACD, 8530 + DIFF,MSGB(1),MSGB(2),ISODR,MSGD(1),MSGD(2), 8531 + XPLUSD,NROW,NETA,NTOL) 8532 8533 ELSE IF (D1.EQ.5) THEN 8534 8535C PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FCN 8536 8537 CALL DODPE3(UNIT,D2,D3) 8538 8539 END IF 8540 8541C PRINT CORRECT FORM OF CALL STATEMENT 8542 8543 IF ((D1.GE.1 .AND. D1.LE.3) .OR. 8544 + (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. 8545 + (D1.EQ.5)) THEN 8546 IF (SHORT) THEN 8547 WRITE (UNIT,1100) 8548 ELSE 8549 WRITE (UNIT,1200) 8550 END IF 8551 END IF 8552 8553 RETURN 8554 8555C FORMAT STATEMENTS 8556 8557 1100 FORMAT 8558 + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// 8559 + ' CALL DODR'/ 8560 + ' + (FCN,'/ 8561 + ' + N,M,NP,NQ,'/ 8562 + ' + BETA,'/ 8563 + ' + Y,LDY,X,LDX,'/ 8564 + ' + WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/ 8565 + ' + JOB,'/ 8566 + ' + IPRINT,LUNERR,LUNRPT,'/ 8567 + ' + WORK,LWORK,IWORK,LIWORK,'/ 8568 + ' + INFO)') 8569 1200 FORMAT 8570 + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// 8571 + ' CALL DODRC'/ 8572 + ' + (FCN,'/ 8573 + ' + N,M,NP,NQ,'/ 8574 + ' + BETA,'/ 8575 + ' + Y,LDY,X,LDX,'/ 8576 + ' + WE,LDWE,LD2WE,WD,LDWD,LD2WD,'/ 8577 + ' + IFIXB,IFIXX,LDIFX,'/ 8578 + ' + JOB,NDIGIT,TAUFAC,'/ 8579 + ' + SSTOL,PARTOL,MAXIT,'/ 8580 + ' + IPRINT,LUNERR,LUNRPT,'/ 8581 + ' + STPB,STPD,LDSTPD,'/ 8582 + ' + SCLB,SCLD,LDSCLD,'/ 8583 + ' + WORK,LWORK,IWORK,LIWORK,'/ 8584 + ' + INFO)') 8585 8586 END 8587*DODPHD 8588 SUBROUTINE DODPHD 8589 + (HEAD,UNIT) 8590C***BEGIN PROLOGUE DODPHD 8591C***REFER TO DODR,DODRC 8592C***ROUTINES CALLED (NONE) 8593C***DATE WRITTEN 860529 (YYMMDD) 8594C***REVISION DATE 920619 (YYMMDD) 8595C***PURPOSE PRINT ODRPACK HEADING 8596C***END PROLOGUE DODPHD 8597 8598C...SCALAR ARGUMENTS 8599 INTEGER 8600 + UNIT 8601 LOGICAL 8602 + HEAD 8603 8604C...VARIABLE DEFINITIONS (ALPHABETICALLY) 8605C HEAD: THE VARIABLE DESIGNATING WHETHER THE HEADING IS TO BE 8606C PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). 8607C UNIT: THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN. 8608 8609 8610C***FIRST EXECUTABLE STATEMENT DODPHD 8611 8612 8613 IF (HEAD) THEN 8614 WRITE(UNIT,1000) 8615 HEAD = .FALSE. 8616 END IF 8617 8618 RETURN 8619 8620C FORMAT STATEMENTS 8621 8622 1000 FORMAT ( 8623 + ' ******************************************************* '/ 8624 + ' * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * '/ 8625 + ' ******************************************************* '/) 8626 END 8627*DODSTP 8628 SUBROUTINE DODSTP 8629 + (N,M,NP,NQ,NPP, 8630 + F,FJACB,FJACD, 8631 + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, 8632 + ALPHA,EPSFCN,ISODR, 8633 + TFJACB,OMEGA,U,QRAUX,KPVT, 8634 + S,T,PHI,IRANK,RCOND,FORVCV, 8635 + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) 8636C***BEGIN PROLOGUE DODSTP 8637C***REFER TO DODR,DODRC 8638C***ROUTINES CALLED IDAMAX,DCHEX,DESUBI,DFCTR,DNRM2,DQRDC,DQRSL,DROT, 8639C DROTG,DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO 8640C***DATE WRITTEN 860529 (YYMMDD) 8641C***REVISION DATE 920619 (YYMMDD) 8642C***PURPOSE COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA) 8643C***END PROLOGUE DODSTP 8644 8645C...SCALAR ARGUMENTS 8646 DOUBLE PRECISION 8647 + ALPHA,EPSFCN,PHI,RCOND 8648 INTEGER 8649 + IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ 8650 LOGICAL 8651 + ISODR 8652 8653C...ARRAY ARGUMENTS 8654 DOUBLE PRECISION 8655 + DELTA(N,M),F(N,NQ),FJACB(N,NP,NQ),FJACD(N,M,NQ), 8656 + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SS(NP), 8657 + T(N,M),TFJACB(N,NQ,NP),TT(LDTT,M),U(NP),WD(LDWD,LD2WD,M), 8658 + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M),WRK(LWRK) 8659 INTEGER 8660 + KPVT(NP) 8661 8662C...LOCAL SCALARS 8663 DOUBLE PRECISION 8664 + CO,ONE,SI,TEMP,ZERO 8665 INTEGER 8666 + I,IMAX,INF,IPVT,J,K,K1,K2,KP,L 8667 LOGICAL 8668 + ELIM,FORVCV 8669 8670C...LOCAL ARRAYS 8671 DOUBLE PRECISION 8672 + DUM(2) 8673 8674C...EXTERNAL FUNCTIONS 8675 DOUBLE PRECISION 8676 + DNRM2 8677 INTEGER 8678 + IDAMAX 8679 EXTERNAL 8680 + DNRM2,IDAMAX 8681 8682C...EXTERNAL SUBROUTINES 8683 EXTERNAL 8684 + DCHEX,DESUBI,DFCTR,DQRDC,DQRSL,DROT,DROTG, 8685 + DSOLVE,DTRCO,DTRSL,DVEVTR,DWGHT,DZERO 8686 8687C...INTRINSIC FUNCTIONS 8688 INTRINSIC 8689 + ABS,SQRT 8690 8691C...DATA STATEMENTS 8692 DATA 8693 + ZERO,ONE 8694 + /0.0D0,1.0D0/ 8695 8696C...VARIABLE DEFINITIONS (ALPHABETICALLY) 8697C ALPHA: THE LEVENBERG-MARQUARDT PARAMETER. 8698C CO: THE COSINE FROM THE PLANE ROTATION. 8699C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 8700C DUM: A DUMMY ARRAY. 8701C ELIM: THE VARIABLE DESIGNATING WHETHER COLUMNS OF THE JACOBIAN 8702C WRT BETA HAVE BEEN ELIMINATED (ELIM=TRUE) OR NOT 8703C (ELIM=FALSE). 8704C EPSFCN: THE FUNCTION'S PRECISION. 8705C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. 8706C FJACB: THE JACOBIAN WITH RESPECT TO BETA. 8707C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. 8708C FORVCV: THE VARIABLE DESIGNATING WHETHER THIS SUBROUTINE WAS 8709C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS 8710C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). 8711C I: AN INDEXING VARIABLE. 8712C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE 8713C VALUE. 8714C INF: THE RETURN CODE FROM LINPACK ROUTINES. 8715C IPVT: THE VARIABLE DESIGNATING WHETHER PIVOTING IS TO BE DONE. 8716C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. 8717C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 8718C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 8719C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE 8720C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. 8721C J: AN INDEXING VARIABLE. 8722C K: AN INDEXING VARIABLE. 8723C K1: AN INDEXING VARIABLE. 8724C K2: AN INDEXING VARIABLE. 8725C KP: THE RANK OF THE JACOBIAN WRT BETA. 8726C KPVT: THE PIVOT VECTOR. 8727C L: AN INDEXING VARIABLE. 8728C LDTT: THE LEADING DIMENSION OF ARRAY TT. 8729C LDWD: THE LEADING DIMENSION OF ARRAY WD. 8730C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 8731C LWRK: THE LENGTH OF VECTOR WRK. 8732C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 8733C N: THE NUMBER OF OBSERVATIONS. 8734C NP: THE NUMBER OF FUNCTION PARAMETERS. 8735C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. 8736C OMEGA: THE ARRAY DEFINED S.T. 8737C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) 8738C = (I-FJACD*INV(P)*TRANS(FJACD)) 8739C WHERE E = D**2 + ALPHA*TT**2 8740C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 8741C ONE: THE VALUE 1.0D0. 8742C PHI: THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP 8743C AND THE TRUST REGION DIAMETER. 8744C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE 8745C Q-R DECOMPOSITION. 8746C RCOND: THE APPROXIMATE RECIPROCAL CONDITION NUMBER OF TFJACB. 8747C S: THE STEP FOR BETA. 8748C SI: THE SINE FROM THE PLANE ROTATION. 8749C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. 8750C T: THE STEP FOR DELTA. 8751C TEMP: A TEMPORARY STORAGE LOCATION. 8752C TFJACB: THE ARRAY OMEGA*FJACB. 8753C TT: THE SCALING VALUES FOR DELTA. 8754C U: THE APPROXIMATE NULL VECTOR FOR TFJACB. 8755C WD: THE (SQUARED) DELTA WEIGHTS. 8756C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, 8757C EQUIVALENCED TO WRK1 AND WRK2. 8758C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. 8759C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 8760C WRK3: A WORK ARRAY OF (NP) ELEMENTS. 8761C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. 8762C WRK5: A WORK ARRAY OF (M) ELEMENTS. 8763C ZERO: THE VALUE 0.0D0. 8764 8765 8766C***FIRST EXECUTABLE STATEMENT DODSTP 8767 8768 8769C COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE 8770 8771C SET UP KPVT IF ALPHA = 0 8772 8773 IF (ALPHA.EQ.ZERO) THEN 8774 KP = NPP 8775 DO 10 K=1,NP 8776 KPVT(K) = K 8777 10 CONTINUE 8778 ELSE 8779 IF (NPP.GE.1) THEN 8780 KP = NPP-IRANK 8781 ELSE 8782 KP = NPP 8783 END IF 8784 END IF 8785 8786 IF (ISODR) THEN 8787 8788C T = WD * DELTA = D*G2 8789 CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,T,N) 8790 8791 DO 300 I=1,N 8792 8793C COMPUTE WRK4, SUCH THAT 8794C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) 8795 CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) 8796 CALL DFCTR(.FALSE.,WRK4,M,M,INF) 8797 IF (INF.NE.0) THEN 8798 ISTOPC = 60000 8799 RETURN 8800 END IF 8801 8802C COMPUTE OMEGA, SUCH THAT 8803C TRANS(OMEGA)*OMEGA = I+FJACD*INV(E)*TRANS(FJACD) 8804C INV(TRANS(OMEGA)*OMEGA) = I-FJACD*INV(P)*TRANS(FJACD) 8805 CALL DVEVTR(M,NQ,I, 8806 + FJACD,N,M, WRK4,M, WRK1,N,NQ, OMEGA,NQ, WRK5) 8807 DO 110 L=1,NQ 8808 OMEGA(L,L) = ONE + OMEGA(L,L) 8809 110 CONTINUE 8810 CALL DFCTR(.FALSE.,OMEGA,NQ,NQ,INF) 8811 IF (INF.NE.0) THEN 8812 ISTOPC = 60000 8813 RETURN 8814 END IF 8815 8816C COMPUTE WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) 8817C = TRANS(FJACD)*INV(TRANS(OMEGA)*OMEGA) 8818 DO 130 J=1,M 8819 DO 120 L=1,NQ 8820 WRK1(I,L,J) = FJACD(I,J,L) 8821 120 CONTINUE 8822 CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,4) 8823 CALL DSOLVE(NQ,OMEGA,NQ,WRK1(I,1,J),N,2) 8824 130 CONTINUE 8825 8826C COMPUTE WRK5 = INV(E)*D*G2 8827 DO 140 J=1,M 8828 WRK5(J) = T(I,J) 8829 140 CONTINUE 8830 CALL DSOLVE(M,WRK4,M,WRK5,1,4) 8831 CALL DSOLVE(M,WRK4,M,WRK5,1,2) 8832 8833C COMPUTE TFJACB = INV(TRANS(OMEGA))*FJACB 8834 DO 170 K=1,KP 8835 DO 150 L=1,NQ 8836 TFJACB(I,L,K) = FJACB(I,KPVT(K),L) 8837 150 CONTINUE 8838 CALL DSOLVE(NQ,OMEGA,NQ,TFJACB(I,1,K),N,4) 8839 DO 160 L=1,NQ 8840 IF (SS(1).GT.ZERO) THEN 8841 TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) 8842 ELSE 8843 TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) 8844 END IF 8845 160 CONTINUE 8846 170 CONTINUE 8847 8848C COMPUTE WRK2 = (V*INV(E)*D**2*G2 - G1) 8849 DO 190 L=1,NQ 8850 WRK2(I,L) = ZERO 8851 DO 180 J=1,M 8852 WRK2(I,L) = WRK2(I,L) + FJACD(I,J,L)*WRK5(J) 8853 180 CONTINUE 8854 WRK2(I,L) = WRK2(I,L) - F(I,L) 8855 190 CONTINUE 8856 8857C COMPUTE WRK2 = INV(TRANS(OMEGA))*(V*INV(E)*D**2*G2 - G1) 8858 CALL DSOLVE(NQ,OMEGA,NQ,WRK2(I,1),N,4) 8859 300 CONTINUE 8860 8861 ELSE 8862 DO 360 I=1,N 8863 DO 350 L=1,NQ 8864 DO 340 K=1,KP 8865 TFJACB(I,L,K) = FJACB(I,KPVT(K),L) 8866 IF (SS(1).GT.ZERO) THEN 8867 TFJACB(I,L,K) = TFJACB(I,L,K)/SS(KPVT(K)) 8868 ELSE 8869 TFJACB(I,L,K) = TFJACB(I,L,K)/ABS(SS(1)) 8870 END IF 8871 340 CONTINUE 8872 WRK2(I,L) = -F(I,L) 8873 350 CONTINUE 8874 360 CONTINUE 8875 END IF 8876 8877C COMPUTE S 8878 8879C DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0) 8880 8881 IF (ALPHA.EQ.ZERO) THEN 8882 IPVT = 1 8883 DO 410 K=1,NP 8884 KPVT(K) = 0 8885 410 CONTINUE 8886 ELSE 8887 IPVT = 0 8888 END IF 8889 8890 CALL DQRDC(TFJACB,N*NQ,N*NQ,KP,QRAUX,KPVT,WRK3,IPVT) 8891 CALL DQRSL(TFJACB,N*NQ,N*NQ,KP, 8892 + QRAUX,WRK2,DUM,WRK2,DUM,DUM,DUM,1000,INF) 8893 IF (INF.NE.0) THEN 8894 ISTOPC = 60000 8895 RETURN 8896 END IF 8897 8898C ELIMINATE ALPHA PART USING GIVENS ROTATIONS 8899 8900 IF (ALPHA.NE.ZERO) THEN 8901 CALL DZERO(NPP,1,S,NPP) 8902 DO 430 K1=1,KP 8903 CALL DZERO(KP,1,WRK3,KP) 8904 WRK3(K1) = SQRT(ALPHA) 8905 DO 420 K2=K1,KP 8906 CALL DROTG(TFJACB(K2,1,K2),WRK3(K2),CO,SI) 8907 IF (KP-K2.GE.1) THEN 8908 CALL DROT(KP-K2,TFJACB(K2,1,K2+1),N*NQ, 8909 + WRK3(K2+1),1,CO,SI) 8910 END IF 8911 TEMP = CO*WRK2(K2,1) + SI*S(KPVT(K1)) 8912 S(KPVT(K1)) = -SI*WRK2(K2,1) + CO*S(KPVT(K1)) 8913 WRK2(K2,1) = TEMP 8914 420 CONTINUE 8915 430 CONTINUE 8916 END IF 8917 8918C COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY 8919 8920 IF (NPP.GE.1) THEN 8921 IF (ALPHA.EQ.ZERO) THEN 8922 KP = NPP 8923 8924C ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR 8925 8926 440 CALL DTRCO(TFJACB,N*NQ,KP,RCOND,U,1) 8927 IF (RCOND.LE.EPSFCN) THEN 8928 ELIM = .TRUE. 8929 IMAX = IDAMAX(KP,U,1) 8930 8931C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX KPVT 8932 8933 IF (IMAX.NE.KP) THEN 8934 CALL DCHEX(TFJACB,N*NQ,KP,IMAX,KP,WRK2,N*NQ,1, 8935 + QRAUX,WRK3,2) 8936 K = KPVT(IMAX) 8937 DO 450 I=IMAX,KP-1 8938 KPVT(I) = KPVT(I+1) 8939 450 CONTINUE 8940 KPVT(KP) = K 8941 END IF 8942 KP = KP-1 8943 ELSE 8944 ELIM = .FALSE. 8945 END IF 8946 IF (ELIM .AND. KP.GE.1) THEN 8947 GO TO 440 8948 ELSE 8949 IRANK = NPP-KP 8950 END IF 8951 END IF 8952 END IF 8953 8954 IF (FORVCV) RETURN 8955 8956C BACKSOLVE AND UNSCRAMBLE 8957 8958 IF (NPP.GE.1) THEN 8959 DO 510 I=KP+1,NPP 8960 WRK2(I,1) = ZERO 8961 510 CONTINUE 8962 IF (KP.GE.1) THEN 8963 CALL DTRSL(TFJACB,N*NQ,KP,WRK2,01,INF) 8964 IF (INF.NE.0) THEN 8965 ISTOPC = 60000 8966 RETURN 8967 END IF 8968 END IF 8969 DO 520 I=1,NPP 8970 IF (SS(1).GT.ZERO) THEN 8971 S(KPVT(I)) = WRK2(I,1)/SS(KPVT(I)) 8972 ELSE 8973 S(KPVT(I)) = WRK2(I,1)/ABS(SS(1)) 8974 END IF 8975 520 CONTINUE 8976 END IF 8977 8978 IF (ISODR) THEN 8979 8980C NOTE: T AND WRK1 HAVE BEEN INITIALIZED ABOVE, 8981C WHERE T = WD * DELTA = D*G2 8982C WRK1 = TRANS(FJACD)*(I-FJACD*INV(P)*TRANS(JFACD)) 8983 8984 DO 670 I=1,N 8985 8986C COMPUTE WRK4, SUCH THAT 8987C TRANS(WRK4)*WRK4 = E = (D**2 + ALPHA*TT**2) 8988 CALL DESUBI(N,M,WD,LDWD,LD2WD,ALPHA,TT,LDTT,I,WRK4) 8989 CALL DFCTR(.FALSE.,WRK4,M,M,INF) 8990 IF (INF.NE.0) THEN 8991 ISTOPC = 60000 8992 RETURN 8993 END IF 8994 8995C COMPUTE WRK5 = INV(E)*D*G2 8996 DO 610 J=1,M 8997 WRK5(J) = T(I,J) 8998 610 CONTINUE 8999 CALL DSOLVE(M,WRK4,M,WRK5,1,4) 9000 CALL DSOLVE(M,WRK4,M,WRK5,1,2) 9001 9002 DO 640 L=1,NQ 9003 WRK2(I,L) = F(I,L) 9004 DO 620 K=1,NPP 9005 WRK2(I,L) = WRK2(I,L) + FJACB(I,K,L)*S(K) 9006 620 CONTINUE 9007 DO 630 J=1,M 9008 WRK2(I,L) = WRK2(I,L) - FJACD(I,J,L)*WRK5(J) 9009 630 CONTINUE 9010 640 CONTINUE 9011 9012 DO 660 J=1,M 9013 WRK5(J) = ZERO 9014 DO 650 L=1,NQ 9015 WRK5(J) = WRK5(J) + WRK1(I,L,J)*WRK2(I,L) 9016 650 CONTINUE 9017 T(I,J) = -(WRK5(J) + T(I,J)) 9018 660 CONTINUE 9019 CALL DSOLVE(M,WRK4,M,T(I,1),N,4) 9020 CALL DSOLVE(M,WRK4,M,T(I,1),N,2) 9021 670 CONTINUE 9022 9023 END IF 9024 9025C COMPUTE PHI(ALPHA) FROM SCALED S AND T 9026 9027 CALL DWGHT(NPP,1,SS,NPP,1,S,NPP,WRK,NPP) 9028 IF (ISODR) THEN 9029 CALL DWGHT(N,M,TT,LDTT,1,T,N,WRK(NPP+1),N) 9030 PHI = DNRM2(NPP+N*M,WRK,1) 9031 ELSE 9032 PHI = DNRM2(NPP,WRK,1) 9033 END IF 9034 9035 RETURN 9036 END 9037*DODVCV 9038 SUBROUTINE DODVCV 9039 + (N,M,NP,NQ,NPP, 9040 + F,FJACB,FJACD, 9041 + WD,LDWD,LD2WD,SSF,SS,TT,LDTT,DELTA, 9042 + EPSFCN,ISODR, 9043 + VCV,SD, 9044 + WRK6,OMEGA,U,QRAUX,JPVT, 9045 + S,T,IRANK,RCOND,RSS,IDF,RVAR,IFIXB, 9046 + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) 9047C***BEGIN PROLOGUE DODVCV 9048C***REFER TO DODR,DODRC 9049C***ROUTINES CALLED DPODI,DODSTP 9050C***DATE WRITTEN 901207 (YYMMDD) 9051C***REVISION DATE 920619 (YYMMDD) 9052C***PURPOSE COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS 9053C***END PROLOGUE DODVCV 9054 9055C...SCALAR ARGUMENTS 9056 DOUBLE PRECISION 9057 + EPSFCN,RCOND,RSS,RVAR 9058 INTEGER 9059 + IDF,IRANK,ISTOPC,LDTT,LDWD,LD2WD,LWRK,M,N,NP,NPP,NQ 9060 LOGICAL 9061 + ISODR 9062 9063C...ARRAY ARGUMENTS 9064 DOUBLE PRECISION 9065 + DELTA(N,M),F(N,NQ), 9066 + FJACB(N,NP,NQ),FJACD(N,M,NQ), 9067 + OMEGA(NQ,NQ),QRAUX(NP),S(NP),SD(NP),SS(NP),SSF(NP), 9068 + T(N,M),TT(LDTT,M),U(NP),VCV(NP,NP),WD(LDWD,LD2WD,M), 9069 + WRK1(N,NQ,M),WRK2(N,NQ),WRK3(NP),WRK4(M,M),WRK5(M), 9070 + WRK6(N*NQ,NP),WRK(LWRK) 9071 INTEGER 9072 + IFIXB(NP),JPVT(NP) 9073 9074C...LOCAL SCALARS 9075 DOUBLE PRECISION 9076 + TEMP,ZERO 9077 INTEGER 9078 + I,IUNFIX,J,JUNFIX,KP,L 9079 LOGICAL 9080 + FORVCV 9081 9082C...EXTERNAL SUBROUTINES 9083 EXTERNAL 9084 + DPODI,DODSTP 9085 9086C...INTRINSIC FUNCTIONS 9087 INTRINSIC 9088 + ABS,SQRT 9089 9090C...DATA STATEMENTS 9091 DATA 9092 + ZERO 9093 + /0.0D0/ 9094 9095C...VARIABLE DEFINITIONS (ALPHABETICALLY) 9096C DELTA: THE ESTIMATED ERRORS IN THE EXPLANATORY VARIABLES. 9097C EPSFCN: THE FUNCTION'S PRECISION. 9098C F: THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. 9099C FJACB: THE JACOBIAN WITH RESPECT TO BETA. 9100C FJACD: THE JACOBIAN WITH RESPECT TO DELTA. 9101C FORVCV: THE VARIABLE DESIGNATING WHETHER SUBROUTINE DODSTP IS 9102C CALLED TO SET UP FOR THE COVARIANCE MATRIX COMPUTATIONS 9103C (FORVCV=TRUE) OR NOT (FORVCV=FALSE). 9104C I: AN INDEXING VARIABLE. 9105C IDF: THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF 9106C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE 9107C NUMBER OF PARAMETERS BEING ESTIMATED. 9108C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 9109C FIXED AT THEIR INPUT VALUES OR NOT. 9110C IMAX: THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE 9111C VALUE. 9112C IRANK: THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. 9113C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 9114C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 9115C ISTOPC: THE VARIABLE DESIGNATING WHETHER THE COMPUTATIONS WERE 9116C STOPED DUE TO A NUMERICAL ERROR WITHIN SUBROUTINE DODSTP. 9117C IUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. 9118C J: AN INDEXING VARIABLE. 9119C JPVT: THE PIVOT VECTOR. 9120C JUNFIX: THE INDEX OF THE NEXT UNFIXED PARAMETER. 9121C KP: THE RANK OF THE JACOBIAN WRT BETA. 9122C L: AN INDEXING VARIABLE. 9123C LDTT: THE LEADING DIMENSION OF ARRAY TT. 9124C LDWD: THE LEADING DIMENSION OF ARRAY WD. 9125C LD2WD: THE SECOND DIMENSION OF ARRAY WD. 9126C LWRK: THE LENGTH OF VECTOR WRK. 9127C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 9128C N: THE NUMBER OF OBSERVATIONS. 9129C NP: THE NUMBER OF FUNCTION PARAMETERS. 9130C NPP: THE NUMBER OF FUNCTION PARAMETERS BEING ESTIMATED. 9131C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 9132C OMEGA: THE ARRAY DEFINED S.T. 9133C OMEGA*TRANS(OMEGA) = INV(I+FJACD*INV(E)*TRANS(FJACD)) 9134C = (I-FJACD*INV(P)*TRANS(FJACD)) 9135C WHERE E = D**2 + ALPHA*TT**2 9136C P = TRANS(FJACD)*FJACD + D**2 + ALPHA*TT**2 9137C QRAUX: THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE 9138C Q-R DECOMPOSITION. 9139C RCOND: THE APPROXIMATE RECIPROCAL CONDITION OF FJACB. 9140C RSS: THE RESIDUAL SUM OF SQUARES. 9141C RVAR: THE RESIDUAL VARIANCE. 9142C S: THE STEP FOR BETA. 9143C SD: THE STANDARD DEVIATIONS OF THE ESTIMATED BETAS. 9144C SS: THE SCALING VALUES FOR THE UNFIXED BETAS. 9145C SSF: THE SCALING VALUES USED FOR BETA. 9146C T: THE STEP FOR DELTA. 9147C TEMP: A TEMPORARY STORAGE LOCATION 9148C TT: THE SCALING VALUES FOR DELTA. 9149C U: THE APPROXIMATE NULL VECTOR FOR FJACB. 9150C VCV: THE COVARIANCE MATRIX OF THE ESTIMATED BETAS. 9151C WD: THE DELTA WEIGHTS. 9152C WRK: A WORK ARRAY OF (LWRK) ELEMENTS, 9153C EQUIVALENCED TO WRK1 AND WRK2. 9154C WRK1: A WORK ARRAY OF (N BY NQ BY M) ELEMENTS. 9155C WRK2: A WORK ARRAY OF (N BY NQ) ELEMENTS. 9156C WRK3: A WORK ARRAY OF (NP) ELEMENTS. 9157C WRK4: A WORK ARRAY OF (M BY M) ELEMENTS. 9158C WRK5: A WORK ARRAY OF (M) ELEMENTS. 9159C WRK6: A WORK ARRAY OF (N*NQ BY P) ELEMENTS. 9160C ZERO: THE VALUE 0.0D0. 9161 9162 9163C***FIRST EXECUTABLE STATEMENT DODVCV 9164 9165 9166 FORVCV = .TRUE. 9167 ISTOPC = 0 9168 9169 CALL DODSTP(N,M,NP,NQ,NPP, 9170 + F,FJACB,FJACD, 9171 + WD,LDWD,LD2WD,SS,TT,LDTT,DELTA, 9172 + ZERO,EPSFCN,ISODR, 9173 + WRK6,OMEGA,U,QRAUX,JPVT, 9174 + S,T,TEMP,IRANK,RCOND,FORVCV, 9175 + WRK1,WRK2,WRK3,WRK4,WRK5,WRK,LWRK,ISTOPC) 9176 IF (ISTOPC.NE.0) THEN 9177 RETURN 9178 END IF 9179 KP = NPP - IRANK 9180 CALL DPODI (WRK6,N*NQ,KP,WRK3,1) 9181 9182 IDF = 0 9183 DO 150 I=1,N 9184 DO 120 J=1,NPP 9185 DO 110 L=1,NQ 9186 IF (FJACB(I,J,L).NE.ZERO) THEN 9187 IDF = IDF + 1 9188 GO TO 150 9189 END IF 9190 110 CONTINUE 9191 120 CONTINUE 9192 IF (ISODR) THEN 9193 DO 140 J=1,M 9194 DO 130 L=1,NQ 9195 IF (FJACD(I,J,L).NE.ZERO) THEN 9196 IDF = IDF + 1 9197 GO TO 150 9198 END IF 9199 130 CONTINUE 9200 140 CONTINUE 9201 END IF 9202 150 CONTINUE 9203 9204 IF (IDF.GT.KP) THEN 9205 IDF = IDF - KP 9206 RVAR = RSS/IDF 9207 ELSE 9208 IDF = 0 9209 RVAR = RSS 9210 END IF 9211 9212C STORE VARIANCES IN SD, RESTORING ORIGINAL ORDER 9213 9214 DO 200 I=1,NP 9215 SD(I) = ZERO 9216 200 CONTINUE 9217 DO 210 I=1,KP 9218 SD(JPVT(I)) = WRK6(I,I) 9219 210 CONTINUE 9220 IF (NP.GT.NPP) THEN 9221 JUNFIX = NPP 9222 DO 220 J=NP,1,-1 9223 IF (IFIXB(J).EQ.0) THEN 9224 SD(J) = ZERO 9225 ELSE 9226 SD(J) = SD(JUNFIX) 9227 JUNFIX = JUNFIX - 1 9228 END IF 9229 220 CONTINUE 9230 END IF 9231 9232C STORE COVARIANCE MATRIX IN VCV, RESTORING ORIGINAL ORDER 9233 9234 DO 310 I=1,NP 9235 DO 300 J=1,I 9236 VCV(I,J) = ZERO 9237 300 CONTINUE 9238 310 CONTINUE 9239 DO 330 I=1,KP 9240 DO 320 J=I+1,KP 9241 IF (JPVT(I).GT.JPVT(J)) THEN 9242 VCV(JPVT(I),JPVT(J))=WRK6(I,J) 9243 ELSE 9244 VCV(JPVT(J),JPVT(I))=WRK6(I,J) 9245 END IF 9246 320 CONTINUE 9247 330 CONTINUE 9248 IF (NP.GT.NPP) THEN 9249 IUNFIX = NPP 9250 DO 360 I=NP,1,-1 9251 IF (IFIXB(I).EQ.0) THEN 9252 DO 340 J=I,1,-1 9253 VCV(I,J) = ZERO 9254 340 CONTINUE 9255 ELSE 9256 JUNFIX = NPP 9257 DO 350 J=NP,1,-1 9258 IF (IFIXB(J).EQ.0) THEN 9259 VCV(I,J) = ZERO 9260 ELSE 9261 VCV(I,J) = VCV(IUNFIX,JUNFIX) 9262 JUNFIX = JUNFIX - 1 9263 END IF 9264 350 CONTINUE 9265 IUNFIX = IUNFIX - 1 9266 END IF 9267 360 CONTINUE 9268 END IF 9269 9270 DO 380 I=1,NP 9271 VCV(I,I) = SD(I) 9272 SD(I) = SQRT(RVAR*SD(I)) 9273 DO 370 J=1,I 9274 VCV(J,I) = VCV(I,J) 9275 370 CONTINUE 9276 380 CONTINUE 9277 9278C UNSCALE STANDARD ERRORS AND COVARIANCE MATRIX 9279 DO 410 I=1,NP 9280 IF (SSF(1).GT.ZERO) THEN 9281 SD(I) = SD(I)/SSF(I) 9282 ELSE 9283 SD(I) = SD(I)/ABS(SSF(1)) 9284 END IF 9285 DO 400 J=1,NP 9286 IF (SSF(1).GT.ZERO) THEN 9287 VCV(I,J) = VCV(I,J)/(SSF(I)*SSF(J)) 9288 ELSE 9289 VCV(I,J) = VCV(I,J)/(SSF(1)*SSF(1)) 9290 END IF 9291 400 CONTINUE 9292 410 CONTINUE 9293 9294 RETURN 9295 END 9296*DPACK 9297 SUBROUTINE DPACK 9298 + (N2,N1,V1,V2,IFIX) 9299C***BEGIN PROLOGUE DPACK 9300C***REFER TO DODR,DODRC 9301C***ROUTINES CALLED DCOPY 9302C***DATE WRITTEN 860529 (YYMMDD) 9303C***REVISION DATE 920304 (YYMMDD) 9304C***PURPOSE SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1 9305C***END PROLOGUE DPACK 9306 9307C...SCALAR ARGUMENTS 9308 INTEGER 9309 + N1,N2 9310 9311C...ARRAY ARGUMENTS 9312 DOUBLE PRECISION 9313 + V1(N2),V2(N2) 9314 INTEGER 9315 + IFIX(N2) 9316 9317C...LOCAL SCALARS 9318 INTEGER 9319 + I 9320 9321C...EXTERNAL SUBROUTINES 9322 EXTERNAL 9323 + DCOPY 9324 9325C...VARIABLE DEFINITIONS (ALPHABETICALLY) 9326C I: AN INDEXING VARIABLE. 9327C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE 9328C FIXED AT THEIR INPUT VALUES OR NOT. 9329C N1: THE NUMBER OF ITEMS IN V1. 9330C N2: THE NUMBER OF ITEMS IN V2. 9331C V1: THE VECTOR OF THE UNFIXED ITEMS FROM V2. 9332C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE 9333C UNFIXED ELEMENTS ARE TO BE EXTRACTED. 9334 9335 9336C***FIRST EXECUTABLE STATEMENT DPACK 9337 9338 9339 N1 = 0 9340 IF (IFIX(1).GE.0) THEN 9341 DO 10 I=1,N2 9342 IF (IFIX(I).NE.0) THEN 9343 N1 = N1+1 9344 V1(N1) = V2(I) 9345 END IF 9346 10 CONTINUE 9347 ELSE 9348 N1 = N2 9349 CALL DCOPY(N2,V2,1,V1,1) 9350 END IF 9351 9352 RETURN 9353 END 9354*DPPNML 9355 DOUBLE PRECISION FUNCTION DPPNML 9356 + (P) 9357C***BEGIN PROLOGUE DPPNML 9358C***REFER TO DODR,DODRC 9359C***ROUTINES CALLED (NONE) 9360C***DATE WRITTEN 901207 (YYMMDD) 9361C***REVISION DATE 920304 (YYMMDD) 9362C***AUTHOR FILLIBEN, JAMES J., 9363C STATISTICAL ENGINEERING DIVISION 9364C NATIONAL BUREAU OF STANDARDS 9365C WASHINGTON, D. C. 20234 9366C (ORIGINAL VERSION--JUNE 1972. 9367C (UPDATED --SEPTEMBER 1975, 9368C NOVEMBER 1975, AND 9369C OCTOBER 1976. 9370C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE 9371C NORMAL (GAUSSIAN) DISTRIBUTION WITH MEAN 0 AND STANDARD 9372C DEVIATION 1, AND WITH PROBABILITY DENSITY FUNCTION 9373C F(X) = (1/SQRT(2*PI))*EXP(-X*X/2). 9374C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS 9375C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) 9376C***DESCRIPTION 9377C --THE CODING AS PRESENTED BELOW IS ESSENTIALLY 9378C IDENTICAL TO THAT PRESENTED BY ODEH AND EVANS 9379C AS ALGORTIHM 70 OF APPLIED STATISTICS. 9380C --AS POINTED OUT BY ODEH AND EVANS IN APPLIED 9381C STATISTICS, THEIR ALGORITHM REPRESENTES A 9382C SUBSTANTIAL IMPROVEMENT OVER THE PREVIOUSLY EMPLOYED 9383C HASTINGS APPROXIMATION FOR THE NORMAL PERCENT POINT 9384C FUNCTION, WITH ACCURACY IMPROVING FROM 4.5*(10**-4) 9385C TO 1.5*(10**-8). 9386C***REFERENCES ODEH AND EVANS, THE PERCENTAGE POINTS OF THE NORMAL 9387C DISTRIBUTION, ALGORTIHM 70, APPLIED STATISTICS, 1974, 9388C PAGES 96-97. 9389C EVANS, ALGORITHMS FOR MINIMAL DEGREE POLYNOMIAL AND 9390C RATIONAL APPROXIMATION, M. SC. THESIS, 1972, 9391C UNIVERSITY OF VICTORIA, B. C., CANADA. 9392C HASTINGS, APPROXIMATIONS FOR DIGITAL COMPUTERS, 1955, 9393C PAGES 113, 191, 192. 9394C NATIONAL BUREAU OF STANDARDS APPLIED MATHEMATICS 9395C SERIES 55, 1964, PAGE 933, FORMULA 26.2.23. 9396C FILLIBEN, SIMPLE AND ROBUST LINEAR ESTIMATION OF THE 9397C LOCATION PARAMETER OF A SYMMETRIC DISTRIBUTION 9398C (UNPUBLISHED PH.D. DISSERTATION, PRINCETON 9399C UNIVERSITY), 1969, PAGES 21-44, 229-231. 9400C FILLIBEN, "THE PERCENT POINT FUNCTION", 9401C (UNPUBLISHED MANUSCRIPT), 1970, PAGES 28-31. 9402C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, 9403C VOLUME 1, 1970, PAGES 40-111. 9404C KELLEY STATISTICAL TABLES, 1948. 9405C OWEN, HANDBOOK OF STATISTICAL TABLES, 1962, PAGES 3-16. 9406C PEARSON AND HARTLEY, BIOMETRIKA TABLES FOR 9407C STATISTICIANS, VOLUME 1, 1954, PAGES 104-113. 9408C***END PROLOGUE DPPNML 9409 9410C...SCALAR ARGUMENTS 9411 DOUBLE PRECISION 9412 + P 9413 9414C...LOCAL SCALARS 9415 DOUBLE PRECISION 9416 + ADEN,ANUM,HALF,ONE,P0,P1,P2,P3,P4,Q0,Q1,Q2,Q3,Q4,R,T,TWO,ZERO 9417 9418C...INTRINSIC FUNCTIONS 9419 INTRINSIC 9420 + LOG,SQRT 9421 9422C...DATA STATEMENTS 9423 DATA 9424 + P0,P1,P2,P3,P4 9425 + /-0.322232431088D0,-1.0D0,-0.342242088547D0, 9426 + -0.204231210245D-1,-0.453642210148D-4/ 9427 DATA 9428 + Q0,Q1,Q2,Q3,Q4 9429 + /0.993484626060D-1,0.588581570495D0, 9430 + 0.531103462366D0,0.103537752850D0,0.38560700634D-2/ 9431 DATA 9432 + ZERO,HALF,ONE,TWO 9433 + /0.0D0,0.5D0,1.0D0,2.0D0/ 9434 9435C...VARIABLE DEFINITIONS (ALPHABETICALLY) 9436C ADEN: A VALUE USED IN THE APPROXIMATION. 9437C ANUM: A VALUE USED IN THE APPROXIMATION. 9438C HALF: THE VALUE 0.5D0. 9439C ONE: THE VALUE 1.0D0. 9440C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE 9441C EVALUATED. P MUST BE BETWEEN 0.0D0 AND 1.0D0, EXCLUSIVE. 9442C P0: A PARAMETER USED IN THE APPROXIMATION. 9443C P1: A PARAMETER USED IN THE APPROXIMATION. 9444C P2: A PARAMETER USED IN THE APPROXIMATION. 9445C P3: A PARAMETER USED IN THE APPROXIMATION. 9446C P4: A PARAMETER USED IN THE APPROXIMATION. 9447C Q0: A PARAMETER USED IN THE APPROXIMATION. 9448C Q1: A PARAMETER USED IN THE APPROXIMATION. 9449C Q2: A PARAMETER USED IN THE APPROXIMATION. 9450C Q3: A PARAMETER USED IN THE APPROXIMATION. 9451C Q4: A PARAMETER USED IN THE APPROXIMATION. 9452C R: THE PROBABILITY AT WHICH THE PERCENT POINT IS EVALUATED. 9453C T: A VALUE USED IN THE APPROXIMATION. 9454C TWO: THE VALUE 2.0D0. 9455C ZERO: THE VALUE 0.0D0. 9456 9457 9458C***FIRST EXECUTABLE STATEMENT DPPT 9459 9460 9461 IF (P.EQ.HALF) THEN 9462 DPPNML = ZERO 9463 9464 ELSE 9465 R = P 9466 IF (P.GT.HALF) R = ONE - R 9467 T = SQRT(-TWO*LOG(R)) 9468 ANUM = ((((T*P4+P3)*T+P2)*T+P1)*T+P0) 9469 ADEN = ((((T*Q4+Q3)*T+Q2)*T+Q1)*T+Q0) 9470 DPPNML = T + (ANUM/ADEN) 9471 9472 IF (P.LT.HALF) DPPNML = -DPPNML 9473 END IF 9474 9475 RETURN 9476 9477 END 9478*DPPT 9479 DOUBLE PRECISION FUNCTION DPPT 9480 + (P, IDF) 9481C***BEGIN PROLOGUE DPPT 9482C***REFER TO DODR,DODRC 9483C***ROUTINES CALLED DPPNML 9484C***DATE WRITTEN 901207 (YYMMDD) 9485C***REVISION DATE 920304 (YYMMDD) 9486C***AUTHOR FILLIBEN, JAMES J., 9487C STATISTICAL ENGINEERING DIVISION 9488C NATIONAL BUREAU OF STANDARDS 9489C WASHINGTON, D. C. 20234 9490C (ORIGINAL VERSION--OCTOBER 1975.) 9491C (UPDATED --NOVEMBER 1975.) 9492C***PURPOSE COMPUTE THE PERCENT POINT FUNCTION VALUE FOR THE 9493C STUDENT'S T DISTRIBUTION WITH IDF DEGREES OF FREEDOM. 9494C (ADAPTED FROM DATAPAC SUBROUTINE TPPF, WITH MODIFICATIONS 9495C TO FACILITATE CONVERSION TO DOUBLE PRECISION AUTOMATICALLY) 9496C***DESCRIPTION 9497C --FOR IDF = 1 AND IDF = 2, THE PERCENT POINT FUNCTION 9498C FOR THE T DISTRIBUTION EXISTS IN SIMPLE CLOSED FORM 9499C AND SO THE COMPUTED PERCENT POINTS ARE EXACT. 9500C --FOR IDF BETWEEN 3 AND 6, INCLUSIVELY, THE APPROXIMATION 9501C IS AUGMENTED BY 3 ITERATIONS OF NEWTON'S METHOD TO 9502C IMPROVE THE ACCURACY, ESPECIALLY FOR P NEAR 0 OR 1. 9503C***REFERENCES NATIONAL BUREAU OF STANDARDS APPLIED MATHMATICS 9504C SERIES 55, 1964, PAGE 949, FORMULA 26.7.5. 9505C JOHNSON AND KOTZ, CONTINUOUS UNIVARIATE DISTRIBUTIONS, 9506C VOLUME 2, 1970, PAGE 102, FORMULA 11. 9507C FEDERIGHI, "EXTENDED TABLES OF THE PERCENTAGE POINTS 9508C OF STUDENT"S T DISTRIBUTION, JOURNAL OF THE AMERICAN 9509C STATISTICAL ASSOCIATION, 1969, PAGES 683-688. 9510C HASTINGS AND PEACOCK, STATISTICAL DISTRIBUTIONS, A 9511C HANDBOOK FOR STUDENTS AND PRACTITIONERS, 1975, 9512C PAGES 120-123. 9513C***END PROLOGUE DPPT 9514 9515C...SCALAR ARGUMENTS 9516 DOUBLE PRECISION 9517 + P 9518 INTEGER 9519 + IDF 9520 9521C...LOCAL SCALARS 9522 DOUBLE PRECISION 9523 + ARG,B21,B31,B32,B33,B34,B41,B42,B43,B44,B45, 9524 + B51,B52,B53,B54,B55,B56,C,CON,D1,D3,D5,D7,D9,DF,EIGHT,FIFTN, 9525 + HALF,ONE,PI,PPFN,S,TERM1,TERM2,TERM3,TERM4,TERM5,THREE,TWO, 9526 + Z,ZERO 9527 INTEGER 9528 + IPASS,MAXIT 9529 9530C...EXTERNAL FUNCTIONS 9531 DOUBLE PRECISION 9532 + DPPNML 9533 EXTERNAL 9534 + DPPNML 9535 9536C...INTRINSIC FUNCTIONS 9537 INTRINSIC 9538 + ATAN,COS,SIN,SQRT 9539 9540C...DATA STATEMENTS 9541 DATA 9542 + B21 9543 + /4.0D0/ 9544 DATA 9545 + B31, B32, B33, B34 9546 + /96.0D0,5.0D0,16.0D0,3.0D0/ 9547 DATA 9548 + B41, B42, B43, B44, B45 9549 + /384.0D0,3.0D0,19.0D0,17.0D0,-15.0D0/ 9550 DATA 9551 + B51,B52,B53,B54,B55,B56 9552 + /9216.0D0,79.0D0,776.0D0,1482.0D0,-1920.0D0,-945.0D0/ 9553 DATA 9554 + ZERO,HALF,ONE,TWO,THREE,EIGHT,FIFTN 9555 + /0.0D0,0.5D0,1.0D0,2.0D0,3.0D0,8.0D0,15.0D0/ 9556 9557C...VARIABLE DEFINITIONS (ALPHABETICALLY) 9558C ARG: A VALUE USED IN THE APPROXIMATION. 9559C B21: A PARAMETER USED IN THE APPROXIMATION. 9560C B31: A PARAMETER USED IN THE APPROXIMATION. 9561C B32: A PARAMETER USED IN THE APPROXIMATION. 9562C B33: A PARAMETER USED IN THE APPROXIMATION. 9563C B34: A PARAMETER USED IN THE APPROXIMATION. 9564C B41: A PARAMETER USED IN THE APPROXIMATION. 9565C B42: A PARAMETER USED IN THE APPROXIMATION. 9566C B43: A PARAMETER USED IN THE APPROXIMATION. 9567C B44: A PARAMETER USED IN THE APPROXIMATION. 9568C B45: A PARAMETER USED IN THE APPROXIMATION. 9569C B51: A PARAMETER USED IN THE APPROXIMATION. 9570C B52: A PARAMETER USED IN THE APPROXIMATION. 9571C B53: A PARAMETER USED IN THE APPROXIMATION. 9572C B54: A PARAMETER USED IN THE APPROXIMATION. 9573C B55: A PARAMETER USED IN THE APPROXIMATION. 9574C B56: A PARAMETER USED IN THE APPROXIMATION. 9575C C: A VALUE USED IN THE APPROXIMATION. 9576C CON: A VALUE USED IN THE APPROXIMATION. 9577C DF: THE DEGREES OF FREEDOM. 9578C D1: A VALUE USED IN THE APPROXIMATION. 9579C D3: A VALUE USED IN THE APPROXIMATION. 9580C D5: A VALUE USED IN THE APPROXIMATION. 9581C D7: A VALUE USED IN THE APPROXIMATION. 9582C D9: A VALUE USED IN THE APPROXIMATION. 9583C EIGHT: THE VALUE 8.0D0. 9584C FIFTN: THE VALUE 15.0D0. 9585C HALF: THE VALUE 0.5D0. 9586C IDF: THE (POSITIVE INTEGER) DEGREES OF FREEDOM. 9587C IPASS: A VALUE USED IN THE APPROXIMATION. 9588C MAXIT: THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR THE APPROX. 9589C ONE: THE VALUE 1.0D0. 9590C P: THE PROBABILITY AT WHICH THE PERCENT POINT IS TO BE 9591C EVALUATED. P MUST LIE BETWEEN 0.0DO AND 1.0D0, EXCLUSIVE. 9592C PI: THE VALUE OF PI. 9593C PPFN: THE NORMAL PERCENT POINT VALUE. 9594C S: A VALUE USED IN THE APPROXIMATION. 9595C TERM1: A VALUE USED IN THE APPROXIMATION. 9596C TERM2: A VALUE USED IN THE APPROXIMATION. 9597C TERM3: A VALUE USED IN THE APPROXIMATION. 9598C TERM4: A VALUE USED IN THE APPROXIMATION. 9599C TERM5: A VALUE USED IN THE APPROXIMATION. 9600C THREE: THE VALUE 3.0D0. 9601C TWO: THE VALUE 2.0D0. 9602C Z: A VALUE USED IN THE APPROXIMATION. 9603C ZERO: THE VALUE 0.0D0. 9604 9605 9606C***FIRST EXECUTABLE STATEMENT DPPT 9607 9608 9609 PI = 3.141592653589793238462643383279D0 9610 DF = IDF 9611 MAXIT = 5 9612 9613 IF (IDF.LE.0) THEN 9614 9615C TREAT THE IDF < 1 CASE 9616 DPPT = ZERO 9617 9618 ELSE IF (IDF.EQ.1) THEN 9619 9620C TREAT THE IDF = 1 (CAUCHY) CASE 9621 ARG = PI*P 9622 DPPT = -COS(ARG)/SIN(ARG) 9623 9624 ELSE IF (IDF.EQ.2) THEN 9625 9626C TREAT THE IDF = 2 CASE 9627 TERM1 = SQRT(TWO)/TWO 9628 TERM2 = TWO*P - ONE 9629 TERM3 = SQRT(P*(ONE-P)) 9630 DPPT = TERM1*TERM2/TERM3 9631 9632 ELSE IF (IDF.GE.3) THEN 9633 9634C TREAT THE IDF GREATER THAN OR EQUAL TO 3 CASE 9635 PPFN = DPPNML(P) 9636 D1 = PPFN 9637 D3 = PPFN**3 9638 D5 = PPFN**5 9639 D7 = PPFN**7 9640 D9 = PPFN**9 9641 TERM1 = D1 9642 TERM2 = (ONE/B21)*(D3+D1)/DF 9643 TERM3 = (ONE/B31)*(B32*D5+B33*D3+B34*D1)/(DF**2) 9644 TERM4 = (ONE/B41)*(B42*D7+B43*D5+B44*D3+B45*D1)/(DF**3) 9645 TERM5 = (ONE/B51)*(B52*D9+B53*D7+B54*D5+B55*D3+B56*D1)/(DF**4) 9646 DPPT = TERM1 + TERM2 + TERM3 + TERM4 + TERM5 9647 9648 IF (IDF.EQ.3) THEN 9649 9650C AUGMENT THE RESULTS FOR THE IDF = 3 CASE 9651 CON = PI*(P-HALF) 9652 ARG = DPPT/SQRT(DF) 9653 Z = ATAN(ARG) 9654 DO 70 IPASS=1,MAXIT 9655 S = SIN(Z) 9656 C = COS(Z) 9657 Z = Z - (Z+S*C-CON)/(TWO*C**2) 9658 70 CONTINUE 9659 DPPT = SQRT(DF)*S/C 9660 9661 ELSE IF (IDF.EQ.4) THEN 9662 9663C AUGMENT THE RESULTS FOR THE IDF = 4 CASE 9664 CON = TWO*(P-HALF) 9665 ARG = DPPT/SQRT(DF) 9666 Z = ATAN(ARG) 9667 DO 90 IPASS=1,MAXIT 9668 S = SIN(Z) 9669 C = COS(Z) 9670 Z = Z - ((ONE+HALF*C**2)*S-CON)/((ONE+HALF)*C**3) 9671 90 CONTINUE 9672 DPPT = SQRT(DF)*S/C 9673 9674 ELSE IF (IDF.EQ.5) THEN 9675 9676C AUGMENT THE RESULTS FOR THE IDF = 5 CASE 9677 9678 CON = PI*(P-HALF) 9679 ARG = DPPT/SQRT(DF) 9680 Z = ATAN(ARG) 9681 DO 110 IPASS=1,MAXIT 9682 S = SIN(Z) 9683 C = COS(Z) 9684 Z = Z - (Z+(C+(TWO/THREE)*C**3)*S-CON)/ 9685 + ((EIGHT/THREE)*C**4) 9686 110 CONTINUE 9687 DPPT = SQRT(DF)*S/C 9688 9689 ELSE IF (IDF.EQ.6) THEN 9690 9691C AUGMENT THE RESULTS FOR THE IDF = 6 CASE 9692 CON = TWO*(P-HALF) 9693 ARG = DPPT/SQRT(DF) 9694 Z = ATAN(ARG) 9695 DO 130 IPASS=1,MAXIT 9696 S = SIN(Z) 9697 C = COS(Z) 9698 Z = Z - ((ONE+HALF*C**2 + (THREE/EIGHT)*C**4)*S-CON)/ 9699 + ((FIFTN/EIGHT)*C**5) 9700 130 CONTINUE 9701 DPPT = SQRT(DF)*S/C 9702 END IF 9703 END IF 9704 9705 RETURN 9706 9707 END 9708*DPVB 9709 SUBROUTINE DPVB 9710 + (FCN, 9711 + N,M,NP,NQ, 9712 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 9713 + NROW,J,LQ,STP, 9714 + ISTOP,NFEV,PVB, 9715 + WRK1,WRK2,WRK6) 9716C***BEGIN PROLOGUE DPVB 9717C***REFER TO DODR,DODRC 9718C***ROUTINES CALLED FCN 9719C***DATE WRITTEN 860529 (YYMMDD) 9720C***REVISION DATE 920304 (YYMMDD) 9721C***PURPOSE COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP 9722C***END PROLOGUE DPVB 9723 9724C...SCALAR ARGUMENTS 9725 DOUBLE PRECISION 9726 + PVB,STP 9727 INTEGER 9728 + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW 9729 9730C...ARRAY ARGUMENTS 9731 DOUBLE PRECISION 9732 + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) 9733 INTEGER 9734 + IFIXB(NP),IFIXX(LDIFX,M) 9735 9736C...SUBROUTINE ARGUMENTS 9737 EXTERNAL 9738 + FCN 9739 9740C...LOCAL SCALARS 9741 DOUBLE PRECISION 9742 + BETAJ 9743 9744C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 9745C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 9746 9747C...VARIABLE DEFINITIONS (ALPHABETICALLY) 9748C BETA: THE FUNCTION PARAMETERS. 9749C BETAJ: THE CURRENT ESTIMATE OF THE JTH PARAMETER. 9750C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 9751C FIXED AT THEIR INPUT VALUES OR NOT. 9752C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 9753C FIXED AT THEIR INPUT VALUES OR NOT. 9754C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 9755C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 9756C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. 9757C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 9758C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. 9759C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. 9760C N: THE NUMBER OF OBSERVATIONS. 9761C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 9762C NP: THE NUMBER OF FUNCTION PARAMETERS. 9763C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 9764C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT 9765C WHICH THE DERIVATIVE IS TO BE CHECKED. 9766C PVB: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. 9767C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. 9768C XPLUSD: THE VALUES OF X + DELTA. 9769 9770 9771C***FIRST EXECUTABLE STATEMENT DPVB 9772 9773 9774C COMPUTE PREDICTED VALUES 9775 9776 BETAJ = BETA(J) 9777 BETA(J) = BETA(J) + STP 9778 ISTOP = 0 9779 CALL FCN(N,M,NP,NQ, 9780 + N,M,NP, 9781 + BETA,XPLUSD, 9782 + IFIXB,IFIXX,LDIFX, 9783 + 003,WRK2,WRK6,WRK1, 9784 + ISTOP) 9785 IF (ISTOP.EQ.0) THEN 9786 NFEV = NFEV + 1 9787 ELSE 9788 RETURN 9789 END IF 9790 BETA(J) = BETAJ 9791 9792 PVB = WRK2(NROW,LQ) 9793 9794 RETURN 9795 END 9796*DPVD 9797 SUBROUTINE DPVD 9798 + (FCN, 9799 + N,M,NP,NQ, 9800 + BETA,XPLUSD,IFIXB,IFIXX,LDIFX, 9801 + NROW,J,LQ,STP, 9802 + ISTOP,NFEV,PVD, 9803 + WRK1,WRK2,WRK6) 9804C***BEGIN PROLOGUE DPVD 9805C***REFER TO DODR,DODRC 9806C***ROUTINES CALLED FCN 9807C***DATE WRITTEN 860529 (YYMMDD) 9808C***REVISION DATE 920304 (YYMMDD) 9809C***PURPOSE COMPUTE NROW-TH FUNCTION VALUE USING 9810C X(NROW,J) + DELTA(NROW,J) + STP 9811C***END PROLOGUE DPVD 9812 9813C...SCALAR ARGUMENTS 9814 DOUBLE PRECISION 9815 + PVD,STP 9816 INTEGER 9817 + ISTOP,J,LDIFX,LQ,M,N,NFEV,NP,NQ,NROW 9818 9819C...ARRAY ARGUMENTS 9820 DOUBLE PRECISION 9821 + BETA(NP),WRK1(N,M,NQ),WRK2(N,NQ),WRK6(N,NP,NQ),XPLUSD(N,M) 9822 INTEGER 9823 + IFIXB(NP),IFIXX(LDIFX,M) 9824 9825C...SUBROUTINE ARGUMENTS 9826 EXTERNAL 9827 + FCN 9828 9829C...LOCAL SCALARS 9830 DOUBLE PRECISION 9831 + XPDJ 9832 9833C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS 9834C FCN: THE USER-SUPPLIED SUBROUTINE FOR EVALUATING THE MODEL. 9835 9836C...VARIABLE DEFINITIONS (ALPHABETICALLY) 9837C BETA: THE FUNCTION PARAMETERS. 9838C IFIXB: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF BETA ARE 9839C FIXED AT THEIR INPUT VALUES OR NOT. 9840C IFIXX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF X ARE 9841C FIXED AT THEIR INPUT VALUES OR NOT. 9842C ISTOP: THE VARIABLE DESIGNATING WHETHER THERE ARE PROBLEMS 9843C COMPUTING THE FUNCTION AT THE CURRENT BETA AND DELTA. 9844C J: THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. 9845C LDIFX: THE LEADING DIMENSION OF ARRAY IFIXX. 9846C LQ: THE RESPONSE CURRENTLY BEING EXAMINED. 9847C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. 9848C N: THE NUMBER OF OBSERVATIONS. 9849C NFEV: THE NUMBER OF FUNCTION EVALUATIONS. 9850C NP: THE NUMBER OF FUNCTION PARAMETERS. 9851C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 9852C NROW: THE ROW NUMBER OF THE INDEPENDENT VARIABLE ARRAY AT 9853C WHICH THE DERIVATIVE IS TO BE CHECKED. 9854C PVD: THE FUNCTION VALUE FOR THE SELECTED OBSERVATION & RESPONSE. 9855C STP: THE STEP SIZE FOR THE FINITE DIFFERENCE DERIVATIVE. 9856C XPDJ: THE (NROW,J)TH ELEMENT OF XPLUSD. 9857C XPLUSD: THE VALUES OF X + DELTA. 9858 9859 9860C***FIRST EXECUTABLE STATEMENT DPVD 9861 9862 9863C COMPUTE PREDICTED VALUES 9864 9865 XPDJ = XPLUSD(NROW,J) 9866 XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP 9867 ISTOP = 0 9868 CALL FCN(N,M,NP,NQ, 9869 + N,M,NP, 9870 + BETA,XPLUSD, 9871 + IFIXB,IFIXX,LDIFX, 9872 + 003,WRK2,WRK6,WRK1, 9873 + ISTOP) 9874 IF (ISTOP.EQ.0) THEN 9875 NFEV = NFEV + 1 9876 ELSE 9877 RETURN 9878 END IF 9879 XPLUSD(NROW,J) = XPDJ 9880 9881 PVD = WRK2(NROW,LQ) 9882 9883 RETURN 9884 END 9885*DSCALE 9886 SUBROUTINE DSCALE 9887 + (N,M,SCL,LDSCL,T,LDT,SCLT,LDSCLT) 9888C***BEGIN PROLOGUE DSCALE 9889C***REFER TO DODR,DODRC 9890C***ROUTINES CALLED (NONE) 9891C***DATE WRITTEN 860529 (YYMMDD) 9892C***REVISION DATE 920304 (YYMMDD) 9893C***PURPOSE SCALE T BY THE INVERSE OF SCL, I.E., COMPUTE T/SCL 9894C***END PROLOGUE DSCALE 9895 9896C...SCALAR ARGUMENTS 9897 INTEGER 9898 + LDT,LDSCL,LDSCLT,M,N 9899 9900C...ARRAY ARGUMENTS 9901 DOUBLE PRECISION 9902 + T(LDT,M),SCL(LDSCL,M),SCLT(LDSCLT,M) 9903 9904C...LOCAL SCALARS 9905 DOUBLE PRECISION 9906 + ONE,TEMP,ZERO 9907 INTEGER 9908 + I,J 9909 9910C...INTRINSIC FUNCTIONS 9911 INTRINSIC 9912 + ABS 9913 9914C...DATA STATEMENTS 9915 DATA 9916 + ONE,ZERO 9917 + /1.0D0,0.0D0/ 9918 9919C...VARIABLE DEFINITIONS (ALPHABETICALLY) 9920C I: AN INDEXING VARIABLE. 9921C J: AN INDEXING VARIABLE. 9922C LDSCL: THE LEADING DIMENSION OF ARRAY SCL. 9923C LDSCLT: THE LEADING DIMENSION OF ARRAY SCLT. 9924C LDT: THE LEADING DIMENSION OF ARRAY T. 9925C M: THE NUMBER OF COLUMNS OF DATA IN T. 9926C N: THE NUMBER OF ROWS OF DATA IN T. 9927C ONE: THE VALUE 1.0D0. 9928C SCL: THE SCALE VALUES. 9929C SCLT: THE INVERSELY SCALED MATRIX. 9930C T: THE ARRAY TO BE INVERSELY SCALED BY SCL. 9931C TEMP: A TEMPORARY SCALAR. 9932C ZERO: THE VALUE 0.0D0. 9933 9934 9935C***FIRST EXECUTABLE STATEMENT DSCALE 9936 9937 9938 IF (N.EQ.0 .OR. M.EQ.0) RETURN 9939 9940 IF (SCL(1,1).GE.ZERO) THEN 9941 IF (LDSCL.GE.N) THEN 9942 DO 80 J=1,M 9943 DO 70 I=1,N 9944 SCLT(I,J) = T(I,J)/SCL(I,J) 9945 70 CONTINUE 9946 80 CONTINUE 9947 ELSE 9948 DO 100 J=1,M 9949 TEMP = ONE/SCL(1,J) 9950 DO 90 I=1,N 9951 SCLT(I,J) = T(I,J)*TEMP 9952 90 CONTINUE 9953 100 CONTINUE 9954 END IF 9955 ELSE 9956 TEMP = ONE/ABS(SCL(1,1)) 9957 DO 120 J=1,M 9958 DO 110 I=1,N 9959 SCLT(I,J) = T(I,J)*TEMP 9960 110 CONTINUE 9961 120 CONTINUE 9962 END IF 9963 9964 RETURN 9965 END 9966*DSCLB 9967 SUBROUTINE DSCLB 9968 + (NP,BETA,SSF) 9969C***BEGIN PROLOGUE DSCLB 9970C***REFER TO DODR,DODRC 9971C***ROUTINES CALLED (NONE) 9972C***DATE WRITTEN 860529 (YYMMDD) 9973C***REVISION DATE 920304 (YYMMDD) 9974C***PURPOSE SELECT SCALING VALUES FOR BETA ACCORDING TO THE 9975C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE 9976C***END PROLOGUE DSCLB 9977 9978C...SCALAR ARGUMENTS 9979 INTEGER 9980 + NP 9981 9982C...ARRAY ARGUMENTS 9983 DOUBLE PRECISION 9984 + BETA(NP),SSF(NP) 9985 9986C...LOCAL SCALARS 9987 DOUBLE PRECISION 9988 + BMAX,BMIN,ONE,TEN,ZERO 9989 INTEGER 9990 + K 9991 LOGICAL 9992 + BIGDIF 9993 9994C...INTRINSIC FUNCTIONS 9995 INTRINSIC 9996 + ABS,LOG10,MAX,MIN,SQRT 9997 9998C...DATA STATEMENTS 9999 DATA 10000 + ZERO,ONE,TEN 10001 + /0.0D0,1.0D0,10.0D0/ 10002 10003C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10004C BETA: THE FUNCTION PARAMETERS. 10005C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT 10006C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF 10007C BETA (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). 10008C BMAX: THE LARGEST NONZERO MAGNITUDE. 10009C BMIN: THE SMALLEST NONZERO MAGNITUDE. 10010C K: AN INDEXING VARIABLE. 10011C NP: THE NUMBER OF FUNCTION PARAMETERS. 10012C ONE: THE VALUE 1.0D0. 10013C SSF: THE SCALING VALUES FOR BETA. 10014C TEN: THE VALUE 10.0D0. 10015C ZERO: THE VALUE 0.0D0. 10016 10017 10018C***FIRST EXECUTABLE STATEMENT DSCLB 10019 10020 10021 BMAX = ABS(BETA(1)) 10022 DO 10 K=2,NP 10023 BMAX = MAX(BMAX,ABS(BETA(K))) 10024 10 CONTINUE 10025 10026 IF (BMAX.EQ.ZERO) THEN 10027 10028C ALL INPUT VALUES OF BETA ARE ZERO 10029 10030 DO 20 K=1,NP 10031 SSF(K) = ONE 10032 20 CONTINUE 10033 10034 ELSE 10035 10036C SOME OF THE INPUT VALUES ARE NONZERO 10037 10038 BMIN = BMAX 10039 DO 30 K=1,NP 10040 IF (BETA(K).NE.ZERO) THEN 10041 BMIN = MIN(BMIN,ABS(BETA(K))) 10042 END IF 10043 30 CONTINUE 10044 BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE 10045 DO 40 K=1,NP 10046 IF (BETA(K).EQ.ZERO) THEN 10047 SSF(K) = TEN/BMIN 10048 ELSE 10049 IF (BIGDIF) THEN 10050 SSF(K) = ONE/ABS(BETA(K)) 10051 ELSE 10052 SSF(K) = ONE/BMAX 10053 END IF 10054 END IF 10055 40 CONTINUE 10056 10057 END IF 10058 10059 RETURN 10060 END 10061*DSCLD 10062 SUBROUTINE DSCLD 10063 + (N,M,X,LDX,TT,LDTT) 10064C***BEGIN PROLOGUE DSCLD 10065C***REFER TO DODR,DODRC 10066C***ROUTINES CALLED (NONE) 10067C***DATE WRITTEN 860529 (YYMMDD) 10068C***REVISION DATE 920304 (YYMMDD) 10069C***PURPOSE SELECT SCALING VALUES FOR DELTA ACCORDING TO THE 10070C ALGORITHM GIVEN IN THE ODRPACK REFERENCE GUIDE 10071C***END PROLOGUE DSCLD 10072 10073C...SCALAR ARGUMENTS 10074 INTEGER 10075 + LDTT,LDX,M,N 10076 10077C...ARRAY ARGUMENTS 10078 DOUBLE PRECISION 10079 + TT(LDTT,M),X(LDX,M) 10080 10081C...LOCAL SCALARS 10082 DOUBLE PRECISION 10083 + ONE,TEN,XMAX,XMIN,ZERO 10084 INTEGER 10085 + I,J 10086 LOGICAL 10087 + BIGDIF 10088 10089C...INTRINSIC FUNCTIONS 10090 INTRINSIC 10091 + ABS,LOG10,MAX,MIN 10092 10093C...DATA STATEMENTS 10094 DATA 10095 + ZERO,ONE,TEN 10096 + /0.0D0,1.0D0,10.0D0/ 10097 10098C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10099C BIGDIF: THE VARIABLE DESIGNATING WHETHER THERE IS A SIGNIFICANT 10100C DIFFERENCE IN THE MAGNITUDES OF THE NONZERO ELEMENTS OF 10101C X (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). 10102C I: AN INDEXING VARIABLE. 10103C J: AN INDEXING VARIABLE. 10104C LDTT: THE LEADING DIMENSION OF ARRAY TT. 10105C LDX: THE LEADING DIMENSION OF ARRAY X. 10106C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. 10107C N: THE NUMBER OF OBSERVATIONS. 10108C ONE: THE VALUE 1.0D0. 10109C TT: THE SCALING VALUES FOR DELTA. 10110C X: THE INDEPENDENT VARIABLE. 10111C XMAX: THE LARGEST NONZERO MAGNITUDE. 10112C XMIN: THE SMALLEST NONZERO MAGNITUDE. 10113C ZERO: THE VALUE 0.0D0. 10114 10115 10116C***FIRST EXECUTABLE STATEMENT DSCLD 10117 10118 10119 DO 50 J=1,M 10120 XMAX = ABS(X(1,J)) 10121 DO 10 I=2,N 10122 XMAX = MAX(XMAX,ABS(X(I,J))) 10123 10 CONTINUE 10124 10125 IF (XMAX.EQ.ZERO) THEN 10126 10127C ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO 10128 10129 DO 20 I=1,N 10130 TT(I,J) = ONE 10131 20 CONTINUE 10132 10133 ELSE 10134 10135C SOME OF THE INPUT VALUES ARE NONZERO 10136 10137 XMIN = XMAX 10138 DO 30 I=1,N 10139 IF (X(I,J).NE.ZERO) THEN 10140 XMIN = MIN(XMIN,ABS(X(I,J))) 10141 END IF 10142 30 CONTINUE 10143 BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE 10144 DO 40 I=1,N 10145 IF (X(I,J).NE.ZERO) THEN 10146 IF (BIGDIF) THEN 10147 TT(I,J) = ONE/ABS(X(I,J)) 10148 ELSE 10149 TT(I,J) = ONE/XMAX 10150 END IF 10151 ELSE 10152 TT(I,J) = TEN/XMIN 10153 END IF 10154 40 CONTINUE 10155 END IF 10156 50 CONTINUE 10157 10158 RETURN 10159 END 10160*DSETN 10161 SUBROUTINE DSETN 10162 + (N,M,X,LDX,NROW) 10163C***BEGIN PROLOGUE DSETN 10164C***REFER TO DODR,DODRC 10165C***ROUTINES CALLED (NONE) 10166C***DATE WRITTEN 860529 (YYMMDD) 10167C***REVISION DATE 920304 (YYMMDD) 10168C***PURPOSE SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED 10169C***END PROLOGUE DSETN 10170 10171C...SCALAR ARGUMENTS 10172 INTEGER 10173 + LDX,M,N,NROW 10174 10175C...ARRAY ARGUMENTS 10176 DOUBLE PRECISION 10177 + X(LDX,M) 10178 10179C...LOCAL SCALARS 10180 INTEGER 10181 + I,J 10182 10183C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10184C I: AN INDEX VARIABLE. 10185C J: AN INDEX VARIABLE. 10186C LDX: THE LEADING DIMENSION OF ARRAY X. 10187C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. 10188C N: THE NUMBER OF OBSERVATIONS. 10189C NROW: THE SELECTED ROW NUMBER OF THE INDEPENDENT VARIABLE. 10190C X: THE INDEPENDENT VARIABLE. 10191 10192 10193C***FIRST EXECUTABLE STATEMENT DSETN 10194 10195 10196 IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN 10197 10198C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS 10199C IF THERE IS ONE, OTHERWISE FIRST ROW IS USED. 10200 10201 DO 20 I = 1, N 10202 DO 10 J = 1, M 10203 IF (X(I,J).EQ.0.0) GO TO 20 10204 10 CONTINUE 10205 NROW = I 10206 RETURN 10207 20 CONTINUE 10208 10209 NROW = 1 10210 10211 RETURN 10212 END 10213*DSOLVE 10214 SUBROUTINE DSOLVE(N,T,LDT,B,LDB,JOB) 10215C***BEGIN PROLOGUE DSOLVE 10216C***REFER TO DODR,DODRC 10217C***ROUTINES CALLED DAXPY,DDOT 10218C***DATE WRITTEN 920220 (YYMMDD) 10219C***REVISION DATE 920619 (YYMMDD) 10220C***PURPOSE SOLVE SYSTEMS OF THE FORM 10221C T * X = B OR TRANS(T) * X = B 10222C WHERE T IS AN UPPER OR LOWER TRIANGULAR MATRIX OF ORDER N, 10223C AND THE SOLUTION X OVERWRITES THE RHS B. 10224C (ADAPTED FROM LINPACK SUBROUTINE DTRSL) 10225C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., 10226C *LINPACK USERS GUIDE*, SIAM, 1979. 10227C***END PROLOGUE DSOLVE 10228 10229C...SCALAR ARGUMENTS 10230 INTEGER 10231 + JOB,LDB,LDT,N 10232 10233C...ARRAY ARGUMENTS 10234 DOUBLE PRECISION 10235 + B(LDB,N),T(LDT,N) 10236 10237C...LOCAL SCALARS 10238 DOUBLE PRECISION 10239 + TEMP,ZERO 10240 INTEGER 10241 + J1,J,JN 10242 10243C...EXTERNAL FUNCTIONS 10244 DOUBLE PRECISION 10245 + DDOT 10246 EXTERNAL 10247 + DDOT 10248 10249C...EXTERNAL SUBROUTINES 10250 EXTERNAL 10251 + DAXPY 10252 10253C...DATA STATEMENTS 10254 DATA 10255 + ZERO 10256 + /0.0D0/ 10257 10258C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10259C B: ON INPUT: THE RIGHT HAND SIDE; ON EXIT: THE SOLUTION 10260C J1: THE FIRST NONZERO ENTRY IN T. 10261C J: AN INDEXING VARIABLE. 10262C JN: THE LAST NONZERO ENTRY IN T. 10263C JOB: WHAT KIND OF SYSTEM IS TO BE SOLVED, WHERE IF JOB IS 10264C 1 SOLVE T*X=B, T LOWER TRIANGULAR, 10265C 2 SOLVE T*X=B, T UPPER TRIANGULAR, 10266C 3 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, 10267C 4 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. 10268C LDB: THE LEADING DIMENSION OF ARRAY B. 10269C LDT: THE LEADING DIMENSION OF ARRAY T. 10270C N: THE NUMBER OF ROWS AND COLUMNS OF DATA IN ARRAY T. 10271C T: THE UPPER OR LOWER TRIDIAGONAL SYSTEM. 10272C ZERO: THE VALUE 0.0D0. 10273 10274 10275C***FIRST EXECUTABLE STATEMENT DSOLVE 10276 10277 10278C FIND FIRST NONZERO DIAGONAL ENTRY IN T 10279 J1 = 0 10280 DO 10 J=1,N 10281 IF (J1.EQ.0 .AND. T(J,J).NE.ZERO) THEN 10282 J1 = J 10283 ELSE IF (T(J,J).EQ.ZERO) THEN 10284 B(1,J) = ZERO 10285 END IF 10286 10 CONTINUE 10287 IF (J1.EQ.0) RETURN 10288 10289C FIND LAST NONZERO DIAGONAL ENTRY IN T 10290 JN = 0 10291 DO 20 J=N,J1,-1 10292 IF (JN.EQ.0 .AND. T(J,J).NE.ZERO) THEN 10293 JN = J 10294 ELSE IF (T(J,J).EQ.ZERO) THEN 10295 B(1,J) = ZERO 10296 END IF 10297 20 CONTINUE 10298 10299 IF (JOB.EQ.1) THEN 10300 10301C SOLVE T*X=B FOR T LOWER TRIANGULAR 10302 B(1,J1) = B(1,J1)/T(J1,J1) 10303 DO 30 J = J1+1, JN 10304 TEMP = -B(1,J-1) 10305 CALL DAXPY(JN-J+1,TEMP,T(J,J-1),1,B(1,J),LDB) 10306 IF (T(J,J).NE.ZERO) THEN 10307 B(1,J) = B(1,J)/T(J,J) 10308 ELSE 10309 B(1,J) = ZERO 10310 END IF 10311 30 CONTINUE 10312 10313 ELSE IF (JOB.EQ.2) THEN 10314 10315C SOLVE T*X=B FOR T UPPER TRIANGULAR. 10316 B(1,JN) = B(1,JN)/T(JN,JN) 10317 DO 40 J = JN-1,J1,-1 10318 TEMP = -B(1,J+1) 10319 CALL DAXPY(J,TEMP,T(1,J+1),1,B(1,1),LDB) 10320 IF (T(J,J).NE.ZERO) THEN 10321 B(1,J) = B(1,J)/T(J,J) 10322 ELSE 10323 B(1,J) = ZERO 10324 END IF 10325 40 CONTINUE 10326 10327 ELSE IF (JOB.EQ.3) THEN 10328 10329C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. 10330 B(1,JN) = B(1,JN)/T(JN,JN) 10331 DO 50 J = JN-1,J1,-1 10332 B(1,J) = B(1,J) - DDOT(JN-J+1,T(J+1,J),1,B(1,J+1),LDB) 10333 IF (T(J,J).NE.ZERO) THEN 10334 B(1,J) = B(1,J)/T(J,J) 10335 ELSE 10336 B(1,J) = ZERO 10337 END IF 10338 50 CONTINUE 10339 10340 ELSE IF (JOB.EQ.4) THEN 10341 10342C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. 10343 B(1,J1) = B(1,J1)/T(J1,J1) 10344 DO 60 J = J1+1,JN 10345 B(1,J) = B(1,J) - DDOT(J-1,T(1,J),1,B(1,1),LDB) 10346 IF (T(J,J).NE.ZERO) THEN 10347 B(1,J) = B(1,J)/T(J,J) 10348 ELSE 10349 B(1,J) = ZERO 10350 END IF 10351 60 CONTINUE 10352 END IF 10353 10354 RETURN 10355 END 10356*DUNPAC 10357 SUBROUTINE DUNPAC 10358 + (N2,V1,V2,IFIX) 10359C***BEGIN PROLOGUE DUNPAC 10360C***REFER TO DODR,DODRC 10361C***ROUTINES CALLED DCOPY 10362C***DATE WRITTEN 860529 (YYMMDD) 10363C***REVISION DATE 920304 (YYMMDD) 10364C***PURPOSE COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE 10365C UNFIXED 10366C***END PROLOGUE DUNPAC 10367 10368C...SCALAR ARGUMENTS 10369 INTEGER 10370 + N2 10371 10372C...ARRAY ARGUMENTS 10373 DOUBLE PRECISION 10374 + V1(N2),V2(N2) 10375 INTEGER 10376 + IFIX(N2) 10377 10378C...LOCAL SCALARS 10379 INTEGER 10380 + I,N1 10381 10382C...EXTERNAL SUBROUTINES 10383 EXTERNAL 10384 + DCOPY 10385 10386C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10387C I: AN INDEXING VARIABLE. 10388C IFIX: THE VALUES DESIGNATING WHETHER THE ELEMENTS OF V2 ARE 10389C FIXED AT THEIR INPUT VALUES OR NOT. 10390C ODRPACK REFERENCE GUIDE.) 10391C N1: THE NUMBER OF ITEMS IN V1. 10392C N2: THE NUMBER OF ITEMS IN V2. 10393C V1: THE VECTOR OF THE UNFIXED ITEMS. 10394C V2: THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE 10395C ELEMENTS OF V1 ARE TO BE INSERTED. 10396 10397 10398C***FIRST EXECUTABLE STATEMENT DUNPAC 10399 10400 10401 N1 = 0 10402 IF (IFIX(1).GE.0) THEN 10403 DO 10 I = 1,N2 10404 IF (IFIX(I).NE.0) THEN 10405 N1 = N1 + 1 10406 V2(I) = V1(N1) 10407 END IF 10408 10 CONTINUE 10409 ELSE 10410 N1 = N2 10411 CALL DCOPY(N2,V1,1,V2,1) 10412 END IF 10413 10414 RETURN 10415 END 10416*DVEVTR 10417 SUBROUTINE DVEVTR 10418 + (M,NQ,INDX, 10419 + V,LDV,LD2V, E,LDE, VE,LDVE,LD2VE, VEV,LDVEV, 10420 + WRK5) 10421C***BEGIN PROLOGUE DVEVTR 10422C***REFER TO DODR,DODRC 10423C***ROUTINES CALLED DSOLVE 10424C***DATE WRITTEN 910613 (YYMMDD) 10425C***REVISION DATE 920304 (YYMMDD) 10426C***PURPOSE COMPUTE V*E*TRANS(V) FOR THE (INDX)TH M BY NQ ARRAY IN V 10427C***END PROLOGUE DVEVTR 10428 10429C...SCALAR ARGUMENTS 10430 INTEGER 10431 + INDX,LDE,LDV,LDVE,LDVEV,LD2V,LD2VE,M,NQ 10432 10433C...ARRAY ARGUMENTS 10434 DOUBLE PRECISION 10435 + E(LDE,M),V(LDV,LD2V,NQ),VE(LDVE,LD2VE,M),VEV(LDVEV,NQ),WRK5(M) 10436 10437C...LOCAL SCALARS 10438 DOUBLE PRECISION 10439 + ZERO 10440 INTEGER 10441 + J,L1,L2 10442 10443C...EXTERNAL SUBROUTINES 10444 EXTERNAL 10445 + DSOLVE 10446 10447C...DATA STATEMENTS 10448 DATA 10449 + ZERO 10450 + /0.0D0/ 10451 10452C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10453C INDX: THE ROW IN V IN WHICH THE M BY NQ ARRAY IS STORED. 10454C J: AN INDEXING VARIABLE. 10455C LDE: THE LEADING DIMENSION OF ARRAY E. 10456C LDV: THE LEADING DIMENSION OF ARRAY V. 10457C LDVE: THE LEADING DIMENSION OF ARRAY VE. 10458C LDVEV: THE LEADING DIMENSION OF ARRAY VEV. 10459C LD2V: THE SECOND DIMENSION OF ARRAY V. 10460C L1: AN INDEXING VARIABLE. 10461C L2: AN INDEXING VARIABLE. 10462C M: THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. 10463C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 10464C E: THE M BY M MATRIX OF THE FACTORS SO ETE = (D**2 + ALPHA*T**2). 10465C V: AN ARRAY OF NQ BY M MATRICES. 10466C VE: THE NQ BY M ARRAY VE = V * INV(E) 10467C VEV: THE NQ BY NQ ARRAY VEV = V * INV(ETE) * TRANS(V). 10468C WRK5: AN M WORK VECTOR. 10469C ZERO: THE VALUE 0.0D0. 10470 10471 10472C***FIRST EXECUTABLE STATEMENT DVEVTR 10473 10474 10475 IF (NQ.EQ.0 .OR. M.EQ.0) RETURN 10476 10477 DO 140 L1 = 1,NQ 10478 DO 110 J = 1,M 10479 WRK5(J) = V(INDX,J,L1) 10480 110 CONTINUE 10481 CALL DSOLVE(M,E,LDE,WRK5,1,4) 10482 DO 120 J = 1,M 10483 VE(INDX,L1,J) = WRK5(J) 10484 120 CONTINUE 10485 140 CONTINUE 10486 10487 DO 230 L1 = 1,NQ 10488 DO 220 L2 = 1,L1 10489 VEV(L1,L2) = ZERO 10490 DO 210 J = 1,M 10491 VEV(L1,L2) = VEV(L1,L2) + VE(INDX,L1,J)*VE(INDX,L2,J) 10492 210 CONTINUE 10493 VEV(L2,L1) = VEV(L1,L2) 10494 220 CONTINUE 10495 230 CONTINUE 10496 10497 RETURN 10498 END 10499*DWGHT 10500 SUBROUTINE DWGHT 10501 + (N,M,WT,LDWT,LD2WT,T,LDT,WTT,LDWTT) 10502C***BEGIN PROLOGUE DWGHT 10503C***REFER TO DODR,DODRC 10504C***ROUTINES CALLED (NONE) 10505C***DATE WRITTEN 860529 (YYMMDD) 10506C***REVISION DATE 920304 (YYMMDD) 10507C***PURPOSE SCALE MATRIX T USING WT, I.E., COMPUTE WTT = WT*T 10508C***END PROLOGUE DWGHT 10509 10510C...SCALAR ARGUMENTS 10511 INTEGER 10512 + LDT,LDWT,LDWTT,LD2WT,M,N 10513 10514C...ARRAY ARGUMENTS 10515 DOUBLE PRECISION 10516 + T(LDT,M),WT(LDWT,LD2WT,M),WTT(LDWTT,M) 10517 10518C...LOCAL SCALARS 10519 DOUBLE PRECISION 10520 + TEMP,ZERO 10521 INTEGER 10522 + I,J,K 10523 10524C...INTRINSIC FUNCTIONS 10525 INTRINSIC 10526 + ABS 10527 10528C...DATA STATEMENTS 10529 DATA 10530 + ZERO 10531 + /0.0D0/ 10532 10533C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10534C I: AN INDEXING VARIABLE. 10535C J: AN INDEXING VARIABLE. 10536C K: AN INDEXING VARIABLE. 10537C LDT: THE LEADING DIMENSION OF ARRAY T. 10538C LDWT: THE LEADING DIMENSION OF ARRAY WT. 10539C LDWTT: THE LEADING DIMENSION OF ARRAY WTT. 10540C LD2WT: THE SECOND DIMENSION OF ARRAY WT. 10541C M: THE NUMBER OF COLUMNS OF DATA IN T. 10542C N: THE NUMBER OF ROWS OF DATA IN T. 10543C T: THE ARRAY BEING SCALED BY WT. 10544C TEMP: A TEMPORARY SCALAR. 10545C WT: THE WEIGHTS. 10546C WTT: THE RESULTS OF WEIGHTING ARRAY T BY WT. 10547C ARRAY WTT CAN BE THE SAME AS T ONLY IF THE ARRAYS IN WT 10548C ARE UPPER TRIANGULAR WITH ZEROS BELOW THE DIAGONAL. 10549C ZERO: THE VALUE 0.0D0. 10550 10551 10552C***FIRST EXECUTABLE STATEMENT DWGHT 10553 10554 10555 IF (N.EQ.0 .OR. M.EQ.0) RETURN 10556 10557 IF (WT(1,1,1).GE.ZERO) THEN 10558 IF (LDWT.GE.N) THEN 10559 IF (LD2WT.GE.M) THEN 10560C WT IS AN N-ARRAY OF M BY M MATRICES 10561 DO 130 I=1,N 10562 DO 120 J=1,M 10563 TEMP = ZERO 10564 DO 110 K=1,M 10565 TEMP = TEMP + WT(I,J,K)*T(I,K) 10566 110 CONTINUE 10567 WTT(I,J) = TEMP 10568 120 CONTINUE 10569 130 CONTINUE 10570 ELSE 10571C WT IS AN N-ARRAY OF DIAGONAL MATRICES 10572 DO 230 I=1,N 10573 DO 220 J=1,M 10574 WTT(I,J) = WT(I,1,J)*T(I,J) 10575 220 CONTINUE 10576 230 CONTINUE 10577 END IF 10578 ELSE 10579 IF (LD2WT.GE.M) THEN 10580C WT IS AN M BY M MATRIX 10581 DO 330 I=1,N 10582 DO 320 J=1,M 10583 TEMP = ZERO 10584 DO 310 K=1,M 10585 TEMP = TEMP + WT(1,J,K)*T(I,K) 10586 310 CONTINUE 10587 WTT(I,J) = TEMP 10588 320 CONTINUE 10589 330 CONTINUE 10590 ELSE 10591C WT IS A DIAGONAL MATRICE 10592 DO 430 I=1,N 10593 DO 420 J=1,M 10594 WTT(I,J) = WT(1,1,J)*T(I,J) 10595 420 CONTINUE 10596 430 CONTINUE 10597 END IF 10598 END IF 10599 ELSE 10600C WT IS A SCALAR 10601 DO 520 J=1,M 10602 DO 510 I=1,N 10603 WTT(I,J) = ABS(WT(1,1,1))*T(I,J) 10604 510 CONTINUE 10605 520 CONTINUE 10606 END IF 10607 10608 RETURN 10609 END 10610*DWINF 10611 SUBROUTINE DWINF 10612 + (N,M,NP,NQ,LDWE,LD2WE,ISODR, 10613 + DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI, 10614 + RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI, 10615 + OLMAVI,TAUI,ALPHAI,ACTRSI,PNORMI,RNORSI,PRERSI, 10616 + PARTLI,SSTOLI,TAUFCI,EPSMAI, 10617 + BETA0I,BETACI,BETASI,BETANI,SI,SSI,SSFI,QRAUXI,UI, 10618 + FSI,FJACBI,WE1I,DIFFI, 10619 + DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI, 10620 + WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, 10621 + LWKMN) 10622C***BEGIN PROLOGUE DWINF 10623C***REFER TO DODR,DODRC 10624C***ROUTINES CALLED (NONE) 10625C***DATE WRITTEN 860529 (YYMMDD) 10626C***REVISION DATE 920619 (YYMMDD) 10627C***PURPOSE SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE 10628C***END PROLOGUE DWINF 10629 10630C...SCALAR ARGUMENTS 10631 INTEGER 10632 + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,BETA0I,DELTAI,DELTNI,DELTSI, 10633 + DIFFI,EPSI,EPSMAI,ETAI,FJACBI,FJACDI,FNI,FSI,LDWE,LD2WE,LWKMN, 10634 + M,N,NP,NQ,OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI, 10635 + RNORSI,RVARI,SDI,SI,SSFI,SSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI, 10636 + WE1I,WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I, 10637 + WSSI,WSSDEI,WSSEPI,XPLUSI 10638 LOGICAL 10639 + ISODR 10640 10641C...LOCAL SCALARS 10642 INTEGER 10643 + NEXT 10644 10645C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10646C ACTRSI: THE LOCATION IN ARRAY WORK OF VARIABLE ACTRS. 10647C ALPHAI: THE LOCATION IN ARRAY WORK OF VARIABLE ALPHA. 10648C BETACI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAC. 10649C BETANI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAN. 10650C BETASI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETAS. 10651C BETA0I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY BETA0. 10652C DELTAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTA. 10653C DELTNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAN. 10654C DELTSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DELTAS. 10655C DIFFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY DIFF. 10656C EPSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY EPS. 10657C EPSMAI: THE LOCATION IN ARRAY WORK OF VARIABLE EPSMAC. 10658C ETAI: THE LOCATION IN ARRAY WORK OF VARIABLE ETA. 10659C FJACBI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACB. 10660C FJACDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FJACD. 10661C FNI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FN. 10662C FSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY FS. 10663C ISODR: THE VARIABLE DESIGNATING WHETHER THE SOLUTION IS BY ODR 10664C (ISODR=TRUE) OR BY OLS (ISODR=FALSE). 10665C LDWE: THE LEADING DIMENSION OF ARRAY WE. 10666C LD2WE: THE SECOND DIMENSION OF ARRAY WE. 10667C LWKMN: THE MINIMUM ACCEPTABLE LENGTH OF VECTOR WORK. 10668C M: THE NUMBER OF COLUMNS OF DATA IN THE EXPLANATORY VARIABLE. 10669C N: THE NUMBER OF OBSERVATIONS. 10670C NEXT: THE NEXT AVAILABLE LOCATION WITH WORK. 10671C NP: THE NUMBER OF FUNCTION PARAMETERS. 10672C NQ: THE NUMBER OF RESPONSES PER OBSERVATION. 10673C OLMAVI: THE LOCATION IN ARRAY WORK OF VARIABLE OLMAVG. 10674C OMEGAI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY OMEGA. 10675C PARTLI: THE LOCATION IN ARRAY WORK OF VARIABLE PARTOL. 10676C PNORMI: THE LOCATION IN ARRAY WORK OF VARIABLE PNORM. 10677C PRERSI: THE LOCATION IN ARRAY WORK OF VARIABLE PRERS. 10678C QRAUXI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY QRAUX. 10679C RCONDI: THE LOCATION IN ARRAY WORK OF VARIABLE RCONDI. 10680C RNORSI: THE LOCATION IN ARRAY WORK OF VARIABLE RNORMS. 10681C RVARI: THE LOCATION IN ARRAY WORK OF VARIABLE RVAR. 10682C SDI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SD. 10683C SI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY S. 10684C SSFI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SSF. 10685C SSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY SS. 10686C SSTOLI: THE LOCATION IN ARRAY WORK OF VARIABLE SSTOL. 10687C TAUFCI: THE LOCATION IN ARRAY WORK OF VARIABLE TAUFAC. 10688C TAUI: THE LOCATION IN ARRAY WORK OF VARIABLE TAU. 10689C TI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY T. 10690C TTI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY TT. 10691C UI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY U. 10692C VCVI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY VCV. 10693C WE1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WE1. 10694C WRK1I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK1. 10695C WRK2I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK2. 10696C WRK3I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK3. 10697C WRK4I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK4. 10698C WRK5I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK5. 10699C WRK6I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK6. 10700C WRK7I: THE STARTING LOCATION IN ARRAY WORK OF ARRAY WRK7. 10701C WSSI: THE LOCATION IN ARRAY WORK OF VARIABLE WSS. 10702C WSSDEI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSDEL. 10703C WSSEPI: THE LOCATION IN ARRAY WORK OF VARIABLE WSSEPS. 10704C XPLUSI: THE STARTING LOCATION IN ARRAY WORK OF ARRAY XPLUSD. 10705 10706 10707C***FIRST EXECUTABLE STATEMENT DWINF 10708 10709 10710 IF (N.GE.1 .AND. M.GE.1 .AND. NP.GE.1 .AND. NQ.GE.1 .AND. 10711 + LDWE.GE.1 .AND. LD2WE.GE.1) THEN 10712 10713 DELTAI = 1 10714 EPSI = DELTAI + N*M 10715 XPLUSI = EPSI + N*NQ 10716 FNI = XPLUSI + N*M 10717 SDI = FNI + N*NQ 10718 VCVI = SDI + NP 10719 RVARI = VCVI + NP*NP 10720 10721 WSSI = RVARI + 1 10722 WSSDEI = WSSI + 1 10723 WSSEPI = WSSDEI + 1 10724 RCONDI = WSSEPI + 1 10725 ETAI = RCONDI + 1 10726 OLMAVI = ETAI + 1 10727 10728 TAUI = OLMAVI + 1 10729 ALPHAI = TAUI + 1 10730 ACTRSI = ALPHAI + 1 10731 PNORMI = ACTRSI + 1 10732 RNORSI = PNORMI + 1 10733 PRERSI = RNORSI + 1 10734 PARTLI = PRERSI + 1 10735 SSTOLI = PARTLI + 1 10736 TAUFCI = SSTOLI + 1 10737 EPSMAI = TAUFCI + 1 10738 BETA0I = EPSMAI + 1 10739 10740 BETACI = BETA0I + NP 10741 BETASI = BETACI + NP 10742 BETANI = BETASI + NP 10743 SI = BETANI + NP 10744 SSI = SI + NP 10745 SSFI = SSI + NP 10746 QRAUXI = SSFI + NP 10747 UI = QRAUXI + NP 10748 FSI = UI + NP 10749 10750 FJACBI = FSI + N*NQ 10751 10752 WE1I = FJACBI + N*NP*NQ 10753 10754 DIFFI = WE1I + LDWE*LD2WE*NQ 10755 10756 NEXT = DIFFI + NQ*(NP+M) 10757 10758 IF (ISODR) THEN 10759 DELTSI = NEXT 10760 DELTNI = DELTSI + N*M 10761 TI = DELTNI + N*M 10762 TTI = TI + N*M 10763 OMEGAI = TTI + N*M 10764 FJACDI = OMEGAI + NQ*NQ 10765 WRK1I = FJACDI + N*M*NQ 10766 NEXT = WRK1I + N*M*NQ 10767 ELSE 10768 DELTSI = DELTAI 10769 DELTNI = DELTAI 10770 TI = DELTAI 10771 TTI = DELTAI 10772 OMEGAI = DELTAI 10773 FJACDI = DELTAI 10774 WRK1I = DELTAI 10775 END IF 10776 10777 WRK2I = NEXT 10778 WRK3I = WRK2I + N*NQ 10779 WRK4I = WRK3I + NP 10780 WRK5I = WRK4I + M*M 10781 WRK6I = WRK5I + M 10782 WRK7I = WRK6I + N*NQ*NP 10783 NEXT = WRK7I + 5*NQ 10784 10785 LWKMN = NEXT 10786 ELSE 10787 DELTAI = 1 10788 EPSI = 1 10789 XPLUSI = 1 10790 FNI = 1 10791 SDI = 1 10792 VCVI = 1 10793 RVARI = 1 10794 WSSI = 1 10795 WSSDEI = 1 10796 WSSEPI = 1 10797 RCONDI = 1 10798 ETAI = 1 10799 OLMAVI = 1 10800 TAUI = 1 10801 ALPHAI = 1 10802 ACTRSI = 1 10803 PNORMI = 1 10804 RNORSI = 1 10805 PRERSI = 1 10806 PARTLI = 1 10807 SSTOLI = 1 10808 TAUFCI = 1 10809 EPSMAI = 1 10810 BETA0I = 1 10811 BETACI = 1 10812 BETASI = 1 10813 BETANI = 1 10814 SI = 1 10815 SSI = 1 10816 SSFI = 1 10817 QRAUXI = 1 10818 FSI = 1 10819 UI = 1 10820 FJACBI = 1 10821 WE1I = 1 10822 DIFFI = 1 10823 DELTSI = 1 10824 DELTNI = 1 10825 TI = 1 10826 TTI = 1 10827 FJACDI = 1 10828 OMEGAI = 1 10829 WRK1I = 1 10830 WRK2I = 1 10831 WRK3I = 1 10832 WRK4I = 1 10833 WRK5I = 1 10834 WRK6I = 1 10835 WRK7I = 1 10836 LWKMN = 1 10837 END IF 10838 10839 RETURN 10840 END 10841*DXMY 10842 SUBROUTINE DXMY 10843 + (N,M,X,LDX,Y,LDY,XMY,LDXMY) 10844C***BEGIN PROLOGUE DXMY 10845C***REFER TO DODR,DODRC 10846C***ROUTINES CALLED (NONE) 10847C***DATE WRITTEN 860529 (YYMMDD) 10848C***REVISION DATE 920304 (YYMMDD) 10849C***PURPOSE COMPUTE XMY = X - Y 10850C***END PROLOGUE DXMY 10851 10852C...SCALAR ARGUMENTS 10853 INTEGER 10854 + LDX,LDXMY,LDY,M,N 10855 10856C...ARRAY ARGUMENTS 10857 DOUBLE PRECISION 10858 + X(LDX,M),XMY(LDXMY,M),Y(LDY,M) 10859 10860C...LOCAL SCALARS 10861 INTEGER 10862 + I,J 10863 10864C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10865C I: AN INDEXING VARIABLE. 10866C J: AN INDEXING VARIABLE. 10867C LDX: THE LEADING DIMENSION OF ARRAY X. 10868C LDXMY: THE LEADING DIMENSION OF ARRAY XMY. 10869C LDY: THE LEADING DIMENSION OF ARRAY Y. 10870C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. 10871C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. 10872C X: THE FIRST OF THE TWO ARRAYS. 10873C XMY: THE VALUES OF X-Y. 10874C Y: THE SECOND OF THE TWO ARRAYS. 10875 10876 10877C***FIRST EXECUTABLE STATEMENT DXMY 10878 10879 10880 DO 20 J=1,M 10881 DO 10 I=1,N 10882 XMY(I,J) = X(I,J) - Y(I,J) 10883 10 CONTINUE 10884 20 CONTINUE 10885 10886 RETURN 10887 END 10888*DXPY 10889 SUBROUTINE DXPY 10890 + (N,M,X,LDX,Y,LDY,XPY,LDXPY) 10891C***BEGIN PROLOGUE DXPY 10892C***REFER TO DODR,DODRC 10893C***ROUTINES CALLED (NONE) 10894C***DATE WRITTEN 860529 (YYMMDD) 10895C***REVISION DATE 920304 (YYMMDD) 10896C***PURPOSE COMPUTE XPY = X + Y 10897C***END PROLOGUE DXPY 10898 10899C...SCALAR ARGUMENTS 10900 INTEGER 10901 + LDX,LDXPY,LDY,M,N 10902 10903C...ARRAY ARGUMENTS 10904 DOUBLE PRECISION 10905 + X(LDX,M),XPY(LDXPY,M),Y(LDY,M) 10906 10907C...LOCAL SCALARS 10908 INTEGER 10909 + I,J 10910 10911C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10912C I: AN INDEXING VARIABLE. 10913C J: AN INDEXING VARIABLE. 10914C LDX: THE LEADING DIMENSION OF ARRAY X. 10915C LDXPY: THE LEADING DIMENSION OF ARRAY XPY. 10916C LDY: THE LEADING DIMENSION OF ARRAY Y. 10917C M: THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y. 10918C N: THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y. 10919C X: THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER. 10920C XPY: THE VALUES OF X+Y. 10921C Y: THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER. 10922 10923 10924C***FIRST EXECUTABLE STATEMENT DXPY 10925 10926 10927 DO 20 J=1,M 10928 DO 10 I=1,N 10929 XPY(I,J) = X(I,J) + Y(I,J) 10930 10 CONTINUE 10931 20 CONTINUE 10932 10933 RETURN 10934 END 10935*DZERO 10936 SUBROUTINE DZERO 10937 + (N,M,A,LDA) 10938C***BEGIN PROLOGUE DZERO 10939C***REFER TO DODR,DODRC 10940C***ROUTINES CALLED (NONE) 10941C***DATE WRITTEN 860529 (YYMMDD) 10942C***REVISION DATE 920304 (YYMMDD) 10943C***PURPOSE SET A = ZERO 10944C***END PROLOGUE DZERO 10945 10946C...SCALAR ARGUMENTS 10947 INTEGER 10948 + LDA,M,N 10949 10950C...ARRAY ARGUMENTS 10951 DOUBLE PRECISION 10952 + A(LDA,M) 10953 10954C...LOCAL SCALARS 10955 DOUBLE PRECISION 10956 + ZERO 10957 INTEGER 10958 + I,J 10959 10960C...DATA STATEMENTS 10961 DATA 10962 + ZERO 10963 + /0.0D0/ 10964 10965C...VARIABLE DEFINITIONS (ALPHABETICALLY) 10966C A: THE ARRAY TO BE SET TO ZERO. 10967C I: AN INDEXING VARIABLE. 10968C J: AN INDEXING VARIABLE. 10969C LDA: THE LEADING DIMENSION OF ARRAY A. 10970C M: THE NUMBER OF COLUMNS TO BE SET TO ZERO. 10971C N: THE NUMBER OF ROWS TO BE SET TO ZERO. 10972C ZERO: THE VALUE 0.0D0. 10973 10974 10975C***FIRST EXECUTABLE STATEMENT DZERO 10976 10977 10978 DO 20 J=1,M 10979 DO 10 I=1,N 10980 A(I,J) = ZERO 10981 10 CONTINUE 10982 20 CONTINUE 10983 10984 RETURN 10985 END 10986