C ALGORITHM 676, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 15, NO. 4, PP. 348-364. Installation Manual for ODRPACK 1.71 -- Software for Weighted Orthogonal Distance Regression Direct questions to Janet R. Donaldson Optimization Group/Applied and Computational Mathematics Division (719) National Institute of Standards and Technology 325 Broadway Boulder, CO 80303-3328 (303) 497-5114 e-mail: internet -- jrd@alpha.bldr.nist.gov bitnet -- jrd@nbs *** PHYSICAL CHARACTERISTICS OF TAPE A. ASCII character set. B. 1600 cpi density. C. Unlabeled. D. 17 files each repeated 3 times for a total of 51 files, each terminated by tapemarks. E. Additional tapemark follows tapemark of last file. F. Files consist of 1 or more blocks (physical records). G. Files 1 to 16, 18 to 33, and 35 to 50 have blocks made up of 45 line images (logical records) of 80 characters each. H. Files 17, 34, and 51 have blocks made up of 20 line images (logical records) of 132 characters each. I. Last block of a file may contain fewer than 20 line images, in which case it is short, not blank filled. *** TAPE CONTENTS File No. File Id. Description -------- ----------- ----------- 1 TOC.DOC - tape characteristics, file structure and table of contents (line image length = 80, block size = 3600) 2 INSTALL.DOC - the installation manual (line image length = 80, block size = 3600) 3 GUIDE.DOC - ODRPACK user's reference guide, in line printer format (line image length = 80, block size = 3600) 4 SODR.FOR - single precision ODRPACK source code, excluding LINPACK, BLAS and machine dependent subprograms (line image length = 80, block size = 3600) 5 SODRLPK.FOR - single precision subprograms from LINPACK and BLAS (line image length = 80, block size = 3600) 6 SMPREC.FOR - single precision machine dependent subprogram (line image length = 80, block size = 3600) 7 DODR.FOR - double precision ODRPACK source code, excluding LINPACK, BLAS and machine dependent subprograms (line image length = 80, block size = 3600) 8 DODRLPK.FOR - double precision subprograms from LINPACK and BLAS (line image length = 80, block size = 3600) 9 DMPREC.FOR - double precision machine dependent subprogram (line image length = 80, block size = 3600) 10 SDRIVE1.FOR - sample driver for single precision user-callable subprogram SODR (line image length = 80, block size = 3600) 11 SDRIVE2.FOR - sample driver for single precision user-callable subprogram SODRC (line image length = 80, block size = 3600) 12 DDRIVE1.FOR - sample driver for double precision user-callable subprogram DODR (line image length = 80, block size = 3600) 13 DDRIVE2.FOR - sample driver for double precision user-callable subprogram DODRC (line image length = 80, block size = 3600) 14 DATA1.DAT - data set for sample drivers in files SDRIVE1.FOR, SDRIVE2.FOR, DDRIVE1.FOR, and DDRIVE2.FOR. (line image length = 80, block size = 3600) 15 STEST.FOR - driver for exercising single precision version of ODRPACK (line image length = 80, block size = 3600) 16 DTEST.FOR - driver for exercising double precision version of ODRPACK (line image length = 80, block size = 3600) 17 TEST.TXT - results obtained by the authors exercising the double precision version of ODRPACK on a Sun 3 Workstation (64 bits per double precision value) (line image length = 132, block size = 2640) 18 to 34 - repeat of files 1 to 17 35 to 51 - repeat of files 1 to 17 *** INTRODUCTION ODRPACK is a portable collection of Fortran subprograms for fitting a model to data. It is designed primarily for instances when the independent as well as the dependent variables have significant errors, implementing a highly efficient algorithm for solving the weighted orthogonal distance regression problem, i.e., for minimizing the sum of the squares of the weighted orthogonal distances between each data point and the curve described by the model equation. It can also be used to solve the ordinary least squares problem where all of the errors are attributed to the observations of the dependent variable. ODRPACK is written in Fortran as defined in the 1978 standard (ANSI X3.9-1978), commonly called Fortran 77. The code has been analyzed using the PFORT 77 verifyer in TOOLPACK, and based on this analysis we believe that ODRPACK is compatible with the ANSI X3.9-1978 full language standard. *** INSTALLING ODRPACK Step 1. Select Single or Double Precision Version ODRPACK software is available in both single and double precision versions. Both versions are complete as they stand, and except for precision are identical. They can be combined in a single library, if desired. (Subprogram JAC, which is included in both source files SODR.FOR and DODR.FOR, is a dummy routine that is provided to prevent the occurrence of an unsatisfied external when finite difference derivatives are used. Either version can be used in a combined library.) ODRPACK is sensitive to the machine precision, however, and requires approximately 14 decimal places. Somewhat fewer places should still work, but six or seven decimal places are definitely too few for general use, since only the simplest problems could be solved correctly at such reduced precisions. The installer must therefore choose which version of ODRPACK to use based upon which version supplies adequate precision on the target machine. To our knowledge, at present only Cray and CDC machines offer sufficient precision to permit general use of the single precision version of ODRPACK. For other machines, we recommend the double precision version. If both versions of ODRPACK have sufficient precision on the installer's machine, then both may be used. When both the single and double precision versions are available, however, there are trade offs between them. The double precision version will offer greater accuracy in results, while the single precision will require less storage and possibly less machine time. Step 2: Select ODRPACK Code Necessary for Installation on the Target System The code for each version of ODRPACK is separated into three sections to facilitate installation. These three sections are in files SODR.FOR, SODRLPK.FOR and SMPREC.FOR for the single precision version, and in files DODR.FOR, DODRLPK.FOR and DMPREC.FOR for the double precision version. Files SODR.FOR and DODR.FOR include all subprograms written especially for ODRPACK. The two user callable ODRPACK subprograms of each version are listed first, followed by the remaining subprograms listed in alphabetical order. The code in these files should not require any modification unless the installer wishes to customize the user callable subprograms. Files SODRLPK.FOR and DODRLPK.FOR include the subprograms used by ODRPACK from the public domain packages LINPACK and BLAS, also listed in alphabetical order. The installer can use local versions of these packages if available. This would be particularly beneficial if the installer's machine has specially optimized versions of LINPACK or BLAS. Files SMPREC.FOR and DMPREC.FOR include the only machine dependent subprograms in ODRPACK. Changes required to these files are described in Step 3, below. Each ODRPACK subprogram follows the SLATEC Source File Format and provides a standardized prologue describing the purpose of the subprogram and what other subprograms are called, an alphabetical list of all variables referenced by the subprogram and how they are used, as well as comments explaining the major sections of the code. Furthermore, each ODRPACK subprogram begins with a comment line consisting of an asterisk followed immediately by the subprogram name, i.e., *name. This is the only use of an asterisk in column 1 of the ODRPACK source code, and is done to aid the installer in separating the subprograms into individual files. Step 3. Set Necessary Machine Dependent Values Files SMPREC.FOR and DMPREC.FOR supply the machine dependent constants used by ODRPACK. Comment statements within these files document the modifications required. They also list the necessary constants for a number of common machines. If the constants for the target machine are included, then the installer need only "uncomment" the appropriate DATA statements. These subprograms will return an undefined value until they are updated; the installer must update them before compiling and running ODRPACK. Step 4. Compile ODRPACK Code and Generate Object Code Library ODRPACK code conforms to the ANSI X3.9-1978 full Fortran standard and has been successfully installed on a CDC Cyber 855, CDC Cyber 205, Concurrent 3230, DEC VAX 11/780, IBM PC/AT, and a Sun 3 Workstation. We believe it is possible to install ODRPACK on any system with an ANSI Fortran 77 compiler and adequate memory. The authors have detected compiler bugs, however, that affect ODRPACK when using FTN200 Cycle 661B on the Cyber 205 and when using Profort 1.0 and 1.19 on the IBM PC/AT. In compiling ODRPACK, we recommend that the following compiler options be used if available. 1. Rounded arithmetic. 2. The most extensive set of error messages possible. (In our experience it is well worth hearing everything that a compiler has to say about imported code.) Let us emphasize that we do not expect any problems with compilation. After the ODRPACK code has been successfully compiled, a Fortran object code library must be created. The term object code library here refers to whatever facility the target system has for satisfying external references automatically at load time, using a collection of previously compiled subprograms. Step 5. Test ODRPACK The ODRPACK supplied software includes drivers and data sets for running ODRPACK in both single and double precision. There are three drivers for each version of the code. Files SDRIVE1.FOR, SDRIVE2.FOR, DDRIVE1.FOR and DDRIVE2.FOR contain simple programs that users can modify to form their own ODRPACK drivers. The data necessary to run these drivers are in file DATA1.DAT; the reports generated by these drivers are shown in the Reference Guide (file GUIDE.DOC), Section VII. (The name of the data file specified in the 'OPEN' statement in these two drivers is 'DATA1'. The data file name and/or the file name specified in the 'OPEN' statement might have to be changed in order for the drivers to run properly on the target machine.) Files STEST.FOR and DTEST.FOR contain drivers that exercise ODRPACK's main features and can be used to verify that the installation was completed successfully. The ODRPACK output generated by DTEST.FOR when run on a Sun 3 Workstation using the double precision version of ODRPACK is listed in file TEST.TXT. No data files are required for these two drivers. The drivers within files STEST.FOR and DTEST.FOR call subprograms SODRX and DODRX, respectively, as documented by the comment statements within each of the drivers. These two subprograms each call the ODRPACK user callable subprograms several times, with each call testing one or more features of the package. The results of each call are automatically compared to the results obtained by the authors using the double precision version of ODRPACK run on a CDC Cyber 205 under VSOS 2.3.7 PSR level 712 (124 bits per double precision value). The success or failure of each test is noted individually in the output and is summarized for all of the data sets. The ODRPACK reports generated by these two drivers and a summary of the comparisons are written to files REPORT and SUMMARY, respectively. By running these demonstration programs and then comparing file REPORT with TEST.TXT, the installer can easily ascertain whether the package is performing as it should. If the REPORT and SUMMARY files indicate that the results generated by the target machine disagree with the expected results, the installer should attempt to determine why. The 3 most common causes of disagreement between the computed results and the expected results are: 1. incorrectly specified machine dependent constants (see Step 3 above); 2. use of the single precision version of ODRPACK on a target machine that requires double precision accuracy (see Step 1 above); and 3. compiler 'bugs'. We suggest that these potential problem areas be investigated before accepting a questionable installation as adequate. If you are unable to find the cause of the reported disagreement, please feel free to contact the developers at the address given above. Step 6. Distribute ODRPACK documentation The ODRPACK Reference Guide is supplied in line printer format in file GUIDE.DOC. It is the installer's responsibility to make this documentation and future modifications to it available to local users. The on line documentation uses the standard Fortran conventions for printing formatted records. In particular, the first character of each line is used to determine vertical spacing. For correct printing, if the first character of a line is a blank then the printer should vertical space one line, and if the first character is a 1 then the printer should advance to the beginning of a new page. The maximum page width is 80 columns (printer control included). The installer may modify the on line documentation as necessary if its format is not convenient. 1 User's Reference Guide for ODRPACK Software for Weighted Orthogonal Distance Regression Version 1.71 07-27-89 National Institute of Standards and Technology (formerly National Bureau of Standards) Internal Report 89-4103 Paul T. Boggs Applied and Computational Mathematics Division National Institute of Standards and Technology Gaithersburg, MD 20899 Richard H. Byrd Department of Computer Science University of Colorado Boulder, CO 80309 Janet R. Donaldson Applied and Computational Mathematics Division National Institute of Standards and Technology Boulder, CO 80303-3328 Robert B. Schnabel Department of Computer Science University of Colorado Boulder, CO 80309 and Applied and Computational Mathematics Division National Institute of Standards and Technology Boulder, CO 80303-3328 ***keywords*** orthogonal distance regression measurement error models nonlinear least squares errors in variables ***categories*** G2E,I1B1 1 *** REVISION HISTORY *** Revision Description -------- ----------- 1.71 (07-27-89) ODRPACK 1.71 corrects an error in the code that performs the computation of finite difference derivatives when M>=2 and the default value of IFIXX is invoked. (The default value of IFIXX is invoked when IFIXX(1,1) is set to a negative value or when ODRPACK routines DODR or SODR are called.) This error could result in incorrect ``fixing'' of the independent variables, which would affect the final solution. Such ``fixing'' could be detected by observing the presence of values of DELTA that were identically zero. The error could go undetected by the user, however, if the values of DELTA were not examined after the fit. 1 TABLE OF CONTENTS I. Introduction II. Background III. Multiple Response Data IV. Starting Values for BETA and DELTA V. Default Values and Structured Arguments VI. Subroutine Declaration and Call Statements VII. Subroutine Argument Descriptions A. Synopsis B. Detailed Descriptions of ODRPACK User Callable Subroutine Arguments VIII. Examples A. DODR Example Program, Data and ODRPACK Generated Report B. DODRC Example Program, Data and ODRPACK Generated Report IX. Scaling Algorithms A. Beta Scaling B. Delta Scaling X. Extracting Information from the Work Vectors A. Extracting Information from Vector WORK B. Extracting Information from Vector IWORK XI. Acknowledgments XII. References 1 I. INTRODUCTION ------------- ODRPACK is a portable collection of ANSI 77 Fortran subroutines for fitting a model to data. It is designed primarily for instances when the independent as well as the dependent variables have significant errors, implementing a highly efficient algorithm for solving the weighted orthogonal distance regression problem, i.e., for minimizing the sum of the squares of the weighted orthogonal distances between each data point and the curve described by the model equation. It can also be used to solve the ordinary least squares problem where all of the errors are attributed to the observations of the dependent variable. A complete description of the orthogonal distance regression problem and the algorithm implemented in ODRPACK is given by Boggs et al. [1987a and 1987b]. ODRPACK is designed to handle many levels of user sophistication and problem difficulty. * It is easy to use, providing two levels of user control of the computations, extensive error handling facilities, optional printed reports and no size restrictions other than effective machine size. * The necessary derivatives (Jacobian matrices) are approximated numerically if they are not supplied by the user. * The correctness of user supplied derivatives can be verified by the derivative checking procedure provided. * Both weighted and unweighted analysis can be performed. * Subsets of the unknowns can be treated as constants with their values held fixed at their input values, allowing the user to examine the results obtained by estimating subsets of the unknowns of a general model without rewriting the model subroutine. * The covariance matrix and the standard errors of the model parameter estimators are optionally provided. * The ODRPACK scaling algorithm automatically compensates for poorly scaled problems, in which the model parameters and/or unknown errors in the independent variables vary widely in magnitude. * It can accommodate complex data and multiple response data, i.e., data where the dependent variable is multi-dimensional. (See section III.) * The trust region Levenberg-Marquardt algorithm implemented by ODRPACK has a computational effort per step that is of the same order as that required for ordinary least squares, even though the number of unknowns estimated in the orthogonal distance regression problem is the number of unknown model parameters plus the number of independent variables, while the number of unknowns estimated in the ordinary least squares problem is simply the number of unknown model parameters. * The code is portable and is easily used with other Fortran subroutine libraries. The following sections describe ODRPACK in greater detail. Users are directed to section II for a brief description of the orthogonal distance regression algorithm. This section introduces notation and provides background material for understanding the remainder of the documentation. Section III describes how ODRPACK can be used for complex and multiple response data, and is only required for users with these data types. Section IV describes the need for starting values for BETA and DELTA, and section V describes two features of ODRPACK that simplify the user interface with the package. The information in these two sections will be especially important to first time users of ODRPACK. The subroutine declaration and call statements are given in section VI and the subroutine arguments are defined in section VII. The sample programs shown in section VIII can be used as templates for creating the user's own program. The information provided in section IX describes the scaling algorithm and section X describes how the user can extract computed results from the work vectors. The information in these two sections is generally not needed by first time users of ODRPACK. 1 II. BACKGROUND ---------- Let Y(I) = FN(X(I,*)+DELTA(I,*);BETA) - EPSILON(I) (eq.1) for I=1,...,N, where N is the number of observations (see subroutine argument N); Y(I), I=1,...,N are the observed values of the dependent variable, where Y(I) depends on X(I,J), J=1,...,M (see subroutine argument Y); FN is the function used to predict values of the dependent variable (see subroutine argument FUN); X(I,J), I=1,...,N & J=1,...,M are the observed values of the independent variable (see subroutine argument X); DELTA(I,J), I=1,...,N & J=1,...,M are the unknown errors in X(I,J) that are to be estimated (see subroutine arguments JOB and WORK); BETA(K), K=1,...,NP are the function parameters that are to be estimated (see subroutine argument BETA); EPSILON(I), I=1,...,N are the unknown errors in Y(I) that are to be estimated (see subroutine argument WORK). We are assuming that observed< Y(I) > = true< Y(I) > - true< EPSILON(I) > observed< X(I,J) > = true< X(I,J) > - true< DELTA(I,J) > and thus that estimated< Y(I) > = observed< Y(I) > + estimated< EPSILON(I) > estimated< X(I,J) > = observed< X(I,J) > + estimated< DELTA(I,J) >. 1 The square of the weighted orthogonal distance from the point (X(I,*),Y(I)) to the point FN(X(I,*)+DELTA(I,*);BETA) on the curve described by the model equation, i.e., the square of the observation errors, is given by R(I)**2 = [FN(X(I,*)+DELTA(I,*);BETA) - Y(I)]**2 (eq.2) M + SUM [D(I,J)*DELTA(I,J)]**2 J=1 for I = 1,...,N, where D(I,J), I=1,...,N & J=1,...,M are the DELTA weights, which can be used to compensate for instances when the precision of the X observations is different from that of the Y observations (see subroutine argument WD). The least squares orthogonal distance solution is then that which minimizes with respect to BETA and DELTA the weighted sum of the squared observation errors, N SUM [ ( W(I) * R(I) )**2 ] (eq.3) I=1 where W(I), I=1,...,N are the observation error weights, which can be used to compensate for unequal precision in the observation errors, R(I) (see subroutine argument W). The solution is found using a trust region Levenberg-Marquardt method [Boggs et al., 1987b], with scaling used to accommodate problems in which estimated values have widely varying magnitudes. The Jacobian matrices, i.e., the matrices of first partial derivatives of FN with respect to each BETA and each X, are computed at every iteration either by finite differences or by a user supplied subroutine, as specified by subroutine argument JOB (see section VII.B). The iterations are stopped when any one of three stopping criteria are met. Two of these indicate the iterations have converged to a solution. These are "sum of squares convergence", which indicates that the change in the weighted sum of the squared observation errors is sufficiently small, and "parameter convergence", which indicates the change in the values of BETA and DELTA is sufficiently small. The third stopping criteria is a limit on the number of iterations. 1 III. MULTIPLE RESPONSE DATA ---------------------- Since its initial release, users have been interested in applying ODRPACK to complex data and to multiple response data in general. Although ODRPACK was written for single response data, where only one dependent variable is observed for each independent variable, it is possible to use it to handle multiple response data, where the dependent variable is multi-dimensional. Complex dependent data falls under the category of multiple response data since the real and imaginary parts of the dependent variable must be treated as separate observations. Let Y(I,L), L=1,...,Q be the Q responses for the Ith observation of the independent variable, X(I,*). These Q multiple responses of the dependent variable cannot simply be treated as Q separate observations as can be done for ordinary least squares because ODRPACK would then treat the independent variables associated with these Q observations as unrelated and thus not constrain the errors DELTA(I,*) to be the same for each of the Q occurrences of X(I,*). In the multiple response case, therefore, the square of the observation errors (eq.2) must be defined as Q R(I)**2 = SUM (C(I,L)*[FN(X(I,*)+DELTA(I,*);BETA) - Y(I,L)])**2 L=1 (eq.4) M + SUM [D(I,J)*DELTA(I,J)]**2 J=1 for I = 1,...,N, where FN(X(I,*)+DELTA(I,*);BETA)-Y(I,L) is the estimated error in the Lth response of the Ith observation of the dependent variable, and C(I,L), I=1,...,N & L=1,...,Q must be appropriately chosen based on the desired weights for the individual response functions. Equation (eq.4) has the effect of collapsing the Q errors associated with Y(I,L),L=1,...,Q, into a single value. This implies that NP must be less than or equal to N, rather than less than or equal to N*Q as would be the case if the multiple response problem were handled directly by ODRPACK or the problem were solved using ordinary least squares. Future plans for ODRPACK include modifications that will allow multiple response data to be handled directly, thus eliminating this restriction. 1 ODRPACK actually computes the results specified by (eq.2) using M R(I)**2 = [-]**2 + SUM [D(I,J)*DELTA(I,J)]**2 (eq.5) J=1 for I = 1,...,N, where is the value in the Ith location of vector F returned from the user supplied subroutine FUN, which in the single response case contains FN(X(I,*)+DELTA(I,*);BETA); and is the value supplied in the Ith location of vector Y of the ODRPACK subroutine argument list, which in the single response case contains the Ith observation of the dependent variable. ODRPACK can thus be "tricked" into solving multiple response orthogonal distance regression problems by setting Q = sqrt(SUM (C(I,L)*[FN(X(I,*)+DELTA(I,*);BETA) - Y(I,L)])**2) (eq.6) L=1 for I = 1,...,N, within user supplied subroutine FUN, and setting = 0.0 for I = 1,...,N. The computations specified by (eq.5) will then yield the value specified by (eq.4) and the multiple response ODR problem will be solved correctly. Note that this technique for solving multi-response orthogonal distance regression problems has the advantage of retaining the original size of the problem, i.e., NP parameters and N observations. It has the disadvantage, however, of making the function F a more complicated function of BETA and DELTA than the original function FN. For small data sets, therefore, users may want to consider explicitly including each DELTA(I,J) as part of an expanded vector BETA and solving the resulting (NP+N*M) parameter problem using ordinary least squares as described in Boggs and Donaldson [1989] or Fuller [1987]. Note also that the standard errors of a multi-response orthogonal distance regression problem encoded as shown in (eq.6) will not be the same as those obtained by solving the problem as an ordinary least squares problem with (NP+N*M) parameters because the two functions being minimized have different Jacobian matrices at the solution. (See Section VII.B, subroutine argument JOB and IPRINT.) 1 IV. STARTING VALUES FOR BETA AND DELTA ---------------------------------- Starting values for BETA must be provided by the user. Users familiar with the ordinary nonlinear least squares problem are generally aware of the importance of obtaining good starting values for the estimated function parameters. It is equally important to obtain good starting values for the parameters when using the orthogonal distance regression technique. Good starting values can significantly decrease the number of iterations required to find a solution; a poor starting value may even prevent the solution from being found at all. Reasonable starting values are often available from previous analysis or experiments. When good starting values are not readily available, the user may have to do some preliminary analysis to obtain them. Himmelblau [1970] offers several suggestions for obtaining starting values when they are not available from other sources. When using the technique of orthogonal distance regression it is also important to have good starting values for the estimated errors, DELTA, in the independent variables. The ODRPACK default is to initialize DELTA to zero, which is the most obvious initial value for the DELTAs. (Note that zero starting values for DELTA do not cause the scaling problems discussed in section VII.B that zero starting values for BETA cause.) Initializing the DELTAs to zero, however, is equivalent to initially assigning all of the errors to the dependent variable as is done for ordinary least squares. While initializing the DELTAs to zero is quite adequate in many cases, in others it is not. A plot of the curve described by the model function and observed data for the initial parameters may indicate whether or not zero starting values for DELTA are reasonable. Often it is visually possible to determine better starting values for the DELTAs, especially when an asymptote is involved. For example, in the case of an asymptote, the user may need to initialize some of the DELTAs to the horizontal distance to the curve, while leaving the other DELTAs initialized to zero in order to obtain a reasonable solution. This problem is discussed further in [Boggs et al., 1987b]. As noted there, proper initialization of DELTA can mean the difference between solving a difficult problem and not solving it. 1 V. DEFAULT VALUES AND STRUCTURED ARGUMENTS --------------------------------------- ODRPACK uses default values and structured arguments to simplify the user interface. The availability of default values in ODRPACK means that the user does not have to be concerned with determining values for many of the ODRPACK arguments unless the problem being solved requires the use of nondefault values. Structured arguments, which exploit the possibly symmetric structure of the independent variable data, reduce the amount of storage space required for arguments and reduce the work required by the user to initialize those arguments. DEFAULT VALUES. Default values have been specified for ODRPACK subroutine arguments wherever feasible. These default values are invoked by setting the argument to any negative value. Arrays with default values are invoked by setting the first element of the array to a negative value, in which case only the first value of the array will ever be used. This allows a scalar to be used to invoke the default values of arrays, thus saving space and the need to declare such arrays. Users are encouraged to invoke the default values of arguments wherever possible. The default values have been found to be reasonable for a wide class of problems. Their use will greatly simplify the initial use of ODRPACK for a given problem. Fine tuning of these arguments can then be done later if it is found necessary. STRUCTURED ARGUMENTS. Structured arguments are included in ODRPACK because the properties of the individual elements of the possibly multiple column independent variable data are often constant throughout a given column of the independent variable or even throughout the whole independent variable matrix. For example, section II introduces the DELTA weights, specified by subroutine argument WD, that indicate how the DELTA and EPSILON for each observation (X,Y) are to be weighted in the weighted orthogonal distance. If each row of the independent variable indicates an hourly temperature reading and each column a different day on which the temperature readings were taken, then the user would probably want to weight each of the DELTAs equally. If one column of the independent variable contained hourly temperature readings and the other hourly humidity readings, then the user might want to weight each of the DELTAs in the first column the same, and to weight each of the DELTAs in the second column the same, but not necessarily want to weight the two columns equally. Of course, in other cases, the user might want to weight each of the DELTAs differently. ODRPACK structured arguments exploit this possible symmetry as follows. If each of the N by M elements of an array describing some property of the independent variable are identically equal, then a single value can be used to specify all N by M elements. If the values of such an array only vary between columns, then each column of the array can be specified by a single value. Thus, it is only necessary to supply all N by M elements of the structured argument array when the elements of one or more of the columns must be individually specified. 1 The use of ODRPACK structured arguments is summarized as follows. Structure of Encoding of Accessed Resulting property P to structured elements of assignment of be specified argument A and structured property P by structured its leading argument A argument A dimension LDA --------------- -------------- ----------- ----------------- Property P A(1,1) < zero A(1,1) P(I,J) = -A(1,1), constant with I=1,...,N & throughout LDA = 1 or J=1,...,M independent LDA >= N variable matrix Property P A(1,1) >= zero A(1,J), P(I,J) = A(1,J), varies only with J=1,...,M I=1,...,N & between columns LDA = 1 J=1,...,M of independent variable matrix Property P A(1,1) >= zero A(I,J), P(I,J) = A(I,J), varies between with I=1,...,N & I=1,...,N & and within LDA >= N J=1,...,M J=1,...,M columns of independent variable matrix If the first element of the structured argument is negative, then each of the N by M elements described by the argument is set to the absolute value of the first element. In this case, only the first element of the structured argument is ever referenced, allowing the user to set the N by M elements using only a scalar. (Note that in this case, setting the first element to a negative value does not necessarily invoke a default value.) This feature thus saves space and the need to declare the structured argument as an array. If the first element of the structured argument is positive, then the way the structured argument will be used to designate the N by M values specified by it will depend its leading dimension. The leading dimension of the structured argument can be either exactly equal to one, or greater than or equal to N. When the leading dimension is exactly equal to one, the structured argument must be passed to ODRPACK as a one by M row vector containing the M values used to set each of the M columns. When the leading dimension is greater than or equal to N, the structured argument passed to ODRPACK must contain an N by M array of values. 1 VI. SUBROUTINE DECLARATION AND CALL STATEMENTS ------------------------------------------ The declaration and call statements for ODRPACK's user callable routines, SODR, SODRC, DODR and DODRC, are given below. SODR and SODRC invoke the single precision version of the code and DODR and DODRC invoke the double precision version. SODR and DODR preset many arguments to their default values and therefore have shorter call statements than SODRC and DODRC. SODRC and DODRC have expanded call statements that give the user greater control in solving the orthogonal distance regression problem. The information in this section is provided primarily for reference. Users are directed to section VII for example programs. These examples, which use Fortran PARAMETER statements to dimension ODRPACK arrays, provide a recommended format for creating an ODRPACK driver that will allow future changes to be made easily. Note that although ODRPACK is distributed in both single precision and double precision versions, both versions may not be available to the user. In addition, even when both versions are available, the single precision version may not be appropriate to use. This is because ODRPACK is sensitive to the machine's precision, and requires approximately 14 decimal places. Somewhat fewer places should still work, but six or seven decimal places are definitely too few for general use, since only the simplest problems could be solved correctly at such reduced precisions. When both versions are available, the user must choose which version of ODRPACK to use based upon which version supplies adequate precision on the target machine. To our knowledge, at present only Cray and CDC machines offer sufficient precision to permit general use of the single precision version of ODRPACK. For other machines, we recommend the double precision version. If both versions of ODRPACK have sufficient precision on the user's machine, then either may be used. When both the single and double precision versions are available, however, there are trade offs between them. The double precision version will offer greater accuracy in results, while the single precision version will require less storage and possibly less machine time. 1 SODR: Compute the weighted orthogonal distance regression or ordinary linear or nonlinear least squares solution in single precision. (SODR is appropriate for general use only on machines with approximately 14 decimal places of precision for single precision.) Derivatives are either supplied by the user or numerically approximated by ODRPACK. Control values are preset, and a three part report of the results can be optionally generated. PROGRAM MAIN . . . EXTERNAL + FUN,JAC INTEGER + N,M,NP, + LDX, + LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + LWORK,IWORK(LIWORK),LIWORK, + INFO REAL + X(LDX,M), + Y(N), + BETA(NP), + WD(LDWD,M), + WORK(LWORK) . . . CALL SODR + (FUN,JAC, + N,M,NP, + X,LDX, + Y, + BETA, + WD,LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) . . . END 1 SODRC: Compute the weighted orthogonal distance regression or ordinary linear or nonlinear least squares solution in single precision. (SODRC is appropriate for general use only on machines with approximately 14 decimal places of precision for single precision.) Derivatives are either supplied by the user or numerically approximated by ODRPACK. Control values are supplied by the user, and a three part report of the results can be optionally generated. PROGRAM MAIN . . . EXTERNAL + FUN,JAC INTEGER + N,M,NP, + LDX,IFIXX(LDIFX,M),LDIFX,LDSCLD, + IFIXB(NP), + LDWD, + JOB,NDIGIT, + MAXIT, + IPRINT,LUNRPT,LUNERR, + LWORK,IWORK(LIWORK),LIWORK, + INFO REAL + X(LDX,M),SCLD(LDSCLD,M), + Y(N), + BETA(NP),SCLB(NP), + WD(LDWD,M),W(N), + TAUFAC, + SSTOL,PARTOL, + WORK(LWORK) . . . CALL SODRC + (FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) . . . END 1 DODR: Compute the weighted orthogonal distance regression or ordinary linear or nonlinear least squares solution in double precision. Derivatives are either supplied by the user or numerically approximated by ODRPACK. Control values are preset, and a three part report of the results can be optionally generated. PROGRAM MAIN . . . EXTERNAL + FUN,JAC INTEGER + N,M,NP, + LDX, + LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + LWORK,IWORK(LIWORK),LIWORK, + INFO DOUBLE PRECISION + X(LDX,M), + Y(N), + BETA(NP), + WD(LDWD,M), + WORK(LWORK) . . . CALL DODR + (FUN,JAC, + N,M,NP, + X,LDX, + Y, + BETA, + WD,LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) . . . END 1 DODRC: Compute the weighted orthogonal distance regression or ordinary linear or nonlinear least squares solution in double precision. Derivatives are either supplied by the user or numerically approximated by ODRPACK. Control values are supplied by the user, and a three part report of the results can be optionally generated. PROGRAM MAIN . . . EXTERNAL + FUN,JAC INTEGER + N,M,NP, + LDX,IFIXX(LDIFX,M),LDIFX,LDSCLD, + IFIXB(NP), + LDWD, + JOB,NDIGIT, + MAXIT, + IPRINT,LUNRPT,LUNERR, + LWORK,IWORK(LIWORK),LIWORK, + INFO DOUBLE PRECISION + X(LDX,M),SCLD(LDSCLD,M), + Y(N), + BETA(NP),SCLB(NP), + WD(LDWD,M),W(N), + TAUFAC, + SSTOL,PARTOL, + WORK(LWORK) . . . CALL DODRC + (FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) . . . END 1 VII. SUBROUTINE ARGUMENT DESCRIPTIONS -------------------------------- VII.A Synopsis The arguments of the ODRPACK user callable subroutines are logically grouped as shown below. Arguments shown in parenthesis (...) are not included in the SODR and DODR call statements; SODR and DODR automatically preset these variables to the default values given in section VII.B. All other arguments are common to all ODRPACK user callable subroutines. Argument Number Arguments Group Description -------- --------- ----------------- 1 to 2 FUN,JAC, Names of user supplied subroutines for function and Jacobian matrix computation 3 to 5 N,M,NP, Problem size specification 6 to 11 X,LDX,(IFIXX,LDIFX,SCLD,LDSCLD,) Independent variable information 12 Y, Dependent variable 13 to 15 BETA,(IFIXB,SCLB,) Function parameter information 16 to 18 WD,LDWD,(W,) Weights 19 to 21 JOB,(NDIGIT,TAUFAC,) Computation and initialization control 22 to 24 (SSTOL,PARTOL,MAXIT,) Stopping criteria 25 to 27 IPRINT,LUNERR,LUNRPT, Print control 28 to 31 WORK,LWORK,IWORK,LIWORK, Work vectors and returned results 32 INFO Stopping condition 1 VII.B Detailed Descriptions of ODRPACK User Callable Subroutine Arguments The arguments of ODRPACK's user callable subroutines are described below in order of their occurrence in the call statements. Appropriate declaration statements for each argument are shown in brackets [...] following the argument name; the character string denotes REAL when using single precision subroutines SODR and SODRC, which should be used only on machines with approximately 14 decimal digits of precision in single precision, and denotes DOUBLE PRECISION when using double precision subroutines DODR and DODRC. Each argument is numbered as shown in section VII.A, allowing the user to easily find the definition of a specific argument. In addition, three common characteristics of ODRPACK subroutine arguments are flagged in the left margin by the argument number. The flags are: C which indicates the argument is only included in the call statements for SODRC and DODRC (SODR and DODR will preset these variables to their default values); D which indicates the argument has a default value that can be invoked by setting the argument to any negative value; and S which indicates the argument exploits possible symmetry in the properties of the independent variables as described in section IV. NOTE Substitute REAL for when using SODR and SODRC. Substitute DOUBLE PRECISION for when using DODR and DODRC. **** 1 1. FUN [EXTERNAL FUN] The name of the user supplied subroutine that computes the predicted values, F, of the dependent variable given the current values of the independent variable, XPLUSD=X+DELTA, and the function parameters, BETA. The subroutine argument list and declaration statements must be exactly as shown below. SUBROUTINE FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOPF) C C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) C INTEGER N,NP,M,LDXPD BETA(NP),XPLUSD(LDXPD,M) C C OUTPUT ARGUMENTS C INTEGER ISTOPF F(N) < computations for F(I)=FN(XPLUSD;BETA), I=1,...,N > < set ISTOPF = 0 if the current estimates of BETA and XPLUSD > < were acceptable for use in subroutine FUN> < and the regression procedure should > < continue > < > 0 if the current estimates of BETA and XPLUSD > < were not acceptable for use in subroutine> < FUN, and values closer to the most > < recently tried acceptable values of BETA > < and XPLUSD should be used > < < 0 if the regression procedure should be > < stopped immediately > RETURN END where INTEGER N is the number of observations, i.e., the number of points (X,Y). INTEGER NP is the number of function parameters, i.e., the number of values in vector BETA. INTEGER M is the number of columns of data in the independent variable matrix XPLUSD. BETA(NP) is the singly subscripted array that contains the current values of the NP function parameters. XPLUSD(LDXPD,M) is the doubly subscripted array that contains the current value of the N by M matrix of the independent variables, i.e., XPLUSD = X + DELTA. INTEGER LDXPD is the leading dimension of array XPLUSD. F(N) is the singly subscripted array that contains the N predicted values of the function given the current values of the function parameters and the independent variables, i.e., F = FN(XPLUSD;BETA). INTEGER ISTOPF is an indicator value that can be used to reject the current estimates of BETA and XPLUSD as unacceptable. Upon return from subroutine FUN: If ISTOPF = 0 then the current estimates of BETA and XPLUSD were acceptable for use in subroutine FUN, and the values of the predicted values F were properly computed. The regression procedure will continue. If ISTOPF > 0 then the values of the predicted values F could not be properly computed because the current estimates of BETA and XPLUSD were not acceptable. The regression procedure will select values closer to the most recently tried acceptable values of BETA and XPLUSD. If ISTOPF < 0 then the regression procedure should be stopped immediately. The final summary of the computation report will be printed, however, if it has been requested (see argument IPRINT). 2. JAC [EXTERNAL JAC] The name of the user supplied subroutine that computes the Jacobian matrices, i.e., the matrices of first partial derivatives of FN with respect to each BETA and each X. This subroutine must be supplied only when digit C of JOB is nonzero (see subroutine argument JOB) although the external statement must always be provided in the user's main program; when digit C of JOB is zero the necessary Jacobian matrices will be computed by ODRPACK using finite differences. Note that the logical argument ISODR, which is passed to subroutine JAC by ODRPACK, can be used to avoid computing the Jacobian matrix with respect to X when the fit is by the method of ordinary least squares and these derivatives are not needed. ISODR will be "false" in this case. It is not an error to compute the Jacobian with respect to X when the fit is by the method of ordinary least squares; it is an error if the Jacobian with respect to X is not computed when the fit is by the method of orthogonal distance regression. The subroutine argument list and dimension statements must be exactly as shown below. 1 SUBROUTINE JAC(N,NP,M,BETA,XPLUSD,LDXPD, + FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOPJ) C C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) C INTEGER N,NP,M,LDXPD LOGICAL ISODR BETA(NP),XPLUSD(LDXPD,M) C C OUTPUT ARGUMENTS C INTEGER ISTOPJ FJACB(LDFJB,NP),FJACX(LDFJX,M) < computations for FJACB(I,K)=first partial derivative of FN with respect to BETA(K), K=1,...,NP, at each observation I=1,...,N > IF (ISODR) THEN < computations for FJACX(I,J)=first partial derivative of FN with respect to X(I,J), J=1,...,M at each observation I=1,...,N > END IF < set ISTOPJ = 0 if the current estimates of BETA and XPLUSD> < were acceptable for use in subroutine > < JAC and the regression procedure should > < continue > < set ISTOPJ <> 0 if the regression procedure should be > < stopped immediately > RETURN END where INTEGER N is the number of observations, i.e., the number of points (X,Y). INTEGER NP is the number of function parameters, i.e., the number of values in vector BETA. INTEGER M is the number of columns of data in the independent variable matrix XPLUSD. BETA(NP) is the singly subscripted array that contains the current values of the NP function parameters. XPLUSD(LDXPD,M) is the doubly subscripted array that contains the current value of the N by M matrix of the independent variables, i.e., XPLUSD = X + DELTA. INTEGER LDXPD is the leading dimension of array XPLUSD. FJACB(LDFJB,NP) is the doubly subscripted array that contains the N by NP matrix of derivatives with respect to BETA at the current values of the function parameters and the independent variables. INTEGER LDFJB is the leading dimension of array FJACB. LOGICAL ISODR is a control value that can be used to inhibit the computation of the derivatives with respect to X when the solution is being computed by ordinary least squares and the derivatives with respect to X are not needed. If ISODR is true then the solution is being computed by ODR and the derivatives with respect to X must be computed else the solution is being computed by OLS and the derivatives with respect to X are not needed. FJACX(LDFJX,M) is the doubly subscripted array that contains the N by M matrix of derivatives with respect to X at the current values of the function parameters and the independent variables, needed only when ISODR = true. INTEGER LDFJX is the leading dimension of array FJACX. INTEGER ISTOPJ is an indicator value that can be used to reject the current estimates of BETA and XPLUSD as unacceptable. Upon return from subroutine JAC: If ISTOPJ = 0 then the current estimates of BETA and XPLUSD were acceptable for use in subroutine JAC, and the Jacobians were properly computed. The regression procedure will continue. Else the regression procedure should be stopped immediately. The final summary of the computation report will be printed, however, if it has been requested (see argument IPRINT). 3. N [INTEGER N] The number of observations, i.e., the number of points (X,Y). (See subroutine arguments X and Y.) 4. M [INTEGER M] The number of columns of data in the independent variable matrix X. (See subroutine argument X.) 5. NP [INTEGER NP] The number of function parameters, i.e., the number of values in vector BETA. (See subroutine argument BETA). 6. X [ X(LDX,M)] The doubly subscripted array that contains the observed values of the N by M matrix of independent variables. 7. LDX [INTEGER LDX] The leading dimension of array X. LDX must equal or exceed N; values of LDX less than N will be treated as an input error. CDS 8. IFIXX [INTEGER IFIXX(LDIFX,M)] The doubly subscripted array that contains the indicator values used to designate whether element X(I,J), I=1,...,N & J=1,...,M, of the independent variable matrix is to treated as without error, i.e., DELTA(I,J) is to be fixed at zero, or whether the error DELTA(I,J) in that observation of the independent variable is to be estimated. By default, all of the independent variables are treated as "unfixed", i.e. the errors DELTA(I,J) are estimated for all I=1,...,N & J=1,...,M. The default value is invoked when IFIXX(1,1) is set to any negative value. Other options for specifying IFIXX are described below. If IFIXX(1,1) >= 0 then the way IFIXX is used depends on the value of the leading dimension of IFIXX, i.e., on LDIFX. If LDIFX = 1 then IFIXX must contain a 1 by M matrix of values, where for J=1,...,M if IFIXX(1,J) = 0 then X(I,J), I=1,...,N, is treated as exact and DELTA(I,J), I=1,...,N, is fixed at zero else X(I,J), I=1,...,N, is treated as approximate and DELTA(I,J), I=1,...,N, is estimated. If LDIFX >= N then IFIXX must contain an N by M matrix of values, where for I=1,...,N & J=1,...,M if IFIXX(I,J) = 0 then X(I,J) is treated as exact and DELTA(I,J) is fixed at zero else X(I,J) is treated as approximate and DELTA(I,J) is estimated. If IFIXX(1,1) < 0 then the default option is invoked, i.e., each observation of the independent variable, X(I,J), is treated as being measured with error an DELTA(I,J) that is estimated as described above in section II. In this case, only the first element of IFIXX is ever referenced and IFIXX can be a scalar. C 9. LDIFX [INTEGER LDIFX] The leading dimension of array IFIXX. LDIFX must exactly equal one or must equal or exceed N; values of LDIFX less than one or between two and N-1, inclusive, will be treated as an input error. See subroutine argument IFIXX for further details. CDS 10. SCLD [ SCLD(LDSCLD,M)] The doubly subscripted array that contains the scale values of the errors in the independent variable, i.e., the reciprocals of the expected magnitudes or typical sizes of DELTA(I,J), I=1,...,N & J=1,...,M. Scaling is used within the regression procedure in order that the units of the variable space will have approximately the same magnitude. In particular, the scale value times the corresponding value of DELTA should be approximately one. For example, if DELTA(1,1) is expected to lie between -10E10 and 10E10 then SCLD(1,1) should be set to 10E-10, while if DELTA(1,1) is expected to lie between -10E-2 and -10E-4 then SCLD(1,1) should be set to 10E3. (The reciprocal of the standard errors of the observation X(I,J) can be used as SCLD(I,J) if the standard errors are known.) Except as noted in the next paragraph, the scale values specified for each DELTA must be greater than zero; values less than or equal to zero will be treated as an input error. By default, the scale values will be set using the algorithm given in section IX.B. The default values are invoked when SCLD(1,1) is set to any negative value. Other options for specifying SCLD are described below. If SCLD(1,1) > 0 then each value of SCLD must be greater than zero and the way SCLD is used depends on the value of the leading dimension of SCLD, i.e., on LDSCLD. If LDSCLD = 1 then SCLD must contain a 1 by M matrix of values, and the scale of DELTA(I,J), I=1,...,N, is set to SCLD(1,J) for J=1,...,M. If LDSCLD >= N then SCLD must contain an N by M matrix of values, and the scale of DELTA(I,J) is set to SCLD(I,J) for I=1,...,N & J=1,...,M. If SCLD(1,1) <= 0 then the default option is invoked and each DELTA(I,J) is scaled as described in section IX.B. In this case, only the first element of SCLD is ever referenced and SCLD can be a scalar. C11. LDSCLD [INTEGER LDSCLD] The leading dimension of array SCLD. LDSCLD must exactly equal one or must equal or exceed N; values of LDSCLD less than one or between two and N-1, inclusive, will be treated as an input error. See subroutine argument SCLD for further details. 12. Y [ Y(N)] The singly subscripted array that contains the N observed values of the dependent variable. (See section III for a discussion of how to handle multiple response data.) 13. BETA [ BETA(NP)] The singly subscripted array that contains the (current) values of the NP function parameters. On input: BETA must contain initial approximations for the function parameters. Initial approximations should be chosen with care since poor initial approximations can significantly increase the number of iterations required to find a solution and possibly prevent the solution from being found at all. Users who do not provide scale information are strongly encouraged not to use zero as an initial approximation since a zero value can result in incorrect scale value selection by the scaling algorithm (see section IX). Setting the initial approximation to the largest magnitude that, for the user's problem, is effectively zero rather than the actual value zero will eliminate scaling problems, possibly producing faster convergence. For example, if BETA(1) represents change in cost in millions of dollars, then the value 10.0 might be considered "effectively zero", while if BETA(1) represents the change in cost in tens of dollars, then the value 0.01 might be considered "effectively zero." On return: BETA contains the "best" estimate of the solution at the time the computations stopped. CD 14. IFIXB [INTEGER IFIXB(NP)] The singly subscripted array that contains the indicator values used to designate whether the corresponding value in BETA is to be treated as a fixed constant or is to be estimated. By default, all of the function parameters, BETA, are treated as "unfixed", i.e. each of the BETA(K), K=1,...,NP, is estimated. The default value is invoked when IFIXB(1) is set to any negative value. Other options for specifying IFIXB are described below. If IFIXB(1) >= 0 then IFIXB must contain a vector of NP values, where for K=1,...,NP if IFIXB(K) = 0 then BETA(K) will be held fixed at its input value else BETA(K) will be estimated as described above. If IFIXB(1) < 0 then the default option is invoked, i.e., all BETA(K), K=1,...,NP, will be estimated as described above in section II. In this case, only the first element of IFIXB is ever referenced and IFIXB can be a scalar. CD 15. SCLB [ SCLB(NP)] The singly subscripted array that contains the scale values of the function parameters, i.e., the reciprocals of the expected magnitudes or typical sizes of BETA(K), K=1,...,NP. Scaling is used within the regression procedure in order that the units of the variable space will have approximately the same magnitude. In particular, the scale value times the corresponding value of BETA should be approximately one. For example, if BETA(1) is expected to lie between -10E10 and 10E10 then SCLB(1) should be set to 10E-10, while if BETA(1) is expected to lie between -10E-2 and -10E-4 then SCLB(1) should be set to 10E3. Except as noted in the next paragraph, the scale values specified for each BETA must be greater than zero; values less than or equal to zero will be treated as an input error. By default, the scale values will be set using the algorithm given in section IX.A. The default values are invoked when SCLB(1) is set to any nonpositive value. If SCLB(1) > 0 then SCLB must contain a vector of NP values each greater than zero and the scale of BETA(K) is set to SCLB(K) for K=1,...,NP. S 16. WD [ WD(LDWD,M)] The doubly subscripted array that contains the values that specify the DELTA weights, D, which indicate how the DELTAs and EPSILONs of the observation (X,Y) are to be weighted in the weighted orthogonal distance, R (see eq.2). For example, WD(I,J) might be the the ratio of the precision of the Y(I) observation to that of the X(I,J) observation. All elements of WD must be nonzero. If WD(1,1) < zero then only the first element of WD is ever referenced (in this case, WD can be a scalar) and D(I,J) = ABS(WD(1,1)) for I=1,...,N & J=1,...,M, i.e., D(I,J) is constant and every DELTA is weighted equally with respect to each of the EPSILONs. When ABS(WD(1,1)) = 1, the DELTAs and EPSILONs are both weighted equally, possibly indicating the X and Y observations are equally precise. If WD(1,1) > zero then then all elements of WD must be greater than zero and the way WD is used to specify D depends on the value of the leading dimension of WD, i.e., on LDWD. If LDWD = 1 then WD must contain a 1 by M matrix of values, where for J=1,...,M D(I,J) = WD(1,J), I=1,...,N, i.e., each column of D is constant. In this case, all elements of a given column of DELTA are weighted equally with respect to EPSILON, possibly reflecting that each observation within a given column of X is equally precise, but that the precision between columns varies. If LDWD >= N then WD must contain an N by M matrix of values, where D(I,J) = WD(I,J) for I=1,...,N & J=1,...,M, i.e., each element of D is individually specified, possibly indicating that the individual observations of X vary significantly in precision both from each other and from the corresponding observations of Y. 17. LDWD [INTEGER LDWD] The leading dimension of array WD. LDWD must exactly equal one or must equal or exceed N; values of LDWD less than one or between two and N-1, inclusive, will be treated as an input error. See subroutine argument WD for further details. CD 18. W [ W(N)] The singly subscripted array that contains the values that specify the observation error weights that can be used to compensate for unequal precision in the observation errors (see eq.3). By default, the observation errors are unweighted, i.e., all of the weights are assumed to be identically equal to one. The default value is invoked when W(1) is set to any negative value. Other options for specifying W are described below. If W(1) >= zero then W must contain a vector of N values, where all elements of W must be greater than or equal to zero, and W(I), I=1,...,N, specifies the weight for the observation error R(I). Zero weights eliminate the corresponding observation from the analysis. If W(1) < zero then the default option is invoked, i.e., the observation errors are unweighted. In this case, only the first element of W is ever referenced and W can be a scalar. D 19. JOB [INTEGER JOB] The value used to specify problem initialization and computational methods. The user has the option of specifying five different aspects of the problem specification: - whether the fit is to be by orthogonal distance regression (ODR) or by ordinary least squares (OLS); - whether the user has supplied subroutine JAC to compute the necessary Jacobian matrices and whether the user supplied Jacobian matrices should be checked; - whether the covariance matrix should be computed for the estimators of BETA; - whether the DELTAs have been initialized by the user; and - whether the fit is a restart. By default: - the solution will be found by ODR; - the derivatives will be computed by finite differences; - the covariance will be computed; - the DELTAs will be initialized to zero; and - the fit will not be a restart. The default value is invoked by setting JOB to any value less than zero. Setting JOB = 1 will have the same consequence as JOB = -1 except that the solution will be found by OLS. If JOB > 0 then JOB is assumed to be a 5 digit INTEGER with decimal expansion ABCDE, where each digit controls a different aspect of the problem specification. Digit A indicates whether the fit is a restart. A = 0 indicates fit is not a restart. A > 0 indicates fit is a restart. The computations will continue from where they left off for another 10 iterations. If the fit is a restart then the elements of vector WORK must be exactly as returned from a previous call to ODRPACK. No error checking will be performed to verify this. Digit B indicates whether the DELTAs have been initialized by the user. B = 0 indicates DELTAs have not been initialized by user. The DELTAs will be initialized to zero. B > 0 indicates DELTAs have been initialized by user. (See subroutine argument WORK.) Digit C indicates whether the the covariance matrix of the estimators of the parameters BETA should be computed. C = 0 indicates that the covariance matrix should be computed. (See subroutine argument IPRINT and section X.B.) C > 0 indicates that the covariance matrix should not be computed. Digit D indicates whether the user has supplied subroutine JAC to compute the necessary Jacobian matrices and whether the user supplied Jacobian matrices should be checked. D = 0 indicates that the Jacobian matrices are to be computed by finite differences and that subroutine JAC will not be used. D > 0 indicates that the user has supplied subroutine JAC to compute the necessary Jacobian matrices (see subroutine argument JAC). If D = 1 the results of the user supplied routine will be checked for correctness. (Derivative checking requires one evaluation of user supplied subroutine JAC and at least NP+M evaluations of user supplied subroutine FUN.) Users who turn off the printed error reports by setting IPRINT=0 or LUNERR=0 should examine the information returned in IWORK to determine the results of the derivative checking procedure. (See subroutine argument INFO and section X.B.) If D > 1 the results of the user supplied routine will not be checked for correctness. Digit E indicates whether the fit is to be by orthogonal distance regression (ODR) or by ordinary least squares (OLS). E = 0 indicates an ODR fit. E > 0 indicates an OLS fit. If JOB < 0 then the "default" value will be used. CD 20. NDIGIT [INTEGER NDIGIT] The number of reliable decimal digits in the predicted values (F) computed by the user's model function. (See [Gill et al., 1981].) By default, the value for NDIGIT is experimentally determined by ODRPACK using the first row of the user's data set that does not contain a zero observation. The computation of NDIGIT requires 5 evaluations of user supplied subroutine FUN. The default value is invoked when NDIGIT is set to any value outside the range [2, DIGITS], where DIGITS is the number of decimal digits carried by the user's computer for a single precision value when the SODR or SODRC are being used, and is the number carried for a double precision value when DODR or DODRC are being used. CD 21. TAUFAC [ TAUFAC] The value used to specify the initializing factor for the trust region radius. The trust region is the region in which the local approximation to the user's function is considered to be reliable. The diameter of this region is adaptively chosen at each iteration based on information from the previous iteration. At the first iteration, the initial diameter is set to the initializing factor times the length of the full Gauss-Newton step at the initial estimates. By default, the initialization factor for the trust region radius is one, thus allowing the full Gauss-Newton step to be taken at the first iteration if it does, in fact, reduce the weighted sum of squares. The default value is invoked when TAUFAC is set to any value less than or equal to zero. A value of TAUFAC greater than zero but less than one may be appropriate if, at the first iteration, the computed results overflow, or the function parameters, BETA, leave the region of interest in parameter space. Values of TAUFAC greater than one have the same effect on the computations as a value of one. CD 22. SSTOL [ SSTOL] The value used to specify the stopping tolerance for the convergence test based on relative change in the weighted sum of the squared observation errors (eq.3). The "default" sum of squares convergence stopping tolerance is the square root of machine precision, where machine precision is defined as the smallest value e such that 1+e>1 on the computer being used. The default value is invoked when the user supplied value for SSTOL is outside the interval [e,1). CD 23. PARTOL [ PARTOL] The value used to specify the stopping tolerance for the convergence test based on relative change in the estimated parameters BETA and DELTA. By default, the stopping tolerance for parameter convergence is (machine precision)**(2/3), where machine precision is defined as the smallest value e such that 1+e>1 on the computer being used. The default value is invoked when the user supplied value for PARTOL is outside the interval [e,1). CD 24. MAXIT [INTEGER MAXIT] The value used to specify the maximum number of iterations allowed. By default, the maximum number of iterations is 50. The default value is invoked when the user supplied value for MAXIT is less than or equal to zero. D 25. IPRINT [INTEGER IPRINT] The value used to control the generated computation reports, which are divided into three sections: - the initial summary - the iteration summary and - the final summary. The choice of content for each of these sections is described below. By default, the computation reports include - a "long" initial summary - no iteration summary and - a "short" final summary The default value is invoked when the user supplied value for IPRINT is less than zero. If IPRINT > 0 then IPRINT is assumed to be a 4 digit INTEGER with decimal expansion ABCD, where each digit controls a different part of the generated reports. Digit A indicates whether the initial summary will be generated. A = 0 indicates the initial summary will not be generated. A = 1 indicates a "short" initial summary will be generated that will include * the values N, M and NP, the number of observations with nonzero weights, and the number of BETAs actually being estimated. * the control values JOB, NDIGIT, TAUFAC, SSTOL, PARTOL, and MAXIT. * the weighted sum of the squared observation errors, the sum of the squared weighted DELTAs and the sum of the squared weighted EPSILONs at the initial values of BETA and DELTA. A > 1 indicates a "long" initial summary will be generated, which includes all the information found in the "short" initial summary and, in addition, includes * a summary of the independent variable data, organized by column. * the first and last observation of the dependent variable and the first and last observation error weight. * for each function parameter BETA, the initial value, whether or not the parameter is treated as fixed or not, and the scale value to be used. Digit B indicates whether the iteration summary will be generated. B = 0 indicates no iteration summary will be generated. B = 1 indicates a "short" 1 line, 68 column iteration summary will be generated every Cth iteration beginning with iteration one. This summary will list * the number of function evaluations. * the weighted sum of the squared observation errors at the current point. * the actual relative reduction in the weighted sum of the squared observation errors due to the most recently tried step (used to check for sum of squares convergence). * the predicted relative reduction in the weighted sum of the squared observation errors due to the most recently tried step (used to check for sum of squares convergence). * the ratio of the trust region radius to the norm of the BETAs and DELTAs, which is an upper bound on the relative change in the estimated values possible at the next step (used to check for parameter convergence). * whether the step was a Gauss-Newton step. B > 1 indicates an [NP/3] line, 125 column iteration summary will be generated every Cth iteration beginning with iteration 1. This summary lists all of the information found in the "short" iteration summary and, in addition, includes * current values of the BETAs. (Note that, at the last iteration, the values listed for BETA will be those that produced the actual and predicted relative reductions shown only if the most recently tried step did in fact make the fit better. If not, then the values of BETA are those that produced the best fit. Digit C indicates the frequency of the iteration summary. C = 0 indicates no iteration summary will be generated, even if the value of digit B is nonzero. C > 0 indicates an iteration summary will be generated every Cth iteration beginning with iteration one. Digit D indicates whether the final summary will be generated. D = 0 indicates the final summary will not be generated. D = 1 indicates a "short" final summary will be generated, which includes * the stopping condition. * the number of iterations, the number of function evaluations and, if the Jacobian was supplied by the user, the number of Jacobian evaluations at the time the computations stopped. * the condition number of the problem at the time the computations stopped. * the rank deficiency of the model at the time the computations stopped. * the final weighted sum of the squared observation errors, the final sum of the squared weighted DELTAs, the final sum of the squared weighted EPSILONs, and if the covariance matrix was computed, the estimated residual variance of the fit, RVAR, and the associated degrees of freedom, DF, where 1 N RVAR = -- * SUM (W(I)*R(I))**2 DF I=1 DF = the number of observations with nonzero weighted derivatives with respect to either BETA or DELTA minus the number of parameters actually estimated. * the final values of BETA, and, if the covariance matrix was computed, the standard errors for the estimators of BETA. (See subroutine argument JOB.) The standard errors are computed as the square root of the diagonal elements of the variance covariance matrix VCV, VCV = RVAR * inv( trans(FJACB)*OMEGA*FJACB ) where RVAR is defined above; FJACB is the derivative of FN(X(I,J)+DELTA(I,J);BETA) with respect to BETA, evalutated at the solution; OMEGA is the diagonal matrix which has (I,I)th element W(I)**2 OMEGA(I,I) = --------------------- M FJACX(I,J)**2 1 + SUM ------------- J=1 D(I,J)**2 with FJACX(I,J) the derivative of FN(X(I,J)+DELTA(I,J);BETA) with respect to DELTA(I,J), evaluated at the solution (for ordinary least squares, OMEGA(I,I) reduces to W(I)**2); inv(.) indicates the inverse of the designated matrix; and trans(.) indicates the transpose of the designated matrix. Note that the covariance matrix is an approximation based on a linearization of the model in the neighborhood of the solution. The validity of the approximation depends on the nonlinearity of the model, the variance and distribution of the errors, and the data itself. Confidence regions and intervals computed using the covariance matrix are often acceptable, but can be very inaccurate in some cases. When reliable confidence intervals and regions are required, other more accurate, but more computationally expensive methods of constructing them should be used. (See, e.g., Boggs and Donaldson [1989], Donaldson and Schnabel [1987], Efron [1985], and Fuller [1987].) * the first 32 values of EPSILON, and the first 32 values of each column of DELTA. D > 1 indicates a "long" final summary will be generated, which includes the same information as the "short" final summary except that * the values of all of the EPSILONs and DELTAs are listed. If IPRINT < 0 then the default reports will be generated. If IPRINT = 0 then the no reports will be generated. D 26. LUNERR [INTEGER LUNERR] The value used to specify the logical unit number of the file to be used for error messages. By default, the error messages are generated on unit 6. The default value is invoked when the user supplied value for LUNERR is less than zero. If LUNERR > 0 the error messages will be generated on unit LUNERR. If LUNERR = 0 no error messages will be generated. If LUNERR < 0 the "default" unit number will be used. D 27. LUNRPT [INTEGER LUNRPT] The value used to specify the logical unit number of the file to be used for computation reports. By default, the computation reports are generated on unit 6. The default value is invoked when the user supplied value for LUNRPT is less than zero. If LUNRPT > 0 the computation reports will be generated on unit LUNRPT. If LUNRPT = 0 no computation reports will be generated. If LUNRPT < 0 the "default" unit number will be used. 28. WORK [ WORK(LWORK)] The singly subscripted array used for work space and the array in which various computed values are returned. The smallest acceptable dimension of WORK is given below in the definition of subroutine argument LWORK. The work area does not need to be initialized by the user unless the user wishes to initialize the DELTAs. The first N*M locations of WORK contain the values for DELTA. An easy way to access these values, either for initialization (as indicated by digit B of subroutine argument JOB) or for analysis upon return from ODRPACK, is to include in the user's program the declaration statements DELTA(,) EQUIVALENCE (WORK(1), DELTA(1,1)) where indicates the first dimension of the array DELTA must be exactly the number of observations, N; and indicates the second dimension of the array DELTA must be exactly the number of columns, M, of the independent variable, X. This allows the error associated with observation X(I,J) of the independent variable matrix to be accessed as DELTA(I,J) rather than as WORK(I+(J-1)*N). The input values of array DELTA will be over written by the final estimates of the errors in the independent variable matrix when this equivalencing method is used. Other values returned in array WORK may also be of general interest and can be accessed as described below in section X. N.B., if the fit is a restart, i.e., if digit A of subroutine argument JOB is nonzero, then all elements of vector WORK, including the values of DELTA, must be exactly as returned from a previous call to ODRPACK. 29. LWORK [INTEGER LWORK] The length of array WORK. LWORK must equal or exceed 17 + 7*N + 10*N*M + 2*N*NP + 8*NP . Values of LWORK less than this value will be treated as an input error. 30. IWORK [INTEGER IWORK(LIWORK)] The singly subscripted array used for INTEGER work space and the array in which various computed values are returned. The smallest acceptable dimension of IWORK is given below in the definition of subroutine argument LIWORK. Certain values returned in array IWORK are of general interest and can be accessed as described below in section X. In particular, the results of the derivative checking procedure are encoded in IWORK, and may be useful if ODRPACK's error reports have been suppressed. 31. LIWORK [INTEGER LIWORK] The length of array IWORK. LIWORK must equal or exceed 19 + 2*NP + M . Values of LIWORK less than this value will be treated as an input error. 32. INFO [INTEGER INFO] The argument used to indicate why the computations stopped. If 1 <= INFO <= 3 then the program converged satisfactorily. The convergence condition met is indicated by the value of INFO as follows. INFO = 1 : sum of squares convergence INFO = 2 : parameter convergence INFO = 3 : sum of squares convergence and parameter convergence If INFO = 4 then the program reached the maximum number of iterations allowed without meeting one of the convergence conditions. If INFO > 4 and INFO < 10000 then the results from ODRPACK are questionable. In this case, INFO is a 4 digit INTEGER with decimal expansion ABCD, where digit D indicates the actual stopping condition, and the nonzero values of digits A, B and C indicate what questionable conditions were found. Digit A = 1 indicates the ODRPACK Jacobian matrix checking procedure determined that the correctness of the user supplied Jacobian matrices is questionable. This occurs when the derivative is exactly zero or when the numerical derivative used in the checking procedure is believed to be inaccurate. (Zero valued derivatives are questionable because they could indicate that the initial values of the function parameters BETA might be hiding an error in the derivative, such as could occur if the initial value of one of the parameters were zero.) Users should examine the ODRPACK error reports or the encoded values of IWORK (see section X.B) to determine the cause of the questionable results, and then examine subroutine JAC to insure that there is not an error in the user supplied derivatives that could be adversely affecting the least squares results. Digit B = 1 indicates the the most recently tried values of BETA and/or X+DELTA were unacceptable, as indicated by the returned value of ISTOPF from user supplied subroutine FUN (see argument FUN). Digit C > 0 indicates the Jacobian with respect to the function parameters BETA is not full rank at the solution. If C=1 the rank is greater than zero but less than the number of parameters being estimated. If C=2 the rank is zero, indicating that the results of user supplied subroutines FUN and/or JAC are unaffected by changes in the unfixed function parameters (BETA), and therefore indicating that there is a probable error in these user supplied subroutines. Digit D > 0 indicates the actual stopping condition. If D=1 the sum of squares convergence criteria was met. If D=2 the parameter convergence criteria was met. If D=3 the sum of squares convergence criteria and the parameter convergence criteria were met. If D=4 the program reached the maximum number of iterations allowed without meeting one of the convergence conditions. If INFO > 9999 then fatal errors were detected that required that the computations be stopped. In this case, INFO is a 5 digit INTEGER with decimal expansion ABCDE, where each nonzero digit indicates a different error condition. Digit A = 1 indicates an error was detected in the arguments used to specify the problem size. When digit A = 1 then digit B = 1 indicates N < 1 digit C = 1 indicates M < 1 digit D = 1 indicates NP < 1 or NP > N Digit A = 2 indicates an error was detected in the arguments used to specify array dimensions. When digit A = 2 then digit B = 1 indicates LDX < N digit C > 0 indicates LDIFX, LDSCLD and/or LDWD are unacceptable (see definitions of LDIFX, LDSCLD and LDWD for acceptable values), where if C=1 LDIFX is bad if C=2 LDSCLD is bad if C=3 LDIFX & LDSCLD are bad if C=4 LDWD is bad if C=5 LDIFX & LDWD are bad if C=6 LDSCLD & LDWD are bad if C=7 LDIFX, LDSCLD & LDWD are bad digit D = 1 indicates LWORK is too small (see definition of LWORK for smallest acceptable value) digit E = 1 indicates LIWORK is too small (see definition of LIWORK for smallest acceptable value) Digit A = 3 indicates an error was detected in the arguments used to specify scaling and/or the in the arguments used to specify the weights. When digit A = 3 then digit B = 1 indicates an error in SCLD (see definition of SCLD for reasonable values) digit C = 1 indicates an error in SCLB (see definition of SCLB for reasonable values) digit D > 1 indicates an error in W, where if D=1 one or more of the elements of W are invalid (see definition of W for reasonable values) if D=2 the number of nonzero values in W is less than NP digit E = 1 indicates an error in WD (see definition of WD for reasonable values) Digit A = 4 indicates an error was detected in the user supplied Jacobian matrices. When digit A = 4 then digit B = 1 indicates an error in the Jacobian matrix with respect to BETA (see the generated error reports, or section X.B for locations in IWORK that indicate which derivatives are in error) digit C = 1 indicates an error in the Jacobian matrix with respect to X (see the generated error reports, or section X.B for locations in IWORK that indicate which derivatives are in error) Digit A = 5 indicates the values of BETA and/or X+DELTA were identified as unacceptable by user supplied subroutine FUN or JAC. When digit A = 5 then digit B > 0 indicates the computations were stopped in user supplied subroutine FUN, where if B=1 variable ISTOPF was returned with a negative value from subroutine FUN when it was invoked during the regression procedure, indicating that the user wanted the computations stopped if B=2 variable ISTOPF was returned with a nonzero value when subroutine FUN was invoked using the initial estimates of BETA and DELTA supplied by the user, so no further computations could be performed if B=3 variable ISTOPF was returned with a nonzero value when subroutine FUN was was invoked during the computation of the number of reliable digits in the predicted values (F) returned from subroutine FUN, indicating that changes in the initial estimates of BETA(K), K=1,NP, as small as 2*BETA(K)*sqrt(e), where e is defined as the smallest value such that 1+e>1 on the computer being used, prevent subroutine FUN from being properly evaluated if B=4 variable ISTOPF was returned with a nonzero value when subroutine FUN was was invoked during the derivative checking procedure, indicating that changes in the initial estimates of BETA(K), K=1,NP, small as max[BETA(K),1/SCLB(K)]*10**(-NETA/2), and/or of DELTA(I,J), i=1,N and j=1,M, as small as max[DELTA(I,J), 1/SCLD(I,J)]*10**(-NETA/2), where NETA is defined to be the number of reliable digits in predicted values (F) returned from subroutine FUN, prevent subroutine fun from being properly evaluated digit C > 0 indicates the computations were stopped in user supplied subroutine JAC, where if C=1 variable ISTOPJ was returned with a nonzero value from subroutine JAC when it was invoked during the regression procedure, indicating that the user wanted the computations stopped if C=2 variable ISTOPJ was returned with a nonzero value from subroutine JAC when it was invoked using the initial estimates of BETA and DELTA supplied by the user, so no further computations could be performed 1 VIII. EXAMPLES -------- The following sample programs use DODR and DODRC to solve exercise I on page 521 and 522 of Draper and Smith [1981]. The program calling DODR uses the default option of computing the derivatives by finite differences, while the program calling DODRC uses analytic derivatives. Note that the results of these two examples are not identical, primarily because the DODRC example has "fixed" one column of the independent variable. Finite difference derivatives generally cause very little change in the results from those obtained using analytic derivatives. Users are encouraged to extract these examples from the online ODRPACK documentation, and to then modify them as necessary to form their own ODRPACK drivers. (Single precision sample programs can be easily generated from these two programs by changing all DOUBLE PRECISION variables to REAL, and substituting SODR for DODR and SODRC for DODRC.) Note especially that by using parameters MAXN, MAXM and MAXNP to specify the largest problem the program can solve without modification, and by specifying LWORK and LIWORK exactly as shown, the user greatly reduces the number of changes that must be made to the program in order to solve a larger problem. 1 VIII.A DODR Example Program, Data and ODRPACK Generated Report User supplied code for DODR example: PROGRAM SAMPLE C SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER C WHERE MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED C MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE C INDEPENDENT VARIABLE ALLOWED C MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS C ALLOWED C LDX IS THE LEADING DIMENSION OF ARRAY X C LDWD IS THE LEADING DIMENSION OF ARRAY WD C LWORK IS THE DIMENSION OF VECTOR WORK C LIWORK IS THE DIMENSION OF VECTOR IWORK C...PARAMETERS INTEGER + MAXN,MAXM,MAXNP,LDX,LDWD,LWORK,LIWORK PARAMETER + (MAXN=15, + MAXM=5, + MAXNP=5, + LDX=MAXN, + LDWD=1, + LWORK = 17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP, + LIWORK = 19 + 2*MAXNP + MAXM) C DECLARE USER-SUPPLIED SUBROUTINES AND C ALL OTHER NECESSARY VARIABLES AND ARRAYS C...LOCAL SCALARS INTEGER + I,INFO,IPRINT,J,JOB,LUNERR,LUNRPT,M,N,NP C...LOCAL ARRAYS DOUBLE PRECISION + BETA(MAXNP),WD(LDWD,MAXM),WORK(LWORK), + X(LDX,MAXM),Y(LDX) INTEGER + IWORK(LIWORK) C...EXTERNAL SUBROUTINES EXTERNAL + DODR,FUN,JAC OPEN(UNIT=5,FILE='DATA1') OPEN(UNIT=6,FILE='REPORT') C READ NUMBER OF OBSERVATIONS C NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE C NUMBER OF PARAMETERS C OBSERVED VALUES OF INDEPENDENT AND DEPENDENT VARIABLES C STARTING VALUES OF FUNCTION PARAMETERS READ (5,*) N,M,NP READ (5,*) ((X(I,J),I=1,N),J=1,M) READ (5,*) (Y(I),I=1,N) READ (5,*) (BETA(I),I=1,NP) C SPECIFY DELTA WEIGHTS WD(1,1) = 3.0D0 WD(1,2) = 5.0D0 C SET CONTROL VALUES TO INVOKE DEFAULT SETTING JOB = -1 IPRINT = -1 LUNERR = -1 LUNRPT = -1 C COMPUTE ODR SOLUTION USING FINITE-DIFFERENCE DERIVATIVES CALL DODR + (FUN,JAC, + N,M,NP, + X,LDX, + Y, + BETA, + WD,LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) END SUBROUTINE FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOPF) C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) C INTEGER N,NP,M,LDXPD C DOUBLE PRECISION BETA(NP),XPLUSD(LDXPD,M) C OUTPUT ARGUMENTS C DOUBLE PRECISION F(N) C INTEGER ISTOPF C...SCALAR ARGUMENTS INTEGER + ISTOPF,LDXPD,M,N,NP C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),F(N),XPLUSD(LDXPD,M) C...LOCAL SCALARS INTEGER + I C...INTRINSIC FUNCTIONS INTRINSIC + EXP DO 10 I = 1, N IF (XPLUSD(I,2).NE.0.0D0) THEN F(I) = EXP(-BETA(1)*XPLUSD(I,1)* + EXP(-BETA(2)* + (1.0D0/XPLUSD(I,2) - 1.0D0/620.0D0))) ELSE ISTOPF = 1 RETURN END IF 10 CONTINUE ISTOPF = 0 RETURN END 1 User supplied data (file DATA1): 8 2 2 109.0 65.0 1180.0 66.0 1270.0 69.0 1230.0 68.0 600.0 640.0 600.0 640.0 600.0 640.0 600.0 640.0 0.912 0.382 0.397 0.376 0.342 0.358 0.348 0.376 0.01155 5000.0 1 Report generated by DODR example program, using a Sun 3 Workstation: ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* INITIAL SUMMARY FOR FIT BY METHOD OF ODR ======================================== PROBLEM SIZE: ------------- NUMBER OF OBSERVATIONS 8 NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS 8 NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE 2 NUMBER OF FUNCTION PARAMETERS 2 NUMBER OF UNFIXED FUNCTION PARAMETERS 2 INDEPENDENT VARIABLE AND DELTA WEIGHT SUMMARY: ---------------------------------------------- COLUMN 1 COLUMN 2 OBS 1 OBS N OBS 1 OBS N X - 0.10900D+03 0.68000D+02 0.60000D+03 0.64000D+03 FIXED - NO NO NO NO INITIAL DELTA - 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 DELTA SCALE - 0.91743D-02 0.14706D-01 0.15625D-02 0.15625D-02 DELTA WEIGHTS - 0.30000D+01 0.30000D+01 0.50000D+01 0.50000D+01 DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT SUMMARY: ---------------------------------------------------------- OBS 1 OBS N Y - 0.91200D+00 0.37600D+00 OBS. ERROR WTS. - 0.10000D+01 0.10000D+01 FUNCTION PARAMETER SUMMARY: --------------------------- INDEX - 1 2 INITIAL BETA - 0.11550000D-01 0.50000000D+04 FIXED - NO NO BETA SCALE - 0.86580087D+02 0.20000000D-03 CONTROL VALUES AND STOPPING CRITERIA: -------------------------------------- * JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT 00000 15 0.10D+01 0.15D-07 0.37D-10 50 * A. FIT IS NOT A RESTART. B. DELTAS ARE INITIALIZED TO ZERO. C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS WILL BE COMPUTED AT THE SOLUTION. D. DERIVATIVES ARE COMPUTED BY FINITE DIFFERENCES. E. FIT IS BY METHOD OF ORTHOGONAL DISTANCE REGRESSION. INITIAL SUMS OF SQUARES: ------------------------ SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.67662011D+00 SUM OF SQUARED WEIGHTED DELTAS 0.00000000D+00 SUM OF SQUARED WEIGHTED EPSILONS 0.67662011D+00 FINAL SUMMARY FOR FIT BY METHOD OF ODR ====================================== STOPPING CONDITION (INFO = 1): ----------------------------------- THE RELATIVE CHANGE IN THE SUM OF THE SQUARED WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL CONDITION NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS (INVERSE) DEFICIENCY 5 42 0.1888D-06 0 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.75382323D-03 SUM OF SQUARED WEIGHTED DELTAS 0.23542098D-07 SUM OF SQUARED WEIGHTED EPSILONS 0.75379969D-03 ESTIMATED RESIDUAL VARIANCE 0.12563720D-03 ( 6 DEGREES OF FREEDOM) ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- J BETA(J) STD. DEV. BETA(J) 1 0.36579727D-02 0.42219552D-04 2 0.27627327D+05 0.22245631D+03 ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N: --------------------------------------------------- I EPSILON(I) DELTA(I,1) DELTA(I,2) 1 0.16752445D-02 0.14086172D-06 0.42418826D-06 2 0.20434718D-02 0.12838222D-05 0.20262810D-05 3 -0.20690085D-01 -0.71652290D-06 -0.23358824D-04 4 0.24305832D-02 0.15047092D-05 0.24114481D-05 5 0.72777482D-02 0.23393281D-06 0.82079307D-05 6 0.40793264D-02 0.24162846D-05 0.40483550D-05 7 0.13043071D-01 0.43337343D-06 0.14726726D-04 8 -0.85499649D-02 -0.51394679D-05 -0.84861061D-05 1 VIII.B DODRC Example Program, Data and ODRPACK Generated Report User supplied code for DODRC example: PROGRAM SAMPLE C SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER C WHERE MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED C MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE C INDEPENDENT VARIABLE ALLOWED C MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS C ALLOWED C LDX IS THE LEADING DIMENSION OF ARRAY X C LDSCLD IS THE LEADING DIMENSION OF ARRAY SCLD C LDWD IS THE LEADING DIMENSION OF ARRAY WD C LDIFX IS THE LEADING DIMENSION OF ARRAY IFIXX C LWORK IS THE DIMENSION OF VECTOR WORK C LIWORK IS THE DIMENSION OF VECTOR IWORK C...PARAMETERS INTEGER + MAXN,MAXM,MAXNP,LDSCLD,LDIFX,LDWD,LWORK,LIWORK PARAMETER + (MAXN=15, + MAXM=5, + MAXNP=5, + LDSCLD=1, + LDWD=1, + LDIFX=1, + LWORK=17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP, + LIWORK=19 + 2*MAXNP + MAXM) C DECLARE USER-SUPPLIED SUBROUTINES AND C ALL OTHER NECESSARY VARIABLES AND ARRAYS C...LOCAL SCALARS DOUBLE PRECISION + PARTOL,SSTOL,TAUFAC INTEGER + I,INFO,IPRINT,J,JOB,LDX,LUNERR,LUNRPT,M,MAXIT,N,NDIGIT,NP C...LOCAL ARRAYS DOUBLE PRECISION + BETA(MAXNP),WD(LDWD,MAXM),SCLB(MAXNP), + SCLD(LDSCLD,MAXM),W(MAXN),WORK(LWORK),X(MAXN,MAXM),Y(MAXN) INTEGER + IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK) C...EXTERNAL SUBROUTINES EXTERNAL + DODRC,FUN,JAC OPEN(UNIT=5,FILE='DATA1') OPEN(UNIT=6,FILE='REPORT') C SPECIFY LEADING DIMENSION OF ARRAY X LDX = MAXN C READ NUMBER OF OBSERVATIONS C NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE C NUMBER OF PARAMETERS C OBSERVED VALUES OF INDEPENDENT AND DEPENDENT VARIABLES C STARTING VALUES OF FUNCTION PARAMETERS READ (5,*) N,M,NP READ (5,*) ((X(I,J),I=1,N),J=1,M) READ (5,*) (Y(I),I=1,N) READ (5,*) (BETA(I),I=1,NP) C FIX SECOND COLUMN OF INDEPENDENT VARIABLE AT OBSERVED VALUES IFIXX(1,1) = 1 IFIXX(1,2) = 0 C SPECIFY USE OF DEFAULT SCALING SCLD(1,1) = -1.0D0 SCLB(1) = -1.0D0 C INDICATE ALL BETA'S ARE TO BE ESTIMATED IFIXB(1) = -1 C SPECIFY WEIGHTS WD(1,1) = 3.0D0 WD(1,2) = 5.0D0 W(1) = -1.0D0 C SET CONTROL VALUES AND STOPPING CRITERIA JOB = 10 NDIGIT = -1 TAUFAC = -1.0D0 SSTOL = -1.0D0 PARTOL = -1.0D0 MAXIT = -1 IPRINT = 1111 LUNERR = -1 LUNRPT = -1 C COMPUTE ODR SOLUTION USING USER-SUPPLIED ANALYTIC DERIVATIVES CALL DODRC + (FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) END SUBROUTINE FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOPF) C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) C INTEGER N,NP,M,LDXPD C DOUBLE PRECISION BETA(NP),XPLUSD(LDXPD,M) C OUTPUT ARGUMENTS C DOUBLE PRECISION F(N) C INTEGER ISTOPF C...SCALAR ARGUMENTS INTEGER + ISTOPF,LDXPD,M,N,NP C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),F(N),XPLUSD(LDXPD,M) C...LOCAL SCALARS INTEGER + I C...INTRINSIC FUNCTIONS INTRINSIC + EXP DO 10 I = 1, N IF (XPLUSD(I,2).NE.0.0D0) THEN F(I) = EXP(-BETA(1)*XPLUSD(I,1)* + EXP(-BETA(2)* + (1.0D0/XPLUSD(I,2) - 1.0D0/620.0D0))) ELSE ISTOPF = 1 RETURN END IF 10 CONTINUE ISTOPF = 0 RETURN END SUBROUTINE JAC(N,NP,M,BETA,XPLUSD,LDXPD, + FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOPJ) C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) C INTEGER N,NP,M,LDXPD C DOUBLE PRECISION BETA(NP),XPLUSD(LDXPD,M) C LOGICAL ISODR C OUTPUT ARGUMENTS C DOUBLE PRECISION FJACB(LDFJB,NP),FJACX(LDFJX,M) C INTEGER ISTOPJ C...SCALAR ARGUMENTS INTEGER + ISTOPJ,LDFJB,LDFJX,LDXPD,M,N,NP LOGICAL + ISODR C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),FJACB(LDFJB,NP),FJACX(LDFJX,M),XPLUSD(LDXPD,M) C...LOCAL SCALARS DOUBLE PRECISION + FAC1,FAC2,FAC3,FAC4 INTEGER + I C...INTRINSIC FUNCTIONS INTRINSIC + EXP DO 10 I=1,N FAC1 = 1.0D0/XPLUSD(I,2) - 1.0D0/620.0D0 FAC2 = EXP(-BETA(2)*FAC1) FAC3 = BETA(1)*XPLUSD(I,1) FAC4 = EXP(-FAC3*FAC2) FJACB(I,1) = -FAC4*XPLUSD(I,1)*FAC2 FJACB(I,2) = FAC4*FAC3*FAC2*FAC1 IF (ISODR) THEN FJACX(I,1) = -FAC4*BETA(1)*FAC2 FJACX(I,2) = -FAC4*FAC3*FAC2*BETA(2)/XPLUSD(I,2)**2 END IF 10 CONTINUE ISTOPJ = 0 RETURN END 1 User supplied data (file DATA1): 8 2 2 109.0 65.0 1180.0 66.0 1270.0 69.0 1230.0 68.0 600.0 640.0 600.0 640.0 600.0 640.0 600.0 640.0 0.912 0.382 0.397 0.376 0.342 0.358 0.348 0.376 0.01155 5000.0 1 Report generated by DODRC example program, using a Sun 3 Workstation: ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* INITIAL SUMMARY FOR FIT BY METHOD OF ODR ======================================== PROBLEM SIZE: ------------- NUMBER OF OBSERVATIONS 8 NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS 8 NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE 2 NUMBER OF FUNCTION PARAMETERS 2 NUMBER OF UNFIXED FUNCTION PARAMETERS 2 CONTROL VALUES AND STOPPING CRITERIA: -------------------------------------- * JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT 00010 15 0.10D+01 0.15D-07 0.37D-10 50 * A. FIT IS NOT A RESTART. B. DELTAS ARE INITIALIZED TO ZERO. C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS WILL BE COMPUTED AT THE SOLUTION. D. DERIVATIVES ARE SUPPLIED BY USER. USER-SUPPLIED DERIVATIVES WERE CHECKED. THE DERIVATIVES APPEAR TO BE CORRECT. E. FIT IS BY METHOD OF ORTHOGONAL DISTANCE REGRESSION. INITIAL SUMS OF SQUARES: ------------------------ SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.67662011D+00 SUM OF SQUARED WEIGHTED DELTAS 0.00000000D+00 SUM OF SQUARED WEIGHTED EPSILONS 0.67662011D+00 ITERATION REPORTS FOR FIT BY METHOD OF ODR ========================================== CUM. ACT. REL. PRED. REL. IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS G-N NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION TAU/PNORM STEP ---- ------ ----------- ----------- ----------- --------- ---- 1 12 0.19694D+00 0.7089D+00 0.4162D+00 0.151D+01 YES 2 13 0.18660D-02 0.9905D+00 0.9957D+00 0.671D+00 YES 3 14 0.75385D-03 0.5960D+00 0.5961D+00 0.463D-01 YES 4 15 0.75385D-03 0.3659D-06 0.3659D-06 0.224D-04 YES 5 16 0.75385D-03 0.3715D-13 0.3892D-13 0.482D-08 YES FINAL SUMMARY FOR FIT BY METHOD OF ODR ====================================== STOPPING CONDITION (INFO = 1): ----------------------------------- THE RELATIVE CHANGE IN THE SUM OF THE SQUARED WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL CONDITION NUMBER OF NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS JAC EVALS (INVERSE) DEFICIENCY 5 17 7 0.1888D-06 0 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.75384644D-03 SUM OF SQUARED WEIGHTED DELTAS 0.33248273D-09 SUM OF SQUARED WEIGHTED EPSILONS 0.75384611D-03 ESTIMATED RESIDUAL VARIANCE 0.12564107D-03 ( 6 DEGREES OF FREEDOM) ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- J BETA(J) STD. DEV. BETA(J) 1 0.36579727D-02 0.42219603D-04 2 0.27627326D+05 0.22245657D+03 ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N: --------------------------------------------------- I EPSILON(I) DELTA(I,1) DELTA(I,2) 1 0.16752465D-02 0.14086188D-06 0.00000000D+00 2 0.20435276D-02 0.12838572D-05 0.00000000D+00 3 -0.20690747D-01 -0.71654588D-06 0.00000000D+00 4 0.24306485D-02 0.15047496D-05 0.00000000D+00 5 0.72779764D-02 0.23394016D-06 0.00000000D+00 6 0.40794324D-02 0.24163474D-05 0.00000000D+00 7 0.13043483D-01 0.43338715D-06 0.00000000D+00 8 -0.85501699D-02 -0.51395912D-05 0.00000000D+00 1 IX. SCALING ALGORITHMS ------------------ Poorly scaled problems, i.e., problems in which the unknowns BETA and DELTA vary over several orders of magnitude, can cause least squares procedures difficulty. ODRPACK's scaling algorithms (discussed below) attempt to overcome these difficulties automatically, although it is preferable for the user to choose the units of the variable space so that the estimated parameters will have roughly the same magnitude [Dennis and Schnabel, 1983]. When the variables have roughly the same magnitude, the ODRPACK scaling algorithm will select scale values that are roughly equal, and the resulting computations will be the same (except for the effect of finite precision arithmetic) as an unscaled analysis, i.e., an analysis in which all of the scale values are set to one. If the user does not do this, the ODRPACK scaling algorithm will select varying scale values. This will not change the optimal solution, but it may affect the number of iterations required, or, in some cases, whether the algorithm is or is not successful. Users may substitute their own scaling values using subroutine arguments SCLD and SCLB (see section VII.B). 1 IX.A BETA Scaling ODRPACK chooses the scale values for the estimated BETAs as follows. If some of the starting values of BETA are nonzero then let BETA_max = the largest absolute value of the nonzero starting values of BETA, and BETA_min = the smallest absolute value of the nonzero starting values of BETA. For K = 1 to NP do if BETA(K) = zero then scale_BETA(K) = ten/BETA_min else if LOG10(BETA_max)-LOG10(BETA_min) > one then scale_BETA(K) = one/ABS(BETA(K)) else scale_BETA(K) = one/BETA_max. If all of the starting values of BETA are zero then for K = 1 to NP do scale_BETA(K) = one. Users may substitute their own BETA scaling values via subroutine argument SCLB. 1 IX.B DELTA Scaling ODRPACK chooses scale values for the estimated errors in the independent variables, i.e., for the DELTAs, as follows. For J = 1 to M do If some of the values of the Jth column of X are nonzero then let X_max = the largest nonzero absolute value in the Jth column of array X, and X_min = the smallest nonzero absolute value in the Jth column of array X. For I = 1 to N do if X(I,J) = zero then scale_X(I,J) = ten/X_min else if LOG10(X_max)-LOG10(X_min) > one then scale_X(I,J) = one/ABS(X(I,J)) else scale_X(I,J) = one/X_max. If all of the values of the Jth column of X are zero then For I = 1 to N do scale_X(I,J) = one Users may substitute their own DELTA scaling values via subroutine argument SCLD. 1 X. EXTRACTING INFORMATION FROM THE WORK VECTORS -------------------------------------------- X.A Extracting Information from Vector WORK Upon return from a call to ODRPACK, array WORK contains various values, some of which may be of interest to the user. To extract information from WORK, the following declaration statement must be added to the user's program: INTEGER + DELTAI,EPSI, + WSSI,WSSDEI,WSSEPI,RVARI, + PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI, + FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,DELTSI, + DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,TAUI, + ALPHAI,VCVI,OMEGAI,YTI,UI,QRAUXI,WRK1I,SDI,RCONDI, + ETAI,ACTRSI,PNORMI,PRERSI,RNORSI, + LWKMN where DELTAI through RNORSI are variables that indicate the starting locations within WORK of the stored values, and LWKMN is the minimum acceptable length of array WORK. The appropriate values of DELTAI through RNORSI are obtained by invoking subroutine SWINF when using either of the single precision ODRPACK subroutines, SODR or SODRC, and by invoking DWINF when using either of the double precision subroutines, DODR or DODRC. The call statements for SWINF and DWINF have the same argument lists. To invoke either subroutine, use CALL + (N,M,NP, + DELTAI,EPSI, + WSSI,WSSDEI,WSSEPI,RVARI, + PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI, + FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,DELTSI, + DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,TAUI, + ALPHAI,VCVI,OMEGAI,YTI,UI,QRAUXI,WRK1I,SEI,RCONDI, + ETAI,ACTRSI,PNORMI,PRERSI,RNORSI, + LWKMN) where SWINF should be substituted for when using single precision subroutines SODR and SODRC, and DWINF should be substituted for when using double precision subroutines DODR and DODRC. The values of N, M and NP must be input to SIWINF and DIWINF with exactly the same values as were used in the original call to ODRPACK. (If possible, users should extract these declaration and call statements from online ODRPACK documentation to avoid typographical errors.) In the following descriptions of the information returned in WORK, (*) indicates values that are likely to be of greatest interest. (*) WORK(DELTAI) is the first element of the N by M matrix, DELTA, containing the estimated errors in the independent variables at the solution, DELTA(I,J) = WORK(DELTAI-1+I+(J-1)*N) for I=1,...,N & J=1,...,M. (*) WORK(EPSI) is the first element of the N vector, EPSILON, containing the estimated errors in the dependent variables at the solution, EPSILON(I) = WORK(EPSI-1+I) for I=1,...,N. (*) WORK(WSSI) is the weighted sum of the squared observation errors (eq.3) at the time the computations stopped, i.e., WORK(WSSI) = WORK(WSSDEI) + WORK(WSSEPI) where WORK(WSSDEI) and WORK(WSSEPI) are defined below. (*) WORK(WSSDEI) is the weighted sum of the squared DELTAs at the time the computations stopped, i.e., N M WORK(WSSDEI) = SUM [ SUM ( W(I)*D(I,J)*DELTA(I,J) )**2 ] . I=1 J=1 (*) WORK(WSSEPI) is the weighted sum of the squared EPSILONs at the time the computations stopped, i.e., N WORK(WSSEPI) = SUM [ ( W(I)*EPSILON(I) )**2 ] . I=1 (*) WORK(RVARI) is the estimated residual variance at the time the computations stopped, i.e., N SUM [ ( W(I)*R(I) )**2 ] I=1 WORK(RVARI) = ------------------------ DF where DF is the degrees of freedom of the fit, i.e., the number of observations with nonzero weighted derivatives with respect to either BETA or DELTA minus the number of parameters being estimated. WORK(PARTLI) is the value of the stopping tolerance used to detect parameter convergence. WORK(SSTOLI) is the value of the stopping tolerance used to detect sum of squares convergence. WORK(TAUFCI) is the value of the factor used to compute the initial trust region radius. WORK(EPSMAI) is the value of machine precision, i.e., the smallest value e such that 1+e>1. WORK(OLMAVI) is the average number of steps to obtain the Levenberg- Marquardt parameter. WORK(FJACBI) is the first element of the N by NPP matrix, FJACB, containing the weighted derivative with respect to BETA, evaluated at the solution if the covariance matrix was computed, otherwise evaluated at the beginning of the last iteration, FJACB(I,J) = WORK(FJACBI-1+I+(J-1)*N) for I=1,...,N & J=1,...,NP. WORK(FJACXI) is the first element of the N by M matrix, FJACX, containing the weighted derivative with respect to X, evaluated at the solution if the covariance matrix was computed, otherwise evaluated at the beginning of the last iteration, FJACX(I,J) = WORK(FJACXI-1+I+(J-1)*N) for I=1,...,N & J=1,...,M. (*) WORK(XPLUSI) is the first element of the N by M matrix containing the final estimates of X, i.e., estimated< X > = observed< X > + estimated< DELTA > computed using the final estimates of DELTA, XPLUSD(I,J) = WORK(XPLUSI-1+I+(J-1)*N) for I=1,...,N & J=1,...,M. WORK(BETACI) is the first element of the NP vector, BETAC, containing the current working estimates of the unfixed subset of the function parameters, BETAC(I) = WORK(BETACI-1+I) for I=1,...,NP. WORK(BETASI) is the first element of the NP vector, BETAS, containing the previous working estimates of the unfixed subset of the function parameters, BETAS(I) = WORK(BETASI-1+I) for I=1,...,NP. WORK(BETANI) is the first element of the NP vector, BETAN, containing the new working estimates of the unfixed subset of the function parameters, BETAN(I) = WORK(BETANI-1+I) for I=1,...,NP. WORK(DELTSI) is the first element of the N by M matrix, DELTAS, containing the previous working estimates of the errors in the independent variables, DELTAS(I,J) = WORK(DELTASI-1+I+(J-1)*N) for I=1,...,N & J=1,...,M. WORK(DELTNI) is the first element of the N by M matrix, DELTAN, containing the new working estimates of the errors in the independent variables, DELTAN(I,J) = WORK(DELTANI-1+I+(J-1)*N) for I=1,...,N & J=1,...,M. WORK(DDELTI) is the first element of the N by M matrix containing the weighted estimated errors in the independent variables, DDELTA = (W*D)**2 * DELTA, DDELTA(I,J) = WORK(DDELTI-1+I+(J-1)*N) for I=1,...,N & J=1,...,M. WORK(FSI) is the first element of the N vector, FS, containing the saved weighted estimated errors in the dependent variable, FS(I) = WORK(FSI-1+I) for I=1,...,N. (*) WORK(FNI) is the first element of the N vector, FN, containing the final estimates of Y = FN(X+DELTA;BETA), i.e., estimated< Y > = observed< Y > + estimated< EPSILON > computed using the final estimates of EPSILON, FN(I) = WORK(FNI-1+I) for I=1,...,N. WORK(SI) is the first element of the NP vector, S, containing the step in the estimated function parameters, S(I) = WORK(SI-1+I) for I=1,...,NP. (*) WORK(SSSI) is the first element of the N + N*M vector, SSS, containing the weighted errors at the solution, SSS(I) = WORK(SSSI-1+I) for I=1,...,N + N*M, where the first N elements contain the weighted EPSILONs, W(I)*EPSILON(I) = WORK(SSSI-1+I) for I=1,...,N and the next N*M elements contain the weighted DELTAs, W(I)*D(I,J)*DELTA(I,J) = WORK(SSSI-1+I+J*N) for I=1,...,N & J=1,...,M. WORK(SSI) is the first element of the NP vector, SS, containing the scale of the estimated function parameters, SS(I) = WORK(SSI-1+I) for I=1,...,NP. WORK(SSFI) is the first element of the NP vector, SSF, containing the scale of each of the function parameters, SSF(I) = WORK(SSFI-1+I) for I=1,...,NP. WORK(TI) is the first element of the N by M array, T, containing the step in the estimated errors in the independent variable, T(I,J) = WORK(TI-1+I+(J-1)*N) for I=1,...,N & J=1,...,M. WORK(TTI) is the first element of the N by M array, TT, containing the scale of each the estimated errors in the independent variable, TT(I,J) = WORK(TTI-1+I+(J-1)*N) for I=1,...,N & J=1,...,M. WORK(TAUI) is the trust region radius at the time the computations stopped. WORK(ALPHAI) is the Levenberg-Marquardt parameter at the time the computations stopped. (*) WORK(VCVI) is the first element of the covariance matrix of the NPP unfixed parameters, stored as an upper triangular matrix, VCV(I,J) = WORK(VCVI-1+I+(J-1)*N) VCV(J,I) = VCV(I,J) for I=1,...,NPP & J=I,...,NPP. The covariance matrix is only computed when the third digit of JOB is zero, and when the solution is full rank. The covariance matrix is defined as VCV = RVAR * inv( trans(FJACB)*OMEGA*FJACB ) where RVAR is the residual variance of the fit, 1 N RVAR = -- * SUM (W(I)*R(I))**2 DF I=1 with DF the number of observations with nonzero weighted derivatives with respect to either BETA or DELTA minus the number of parameters actually estimated, FJACB is the derivative of FN(X(I,J)+DELTA(I,J);BETA) with respect to BETA, evalutated at the solution, OMEGA is the diagonal matrix which has (I,I)th element W(I)**2 OMEGA(I,I) = --------------------- M FJACX(I,J)**2 1 + SUM ------------- J=1 D(I,J)**2 with FJACX(I,J) the derivative of FN(X(I,J)+DELTA(I,J);BETA) with respect to DELTA(I,J), evalutated at the solution (for ordinary least squares, OMEGA(I,I) reduces to W(I)**2), inv(.) indicates the inverse of the designated matrix, and trans(.) indicates the transpose of the designated matrix. Note that the covariance matrix is an approximation based on a linearization of the model in the neighborhood of the solution. The validity of the approximation depends on the nonlinearity of the model, the variance and distribution of the errors, and the data itself. Confidence regions and intervals computed using the variance covariance matrix are often acceptable, but can be very inaccurate in some cases. When reliable confidence intervals and regions are required, other more accurate, but more computationally expensive methods of constructing them should be used. (See, e.g., Boggs and Donaldson [1989], Donaldson and Schnabel [1987], Efron [1985], and Fuller [1987].) WORK(OMEGAI) is the first element of the N vector OMEGA(I) = WORK(OMEGAI-1+I) W(I)**2 = --------------------- M FJACX(I,J)**2 1 + SUM ------------- J=1 D(I,J)**2 for I=1,...,N, computed at the solution if the covariance matrix was calculated. WORK(YTI) is the first element of the N vector containing the diagonal elements of YT(I) = WORK(YTI-1+I) = -diag[sqrt(OMEGA(I),I=1,...,N]*(G1-V*inv(E)*D*G2) for I=1,...,N. WORK(UI) is the first element of the N vector, U, containing the approximate null vector for FJACB, U(I) = WORK(UI-1+I) for I=1,...,N. WORK(QRAUXI) is the first element of the NP vector, QRAUX, required to recover the QR decomposition of FJACB, QRAUX(I) = WORK(QRAUXI-1+I) for I=1,...,NP. WORK(WRK1I) is the first element of the N by M matrix, WRK1, required for work space, WRK1(I,J) = WORK(WRK1I-1+I+(J-1)*N) for I=1,...,N & J=1,...,M. (*) WORK(SEI) is the first element of the NP vector containing the standard errors of the function parameters BETA, i.e., the square roots of the diagonal entries of the covariance matrix stored in WORK(VCVI) for the unfixed parameters and zero for the fixed parameters, SE(I) = WORK(SEI-1+I) for I=1,...,NP. The standard errors are only computed when the third digit of JOB is zero, and when the solution is full rank. Note that the covariance matrix used to compute the standard errors is an approximation based on a linearization of the model in the neighborhood of the solution. The validity of the approximation depends on the nonlinearity of the model, the variance and distribution of the errors, and the data itself. Confidence intervals computed using the covariance matrix are often acceptable, but can be very inaccurate in some cases. When reliable confidence intervals and regions are required, other more accurate, but more computationally expensive methods of constructing them should be used. (See, e.g., Boggs and Donaldson [1989], Donaldson and Schnabel [1987], Efron [1985], and Fuller [1987].) (*) WORK(RCONDI) is the reciprocal of the condition number at the time the computations stopped. (*) WORK(ETAI) is the value of the relative error in the model function value. WORK(ACTRSI) is the saved actual relative reduction in the weighted sum of squares of the observation errors from the last iteration. WORK(PNROMI) is the norm of the scaled estimated parameters from the last iteration. WORK(PRERSI) is the saved predicted relative reduction in the weighted sum of the squares of the observation errors from the last iteration. WORK(RNORSI) is the norm of the saved weighted observation errors from the last iteration. 1 X.B Extracting Information from Vector IWORK Upon return from a call to ODRPACK, array IWORK contains various values, some of which may be of interest to the user. To extract information from IWORK, the following declaration statement must be added to the user's program INTEGER + MSGB,MSGX,JPVTI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN where MSGB through LDTTI are variables that indicate the starting locations within IWORK of the stored values, and LIWKMN is the minimum acceptable length of array IWORK. The appropriate values of MSGB through LDTTI are obtained by invoking subroutine SIWINF when using either of the single precision ODRPACK subroutines, SODR or SODRC, and by invoking DIWINF when using either of the double precision subroutines, DODR or DODRC. The call statements for SIWINF and DIWINF have the same argument lists. To invoke either subroutine, use CALL + (M,NP, + MSGB,MSGX,JPVTI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) where SIWINF should be substituted for when using single precision subroutines SODR and SODRC, and DIWINF should be substituted for when using double precision subroutines DODR and DODRC. Note that the values of M and NP must be input to SIWINF and DIWINF with exactly the same values as were used in the original call to ODRPACK. (If possible, users should extract these declaration and call statements from online ODRPACK documentation to avoid typographical errors.) In the following descriptions of the information returned in IWORK, (*) indicates values that are likely to be of greatest interest. (*) IWORK(MSGB) is the first element of the NP+1 vector, MSGB, used to indicate the results of checking the partial derivatives with respect to BETA. The value of IWORK(MSGB) summarizes the results over all of the BETAs. If IWORK(MSGB) < 0, the partial derivatives with respect to each of the BETAs were not checked. If IWORK(MSGB) = 0, the partial derivatives with respect to each of the BETAs appear to be correct. If IWORK(MSGB) = 1, the partial derivative with respect to at least one of the BETAs appears to be incorrect. If IWORK(MSGB) = 2, the partial derivative with respect to at least one of the BETAs is questionable. The value of IWORK(MSGB+K), K=1,...,NP, indicates the individual results for the partial derivative with respect to BETA(K), K=1,...,NP. If IWORK(MSGB+K) = 0, the partial derivative with respect to BETA(K) appears to be correct. If IWORK(MSGB+K) = 1, the partial derivative with respect to BETA(K) appears to be incorrect, i.e., the user supplied derivative and the finite difference value it is checked against do not agree to within the required tolerance and there is no reason to question the results. If IWORK(MSGB+K) = 2, the partial derivative with respect to BETA(K) appears to be questionable because the user supplied derivative and the finite difference value it is checked against are both zero. If IWORK(MSGB+K) = 3, the partial derivative with respect to BETA(K) appears to be questionable because the user supplied derivative is exactly zero and the finite difference value it is checked against is only approximately zero. If IWORK(MSGB+K) = 4, the partial derivative with respect to BETA(K) appears to be questionable because the user supplied derivative is exactly zero and the finite difference value it is checked against is not even approximately zero. If IWORK(MSGB+K) = 5, the partial derivative with respect to BETA(K) appears to be questionable because the finite difference value it is being checked against is questionable due to a high ratio of relative curvature to relative slope or to an incorrect scale value. If IWORK(MSGB+K) = 6, the partial derivative with respect to BETA(K) appears to be questionable because the finite difference value it is being checked against is questionable due to a high ratio of relative curvature to relative slope. (*) IWORK(MSGX) is the first element of the M+1 vector, MSGX, used to indicate the results of checking the partial derivatives with respect to X. The value of IWORK(MSGX) summarizes the results over all of the Xs. If IWORK(MSGX) < 0, the partial derivatives with respect to each of the Xs were not checked. If IWORK(MSGX) = 0, the partial derivatives with respect to each of the Xs appear to be correct. If IWORK(MSGX) = 1, the partial derivative with respect to at least one of the Xs appears to be incorrect. If IWORK(MSGX) = 2, the partial derivative with respect to at least one of the Xs is questionable. The value of IWORK(MSGX+J), J=1,...,M, indicates the individual results for the partial derivative with respect to the Jth column of X, J=1,...,M. If IWORK(MSGX+J) = 0, the partial derivative with respect to the Jth column of X appears to be correct. If IWORK(MSGX+J) = 1, the partial derivative with respect to the Jth column of X to be incorrect, i.e., the user supplied derivative and the finite difference value it is checked against do not agree to within the required tolerance and there is no reason to question the results. If IWORK(MSGX+J) = 2, the partial derivative with respect to the Jth column of X appears to be questionable because the user supplied derivative and the finite difference value it is checked against are both zero. If IWORK(MSGX+J) = 3, the partial derivative with respect to the Jth column of X appears to be questionable because the user supplied derivative is exactly zero and the finite difference value it is checked against is only approximately zero. If IWORK(MSGX+J) = 4, the partial derivative with respect to the Jth column of X appears to be questionable because the user supplied derivative is exactly zero and the finite difference value it is checked against is not even approximately zero. If IWORK(MSGX+J) = 5, the partial derivative with respect to the Jth column of X appears to be questionable because the finite difference value it is being checked against is questionable due to a high ratio of relative curvature to relative slope or to an incorrect scale value. If IWORK(MSGX+J) = 6, the partial derivative with respect to the Jth column of X appears to be questionable because the finite difference value it is being checked against is questionable due to a high ratio of relative curvature to relative slope. IWORK(JPVTI) is the first element of the NP vector, JPVT, containing the pivot vector, JPVT(I) = WORK(JPVTI-1+I) for I=1,...,NP. IWORK(NNZWI) is the number of nonzero observation error weights. IWORK(NPPI) is the number of function parameters actually being estimated. (*) IWORK(IDFI) is the degrees of freedom of the fit, equal to the number of observations with nonzero weighted derivatives with respect to either BETA or DELTA minus the number of parameters being estimated. IWORK(JOBI) is the value used to specify problem initialization and computational methods. IWORK(IPRINI) is the print control value used. IWORK(LUNERI) is the logical unit number used for error reports. IWORK(LUNRPI) is the logical unit number used for computation reports. IWORK(NROWI) is the number of the row at which the derivative is to be checked. IWORK(NTOLI) is the number of digits of agreement required between the numerical derivatives and the user supplied derivatives. (*) IWORK(NETAI) is the number of good digits in the model function results for the first row of the data not containing zero. IWORK(MAXITI) is the maximum number of iterations allowed. (*) IWORK(NITERI) is the number of iterations taken. (*) IWORK(NFEVI) is the number of function evaluations made. (*) IWORK(NJEVI) is the number of Jacobian matrix evaluations made. IWORK(INT2I) is the number of internal doubling steps taken at the time the computations stopped. (*) IWORK(IRANKI) is the rank deficiency at the solution. IWORK(LDTTI) is the leading dimension of the work array TT. 1 XI. ACKNOWLEDGMENTS --------------- The ODRPACK code was developed at the National Institute of Standards and Technology (formerly the National Bureau of Standards). The subroutine that supplies the value of machine precision was modeled after subroutines R1MACH and D1MACH from the Bell Laboratories "Framework for a Portable Library" [Fox et al., 1978]. We also use subroutines from LINPACK [Dongarra et al., 1979] and from the "Basic Linear Algebra Subprograms for Fortran Usage (BLAS)" [Lawson et al., 1979]. The code that checks user supplied derivatives was adapted from STARPAC [Donaldson and Tryon, 1986] using algorithms developed by Schnabel [1982]. 1 XII. REFERENCES ---------- Boggs, P. T., R. H. Byrd, J. R. Donaldson and R. B. Schnabel (1987a), "ODRPACK -- Software for Weighted Orthogonal Distance Regression," University of Colorado Department of Computer Science Technical Report Number CU-CS-360-87. (To appear in ACM Trans. Math. Software.) Boggs, P. T., R. H. Byrd, and R. B. Schnabel (1987b), "A stable and efficient algorithm for nonlinear orthogonal distance regression," SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. Boggs, P. T., and J. R. Donaldson (1989), "The Computation and Use of the Asymptotic Covariance Matrix for Measurement Error Models," National Institute of Standards and Technology Internal Report 89-4102. Dennis, J. E., and R. B. Schnabel (1983), NUMERICAL METHODS FOR UNCONSTRAINED OPTIMIZATION AND NONLINEAR EQUATIONS, Prentice-Hall, Englewood Cliffs, NJ. Donaldson, J. R., and R. B. Schnabel (1987), "Computational Experience with Confidence Regions and Confidence Intervals for Nonlinear Least Squares," TECHNOMETRICS, 29(1):67-82. Donaldson, J. R., and P. V. Tryon (1986), "STARPAC - the standards time series and regression package," National Bureau of Standards (U.S.) Interim Report 86-3448. Dongarra, J. J., C. B. Moler, J. R. Bunch, and G. W. Stewart (1979), LINPACK USERS' GUIDE, SIAM, Philadelphia, PA. Draper, N. R., and H. Smith (1981), APPLIED REGRESSION ANALYSIS, Second Edition, John Wiley and Sons, New York, NY. Efron, B. (1985), "The Jackknife, the Bootstrap and Other Resampling Plans," Monograph 38 (CBMS-NFS), SIAM, Philadelphia, PA. Fox, P. A., A. D. Hall and N. L. Schryer (1978), "Algorithm 528: framework for a portable library [z]," ACM TRANS. MATH. SOFTWARE, 4(2):177-188. Fuller, W. A. (1987), MEASUREMENT ERROR MODELS, John Wiley and Sons, New York, NY. Gill, P. E., W. Murray and M. H. Wright (1981), PRACTICAL OPTIMIZATION, Academic Press, New York, NY. Himmelblau, D. M. (1970), PROCESS ANALYSIS BY STATISTICAL METHODS, John Wiley and Sons, New York, NY. 1 Lawson, C., R. Hanson, D. Kincaid, and F. Krogh (1979), "Basic linear algebra subprograms for fortran usage", ACM TRANS. MATH. SOFTWARE, 5(3):308-371. Schnabel, R. B. (1982), "Finite difference derivatives - theory and practice", (unpublished, available from author). PROGRAM SAMPLE * C SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER C WHERE MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED C MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE C INDEPENDENT VARIABLE ALLOWED C MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS C ALLOWED C LDX IS THE LEADING DIMENSION OF ARRAY X C LDWD IS THE LEADING DIMENSION OF ARRAY WD C LWORK IS THE DIMENSION OF VECTOR WORK C LIWORK IS THE DIMENSION OF VECTOR IWORK * C...PARAMETERS INTEGER + MAXN,MAXM,MAXNP,LDX,LDWD,LWORK,LIWORK PARAMETER + (MAXN=15, + MAXM=5, + MAXNP=5, + LDX=MAXN, + LDWD=1, + LWORK = 17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP, + LIWORK = 19 + 2*MAXNP + MAXM) * C DECLARE USER-SUPPLIED SUBROUTINES AND C ALL OTHER NECESSARY VARIABLES AND ARRAYS * C...LOCAL SCALARS INTEGER + I,INFO,IPRINT,J,JOB,LUNERR,LUNRPT,M,N,NP * C...LOCAL ARRAYS DOUBLE PRECISION + BETA(MAXNP),WD(LDWD,MAXM),WORK(LWORK), + X(LDX,MAXM),Y(LDX) INTEGER + IWORK(LIWORK) * C...EXTERNAL SUBROUTINES EXTERNAL + DODR,FUN,JAC * * OPEN(UNIT=5,FILE='DATA1') OPEN(UNIT=6,FILE='REPORT') * C READ NUMBER OF OBSERVATIONS C NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE C NUMBER OF PARAMETERS C OBSERVED VALUES OF INDEPENDENT AND DEPENDENT VARIABLES C STARTING VALUES OF FUNCTION PARAMETERS * READ (5,*) N,M,NP READ (5,*) ((X(I,J),I=1,N),J=1,M) READ (5,*) (Y(I),I=1,N) READ (5,*) (BETA(I),I=1,NP) * C SPECIFY DELTA WEIGHTS * WD(1,1) = 3.0D0 WD(1,2) = 5.0D0 * C SET CONTROL VALUES TO INVOKE DEFAULT SETTING * JOB = -1 IPRINT = -1 LUNERR = -1 LUNRPT = -1 * C COMPUTE ODR SOLUTION USING FINITE-DIFFERENCE DERIVATIVES * CALL DODR + (FUN,JAC, + N,M,NP, + X,LDX, + Y, + BETA, + WD,LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) * END SUBROUTINE FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOPF) * C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) C INTEGER N,NP,M,LDXPD C DOUBLE PRECISION BETA(NP),XPLUSD(LDXPD,M) C OUTPUT ARGUMENTS C DOUBLE PRECISION F(N) C INTEGER ISTOPF * C...SCALAR ARGUMENTS INTEGER + ISTOPF,LDXPD,M,N,NP * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),F(N),XPLUSD(LDXPD,M) * C...LOCAL SCALARS INTEGER + I * C...INTRINSIC FUNCTIONS INTRINSIC + EXP * * DO 10 I = 1, N IF (XPLUSD(I,2).NE.0.0D0) THEN F(I) = EXP(-BETA(1)*XPLUSD(I,1)* + EXP(-BETA(2)* + (1.0D0/XPLUSD(I,2) - 1.0D0/620.0D0))) ELSE ISTOPF = 1 RETURN END IF 10 CONTINUE ISTOPF = 0 * RETURN END PROGRAM SAMPLE * C SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER C WHERE MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED C MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE C INDEPENDENT VARIABLE ALLOWED C MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS C ALLOWED C LDX IS THE LEADING DIMENSION OF ARRAY X C LDSCLD IS THE LEADING DIMENSION OF ARRAY SCLD C LDWD IS THE LEADING DIMENSION OF ARRAY WD C LDIFX IS THE LEADING DIMENSION OF ARRAY IFIXX C LWORK IS THE DIMENSION OF VECTOR WORK C LIWORK IS THE DIMENSION OF VECTOR IWORK * C...PARAMETERS INTEGER + MAXN,MAXM,MAXNP,LDSCLD,LDIFX,LDWD,LWORK,LIWORK PARAMETER C + (MAXN=15, + MAXM=5, + MAXNP=5, + LDSCLD=1, + LDWD=1, + LDIFX=1, + LWORK=17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP, + LIWORK=19 + 2*MAXNP + MAXM) * C DECLARE USER-SUPPLIED SUBROUTINES AND C ALL OTHER NECESSARY VARIABLES AND ARRAYS * C...LOCAL SCALARS DOUBLE PRECISION + PARTOL,SSTOL,TAUFAC INTEGER + I,INFO,IPRINT,J,JOB,LDX,LUNERR,LUNRPT,M,MAXIT,N,NDIGIT,NP * C...LOCAL ARRAYS DOUBLE PRECISION + BETA(MAXNP),WD(LDWD,MAXM),SCLB(MAXNP), + SCLD(LDSCLD,MAXM),W(MAXN),WORK(LWORK),X(MAXN,MAXM),Y(MAXN) INTEGER + IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK) * C...EXTERNAL SUBROUTINES EXTERNAL + DODRC,FUN,JAC * * OPEN(UNIT=5,FILE='DATA1') OPEN(UNIT=6,FILE='REPORT') * C SPECIFY LEADING DIMENSION OF ARRAY X * LDX = MAXN * C READ NUMBER OF OBSERVATIONS C NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE C NUMBER OF PARAMETERS C OBSERVED VALUES OF INDEPENDENT AND DEPENDENT VARIABLES C STARTING VALUES OF FUNCTION PARAMETERS * READ (5,*) N,M,NP READ (5,*) ((X(I,J),I=1,N),J=1,M) READ (5,*) (Y(I),I=1,N) READ (5,*) (BETA(I),I=1,NP) * C FIX SECOND COLUMN OF INDEPENDENT VARIABLE AT OBSERVED VALUES * IFIXX(1,1) = 1 IFIXX(1,2) = 0 * C SPECIFY USE OF DEFAULT SCALING * SCLD(1,1) = -1.0D0 SCLB(1) = -1.0D0 * C INDICATE ALL BETA'S ARE TO BE ESTIMATED * IFIXB(1) = -1 * C SPECIFY WEIGHTS * WD(1,1) = 3.0D0 WD(1,2) = 5.0D0 W(1) = -1.0D0 * C SET CONTROL VALUES AND STOPPING CRITERIA * JOB = 10 NDIGIT = -1 TAUFAC = -1.0D0 SSTOL = -1.0D0 PARTOL = -1.0D0 MAXIT = -1 IPRINT = 1111 LUNERR = -1 LUNRPT = -1 * C COMPUTE ODR SOLUTION USING USER-SUPPLIED ANALYTIC DERIVATIVES * CALL DODRC + (FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) * END SUBROUTINE FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOPF) * C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) * C INTEGER N,NP,M,LDXPD C DOUBLE PRECISION BETA(NP),XPLUSD(LDXPD,M) * C OUTPUT ARGUMENTS * C DOUBLE PRECISION F(N) C INTEGER ISTOPF * C...SCALAR ARGUMENTS INTEGER + ISTOPF,LDXPD,M,N,NP * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),F(N),XPLUSD(LDXPD,M) * C...LOCAL SCALARS INTEGER + I * C...INTRINSIC FUNCTIONS INTRINSIC + EXP * * DO 10 I = 1, N IF (XPLUSD(I,2).NE.0.0D0) THEN F(I) = EXP(-BETA(1)*XPLUSD(I,1)* + EXP(-BETA(2)* + (1.0D0/XPLUSD(I,2) - 1.0D0/620.0D0))) ELSE ISTOPF = 1 RETURN END IF 10 CONTINUE ISTOPF = 0 * RETURN END SUBROUTINE JAC(N,NP,M,BETA,XPLUSD,LDXPD, + FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOPJ) * C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) * C INTEGER N,NP,M,LDXPD C DOUBLE PRECISION BETA(NP),XPLUSD(LDXPD,M) C LOGICAL ISODR * C OUTPUT ARGUMENTS * C DOUBLE PRECISION FJACB(LDFJB,NP),FJACX(LDFJX,M) C INTEGER ISTOPJ * C...SCALAR ARGUMENTS INTEGER + ISTOPJ,LDFJB,LDFJX,LDXPD,M,N,NP LOGICAL + ISODR * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),FJACB(LDFJB,NP),FJACX(LDFJX,M),XPLUSD(LDXPD,M) * C...LOCAL SCALARS DOUBLE PRECISION + FAC1,FAC2,FAC3,FAC4 INTEGER + I * C...INTRINSIC FUNCTIONS INTRINSIC + EXP * * DO 10 I=1,N FAC1 = 1.0D0/XPLUSD(I,2) - 1.0D0/620.0D0 FAC2 = EXP(-BETA(2)*FAC1) FAC3 = BETA(1)*XPLUSD(I,1) FAC4 = EXP(-FAC3*FAC2) * FJACB(I,1) = -FAC4*XPLUSD(I,1)*FAC2 FJACB(I,2) = FAC4*FAC3*FAC2*FAC1 * IF (ISODR) THEN FJACX(I,1) = -FAC4*BETA(1)*FAC2 FJACX(I,2) = -FAC4*FAC3*FAC2*BETA(2)/XPLUSD(I,2)**2 END IF 10 CONTINUE ISTOPJ = 0 * RETURN END *DTEST PROGRAM DTEST C***BEGIN PROLOGUE TEST C***REFER TO DODR,DODRC C***ROUTINES CALLED DODRX C***DATE WRITTEN 861229 (YYMMDD) C***REVISION DATE 890727 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE EXERCISE FEATURES OF ODRPACK SOFTWARE C***END PROLOGUE ODRPACK * C...SCALARS IN COMMON INTEGER + NTEST * C...LOCAL SCALARS DOUBLE PRECISION + TSTFAC INTEGER + LUNERR,LUNRPT,LUNSUM LOGICAL + PASSED * C...EXTERNAL SUBROUTINES EXTERNAL + DODRX * C...COMMON BLOCKS COMMON /TSTSET/ NTEST * C***VARIABLE DECLARATIONS (ALPHABETICALLY) * C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNSUM C THE LOGICAL UNIT NUMBER USED FOR A SUMMARY REPORT THAT LISTS C ONLY THE TEST COMPARISONS AND NOT THE ODRPACK GENERATED C REPORTS. C INTEGER NTEST C THE NUMBER OF TESTS TO BE RUN. C LOGICAL PASSED C THE INDICATOR VALUE USED TO DESIGNATES WHETHER THE RESULTS OF C ALL OF THE TESTS AGREE WITH THOSE FROM THE CDC CYBER 205 USING C DOUBLE PRECISION (PASSED=TRUE), OR WHETHER SOME OF THE RESULTS C DISAGREED (PASSED=FALSE). C DOUBLE PRECISION TSTFAC C THE USER-SUPPLIED FACTOR FOR SCALING THE TEST TOLERANCES USED C TO CHECK FOR AGREEMENT BETWEEN COMPUTED RESULTS AND RESULTS C OBTAINED USING DOUBLE PRECISION VERSION ON CDC CYBER 205. C VALUES OF TSTFAC GREATER THAN ONE INCREASE THE TEST TOLERANCES, C MAKING THE TESTS EASIER TO PASS AND ALLOWING SMALL C DISCREPANCIES BETWEEN THE COMPUTED AND EXPECTED RESULTS TO BE C AUTOMATICALLY DISCOUNTED. * * C***FIRST EXECUTABLE STATEMENT TEST * * C SET UP NECESSARY FILES * C NOTE: ODRPACK GENERATES COMPUTATION AND ERROR REPORTS ON C LOGICAL UNIT 6 BY DEFAULT; C LOGICAL UNIT 'LUNSUM' USED TO SUMMARIZE RESULTS OF COMPARISONS C FROM EXERCISE ROUTINE DODRX. * LUNRPT = 18 LUNERR = 18 LUNSUM = 19 * OPEN(UNIT=LUNRPT,FILE='REPORT') OPEN(UNIT=LUNERR,FILE='REPORT') OPEN(UNIT=LUNSUM,FILE='SUMMARY') * C EXERCISE DOUBLE PRECISION VERSION OF ODRPACK C (TEST REPORTS GENERATED ON FILE 'RESULTS' AND C SUMMARIZED IN FILE 'SUMMARY') * NTEST = 10 TSTFAC = 1.0D0 CALL DODRX(TSTFAC,PASSED,LUNSUM) * END *DODRX SUBROUTINE DODRX + (TSTFAC,PASSED,LUNSUM) C***BEGIN PROLOGUE DODRX C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890727 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE EXERCISE FEATURES OF ODRPACK SOFTWARE C***DESCRIPTION C DODRX SUBPROGRAM ARGUMENTS: C DOUBLE PRECISION TSTFAC C THE USER-SUPPLIED FACTOR FOR SCALING THE TEST TOLERANCES USED C TO CHECK FOR AGREEMENT BETWEEN COMPUTED RESULTS AND RESULTS C OBTAINED USING DOUBLE PRECISION VERSION ON CDC CYBER 205. C VALUES OF TSTFAC GREATER THAN ONE INCREASE THE TEST TOLERANCES, C MAKING THE TESTS EASIER TO PASS AND ALLOWING SMALL C DISCREPANCIES BETWEEN THE COMPUTED AND EXPECTED RESULTS TO BE C AUTOMATICALLY DISCOUNTED. C LOGICAL PASSED C THE INDICATOR VALUE USED TO DESIGNATES WHETHER THE RESULTS OF C ALL OF THE TESTS AGREE WITH THOSE FROM THE CDC CYBER 205 USING C DOUBLE PRECISION (PASSED=TRUE), OR WHETHER SOME OF THE RESULTS C DISAGREED (PASSED=FALSE). C INTEGER LUNSUM C THE LOGICAL UNIT NUMBER USED FOR A SUMMARY REPORT THAT LISTS C ONLY THE TEST COMPARISONS AND NOT THE ODRPACK GENERATED C REPORTS, WHICH ARE WRITTEN TO UNIT 6. C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1987), C "ODRPACK -- SOFTWARE FOR WEIGHTED ORTHOGONAL C DISTANCE REGRESSION," C UNIVERSITY OF COLORADO DEPARTMENT OF COMPUTER SCIENCE C TECHNICAL REPORT NUMBER CU-CS-360-87. C (TO APPEAR IN ACM TRANS. MATH. SOFTWARE.) C BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1989), C "REFERENCE GUIDE FOR ODRPACK SOFTWARE FOR WEIGHTED C ORTHOGONAL DISTANCE REGRESSION," C ONLINE DOCUMENTATION AVAILABLE FROM AUTHORS C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR C ORTHOGONAL DISTANCE REGRESSION," C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. C***ROUTINES CALLED DIWINF,DMPREC,DNRM2,DODR,DODRC,DODRXD, C DODRXF,DODRXJ,DODRXW,DWINF,DZERO, C***END PROLOGUE DODRX * C SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER, WHERE C LIWORK IS THE LENGTH OF THE WORK VECTOR IWORK. C LWORK IS THE LENGTH OF THE WORK VECTOR WORK. C MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED, C MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE C INDEPENDENT VARIABLE ALLOWED, C MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS C ALLOWED, AND C NTESTS IS THE NUMBER OF DIFFERENT TESTS THAT CAN BE RUN. * C...PARAMETERS INTEGER + LIWORK,LWORK,MAXN,MAXM,MAXNP,NTESTS PARAMETER C + (MAXN=50, MAXNP=10, MAXM=3, NTESTS=10, + LWORK = 17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP, + LIWORK = 19 + 2*MAXNP + MAXM) * C...SCALAR ARGUMENTS DOUBLE PRECISION + TSTFAC INTEGER + LUNSUM LOGICAL + PASSED * C...SCALARS IN COMMON INTEGER + NTEST,SETNO * C...LOCAL SCALARS DOUBLE PRECISION + BNRM,EPSMAC,HUNDRD,ONE,P01,P2,PARTOL,RSSQ,SSTOL, + TAUFAC,TSTTOL,TWO,ZERO INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,DDELTI,DELTAI,DELTNI,DELTSI, + EPSI,EPSMAI,ETAI,FJACBI,FJACXI,FNI,FSI,I,IDFI,INFO,INT2I, + IPRINI,IPRINT,IRANKI,ITEST,JOB,JOBI,JPVTI,L,LDIFX,LDSCLD,LDTTI, + LDWD,LDX,LIWKMN,LIWMIN,LUN,LUNERI,LUNERR,LUNRPI,LUNRPT,LWKMN, + LWMIN,M,MAXIT,MAXITI,MSG,MSGB,MSGX,N,NDIGIT,NETAI,NFEVI,NITERI, + NJEVI,NNZWI,NP,NPPI,NROWI,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI, + PRERSI,QRAUXI,RCONDI,RNORSI,RVARI,SEI,SI,SSFI,SSI,SSSI, + SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI,WRK1I,WSSI,WSSDEI,WSSEPI, + XPLUSI,YTI LOGICAL + FAILED,FAILS,SHORT CHARACTER TITLE*80 * C...LOCAL ARRAYS DOUBLE PRECISION + BETA(MAXNP),DP205(2,NTESTS), + SCLB(MAXNP),SCLD(MAXN,MAXM),W(MAXN),WD(MAXN,MAXM),WORK(LWORK), + X(MAXN,MAXM),Y(MAXN) INTEGER + IDP205(NTESTS),IFIXB(MAXNP),IFIXX(MAXN,MAXM),IWORK(LIWORK) * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DMPREC,DNRM2 EXTERNAL + DMPREC,DNRM2 * C...EXTERNAL SUBROUTINES EXTERNAL + DIWINF,DODR,DODRC,DODRXD,DODRXF,DODRXJ,DODRXW,DWINF,DZERO * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MOD * C...COMMON BLOCKS COMMON /SETID/SETNO COMMON /TSTSET/ NTEST * C...DATA STATEMENTS DATA + ZERO,P01,P2,ONE,TWO,HUNDRD + /0.0D0,0.01D0,0.2D0,1.0D0,2.0D0,100.0D0/ * DATA + (DP205(I,1),I=1,2) + /0.276273319578025680897844934084D+05, + 0.753263956902291894369510458488D-03/ DATA + (DP205(I,2),I=1,2) + /0.276273263014367271057285851346D+05, + 0.753846772268713150687427932817D-03/ DATA + (DP205(I,3),I=1,2) + /0.106994410000000002794090519414D+10, + 0.121280859325605635962966065824D-04/ DATA + (DP205(I,4),I=1,2) + /0.106994410000000002662346114304D+10, + 0.545208463379060601757201499747D-06/ DATA + (DP205(I,5),I=1,2) + /0.142698815637725861752157173592D+01, + 0.108472868712743221975390382045D+01/ DATA + (DP205(I,6),I=1,2) + /0.426132182951397887187250887403D+01, + 0.147796721039842073356542433095D-01/ DATA + (DP205(I,7),I=1,2) + /0.426127230714288607663880633106D+01, + 0.147796612546537433680413855128D-01/ DATA + (DP205(I,8),I=1,2) + /0.437148731790976277721640707488D+02, + 0.114441947440828606711224215902D-02/ DATA + (DP205(I,9),I=1,2) + /0.395094925302768220710923336357D+02, + 0.665183875083491081963688151467D+02/ DATA + (DP205(I,10),I=1,2) + /0.395094925302768220710923336357D+02, + 0.665183875083491081963688151467D+02/ * DATA + (IDP205(I),I=1,10) + /1,1,1,1,101,4,1,1,1023,40100/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL DODRXF C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL DODRXJ C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER ACTRSI C THE LOCATION IN ARRAY WORK OF C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER ALPHAI C THE LOCATION IN ARRAY WORK OF C THE LEVENBERG-MARQUARDT PARAMETER. C DOUBLE PRECISION BETA(MAXNP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER BETACI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETANI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETASI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C DOUBLE PRECISION BNRM C THE NORM OF THE BETA. C INTEGER DDELTI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (W*D)**2 * DELTA. C INTEGER DELTAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C DOUBLE PRECISION DP205(2,NTESTS) C THE FLOATING POINT RESULTS FROM A CDC CYBER 205 USING C DOUBLE PRECISION. C INTEGER EPSI C THE STARTING LOCATION IN ARRAY WORK OF C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C DOUBLE PRECISION EPSMAC C THE VALUE OF MACHINE PRECISION. C INTEGER EPSMAI C THE LOCATION IN ARRAY WORK OF C THE VALUE OF MACHINE PRECISION. C INTEGER ETAI C THE LOCATION IN ARRAY WORK OF C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C LOGICAL FAILED C THE INDICATOR VALUE USED TO DESIGNATE WHETHER THE RESULTS OF C ALL OF THE DEMONSTRATION RUNS AGREED WITH THOSE FROM THE C CDC CYBER 205 USING DOUBLE PRECISION (FAILED=FALSE) OR WHETHER C SOME OF THE TESTS DISAGREED (FAILED=TRUE). C LOGICAL FAILS C THE INDICATOR VALUE USED TO DESIGNATE WHETHER THE RESULTS OF C AN INDIVIDUAL DEMONSTRATION RUN AGREED WITH THOSE FROM THE C CDC CYBER 205 USING DOUBLE PRECISION (FAILS=FALSE) OR DISAGREE C (FAILS=TRUE). C INTEGER FJACBI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO BETA. C INTEGER FJACXI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO X. C INTEGER FNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON. C DOUBLE PRECISION HUNDRD C THE VALUE 100.0D0. C INTEGER I C AN INDEX VARIABLE. C INTEGER IDFI C THE STARTING LOCATION IN ARRAY IWORK OF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IDP205(NTESTS) C THE INTEGER RESULTS FROM A CDC CYBER 205 USING C DOUBLE PRECISION. C INTEGER IFIXB(MAXNP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(MAXN,MAXM) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INT2I C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF INTERNAL DOUBLING STEPS. C INTEGER IPRINI C THE LOCATION IN ARRAY IWORK OF C THE PRINT CONTROL VARIABLE. C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IRANKI C THE LOCATION IN ARRAY IWORK OF C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C INTEGER ITEST C THE NUMBER OF THE CURRENT TEST BEING RUN. C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOBI C THE LOCATION IN ARRAY IWORK OF C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C INTEGER JPVTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE PIVOT VECTOR. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LIWMIN C THE MINIMUM LENGTH OF VECTOR IWORK FOR A GIVEN PROBLEM. C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUN C THE LOGICAL UNIT NUMBER CURRENTLY BEING USED. C INTEGER LUNERI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNSUM C THE LOGICAL UNIT NUMBER USED FOR A SUMMARY REPORT. C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER LWMIN C THE MINIMUM LENGTH OF VECTOR WORK FOR A GIVEN PROBLEM. C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXITI C THE LOCATION IN ARRAY IWORK OF C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MSG C AN INDICATOR VARIABLE USED TO DESIGNATE WHICH MESSAGE IS C TO BE PRINTED AS A RESULT OF THE COMPARISON WITH THE CDC CYBER C 205 RESULTS. C INTEGER MSGB C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NDIGIT C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETAI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITERI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NJEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NNZWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPPI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C INTEGER NROWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTEST C THE NUMBER OF TESTS TO BE RUN. C INTEGER NTESTS C THE NUMBER OF DIFFERENT TESTS AVAILABLE. C INTEGER NTOLI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C TO BE SET BY DJCK. C INTEGER OLMAVI C THE LOCATION IN ARRAY WORK OF C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OMEGAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C LOGICAL PASSED C THE INDICATOR VALUE USED TO DESIGNATES WHETHER THE RESULTS OF C ALL OF THE DEMONSTRATION RUNS AGREED WITH THOSE FROM THE C CDC CYBER 205 USING DOUBLE PRECISION (PASSED=TRUE), OR WHETHER C SOME OF THE RESULTS DISAGREED (PASSED=FALSE). C DOUBLE PRECISION P01 C THE VALUE 0.01D0. C DOUBLE PRECISION P2 C THE VALUE 0.2D0. C INTEGER PARTLI C THE LOCATION IN ARRAY WORK OF C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C DOUBLE PRECISION PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER PNORMI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C INTEGER PRERSI C THE LOCATION IN ARRAY WORK OF C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER QRAUXI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C INTEGER RCONDI C THE LOCATION IN ARRAY WORK OF C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C INTEGER RNORSI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION RSSQ C THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER RVARI C THE LOCATION IN ARRAY WORK OF C THE RESIDUAL VARIANCE. C DOUBLE PRECISION SCLB(MAXNP) C THE SCALE VALUE FOR EACH VALUE OF BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SCLD(MAXN,MAXM) C THE SCALE VALUE FOR EACH VALUE OF DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SEI C THE STARTING LOCATION IN ARRAY WORK OF C THE STANDARD ERRORS FOR THE PARAMETERS, ALSO USED AS A C WORK ARRAY. C INTEGER SETNO C THE NUMBER OF THE DATA SET BEING ANALYZED. C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ODRPACK IS TO C BE INVOKED BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL C (SHORT=.FALSE.). C INTEGER SI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED BETA'S. C INTEGER SSFI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE BETA'S. C INTEGER SSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE ESTIMATED BETA'S. C INTEGER SSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C DOUBLE PRECISION SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SSTOLI C THE LOCATION IN ARRAY WORK OF C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C DOUBLE PRECISION TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER TAUFCI C THE LOCATION IN ARRAY WORK OF C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C INTEGER TAUI C THE LOCATION IN ARRAY WORK OF C THE TRUST REGION DIAMETER. C INTEGER TI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED DELTA'S. C CHARACTER*80 TITLE C THE REFERENCE FOR THE DATA SET BEING ANALYZED. C DOUBLE PRECISION TSTFAC C THE USER-SUPPLIED FACTOR FOR SCALING THE TEST TOLERANCES C USED TO CHECK FOR AGREEMENT BETWEEN COMPUTED RESULTS AND C RESULTS OBTAINED USING DOUBLE PRECISION VERSION ON CDC C CYBER 205. C DOUBLE PRECISION TSTTOL C THE TEST TOLERANCE USED IN CHECKING COMPUTED VALUES FOR C PURPOSES OF DETERMINING PROPER INSTALLATION. C INTEGER TTI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE DELTA'S. C DOUBLE PRECISION TWO C THE VALUE 2.0D0. C INTEGER UI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR TFJACB. C INTEGER VCVI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE VARIANCE COVARIANCE MATRIX, ALSO USED C TO STORE THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C DOUBLE PRECISION W(MAXN) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(MAXN,MAXM) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WORK(LWORK) C THE DOUBLE PRECISION WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER WRK1I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C INTEGER WSSDEI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C INTEGER WSSEPI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C DOUBLE PRECISION X(MAXN,MAXM) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER XPLUSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY X + DELTA. C DOUBLE PRECISION Y(MAXN) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER YTI C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DODRX * * C SET LOGICAL UNITS FOR ERROR AND COMPUTATION REPORTS * LUNERR = 18 LUNRPT = 18 * C INITIALIZE TEST TOLERANCE * IF (TSTFAC.GT.ONE) THEN TSTTOL = TSTFAC ELSE TSTTOL = ONE END IF * C INITIALIZE MACHINE PRECISION * EPSMAC = DMPREC() * C INITIALIZE LEADING DIMENSION OF X * LDX = MAXN * C INITIALIZE MISCELLANEOUS VARIABLES USED IN THE EXERCISE PROCEDURE * FAILED = .FALSE. SHORT = .TRUE. N = 0 * C BEGIN EXERCISING ODRPACK * DO 400 ITEST=1,NTEST * C SET CONTROL VALUES TO INVOKE DEFAULT VALUES * IFIXX(1,1) = -1 LDIFX = MAXN IFIXB(1) = -1 W(1) = -ONE NDIGIT = -1 TAUFAC = -ONE SSTOL = -ONE PARTOL = -ONE MAXIT = -1 IPRINT = 2112 * IF (ITEST.EQ.1) THEN * C TEST SIMPLE ODR PROBLEM WITH ANALYTIC DERIVATIVES USING DODR * LUN = LUNRPT DO 10 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1010) LUN = LUNSUM 10 CONTINUE SETNO = 5 CALL DODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL DZERO(LWORK,1,WORK,LWORK) JOB = 00010 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = 1 SHORT = .TRUE. ELSE IF (ITEST.EQ.2) THEN * C TEST SIMPLE OLS PROBLEM WITH FINITE DIFFERENCE DERIVATIVES USING DODR * LUN = LUNRPT DO 20 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1020) LUN = LUNSUM 20 CONTINUE SETNO = 5 CALL DODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL DZERO(LWORK,1,WORK,LWORK) JOB = 00001 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = 1 SHORT = .TRUE. ELSE IF (ITEST.EQ.3) THEN * C TEST PARAMETER FIXING CAPABILITIES FOR POORLY SCALED OLS PROBLEM C WITH ANALYTIC DERIVATIVES USING DODRC. * LUN = LUNRPT DO 30 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1030) LUN = LUNSUM 30 CONTINUE SETNO = 3 CALL DODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL DZERO(LWORK,1,WORK,LWORK) JOB = 00031 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = 1 SHORT = .FALSE. IFIXB(1) = 1 IFIXB(2) = 1 IFIXB(3) = 1 IFIXB(4) = 0 IFIXB(5) = 1 IFIXB(6) = 0 IFIXB(7) = 0 IFIXB(8) = 0 IFIXB(9) = 0 ELSE IF (ITEST.EQ.4) THEN * C TEST WEIGHTING CAPABILITIES FOR ODR PROBLEM WITH C ANALYTIC DERIVATIVES USING DODRC. C ALSO SHOWS SOLUTION OF POORLY SCALED ODR PROBLEM C (DERIVATIVE CHECKING TURNED OFF) * LUN = LUNRPT DO 40 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1040) LUN = LUNSUM 40 CONTINUE SETNO = 3 CALL DZERO(LWORK,1,WORK,LWORK) JOB = 00020 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE DO 45 I=1,N WD(I,1) = P01/ABS(X(I,1)) W(I) = ONE 45 CONTINUE LDWD = N W(28) = ZERO SHORT = .FALSE. IFIXB(1) = 1 IFIXB(2) = 1 IFIXB(3) = 1 IFIXB(4) = 0 IFIXB(5) = 1 IFIXB(6) = 1 IFIXB(7) = 1 IFIXB(8) = 0 IFIXB(9) = 0 IPRINT = 2232 ELSE IF (ITEST.EQ.5) THEN * C TEST DELTA INITIALIZATION CAPABILITIES AND USER-SUPPLIED SCALING C TEST DELTA INITIALIZATION CAPABILITIES C AND USE OF ISTOPF TO RESTRICT PARAMETER VALUES C FOR ODR PROBLEM WITH ANALYTIC DERIVATIVES USING DODRC. * LUN = LUNRPT DO 50 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1050) LUN = LUNSUM 50 CONTINUE SETNO = 1 CALL DODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL DZERO(LWORK,1,WORK,LWORK) JOB = 01010 SCLD(1,1) = TWO LDSCLD = 1 SCLB(1) = P2 SCLB(2) = ONE WD(1,1) = -ONE LDWD = N DO 55 I=20,21 WORK(I) = BETA(1)/Y(I) + BETA(2) - X(I,1) 55 CONTINUE SHORT = .FALSE. ELSE IF (ITEST.EQ.6) THEN * C TEST STIFF STOPPING CONDITIONS FOR UNSCALED ODR PROBLEM C WITH ANALYTIC DERIVATIVES USING DODRC * LUN = LUNRPT DO 60 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1060) LUN = LUNSUM 60 CONTINUE SETNO = 4 CALL DODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL DZERO(LWORK,1,WORK,LWORK) JOB = 00010 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = N SHORT = .FALSE. SSTOL = HUNDRD*EPSMAC PARTOL = EPSMAC MAXIT = 2 ELSE IF (ITEST.EQ.7) THEN * C TEST RESTART FOR UNSCALED ODR PROBLEM C WITH ANALYTIC DERIVATIVES USING DODRC * LUN = LUNRPT DO 70 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1070) LUN = LUNSUM 70 CONTINUE SETNO = 4 JOB = 20210 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = N SHORT = .FALSE. SSTOL = HUNDRD*EPSMAC PARTOL = EPSMAC MAXIT = -1 ELSE IF (ITEST.EQ.8) THEN * C TEST USE OF TAUFAC TO RESTRICT FIRST STEP C FOR ODR PROBLEM WITH FINITE DIFFERENCE DERIVATIVES USING DODRC. * LUN = LUNRPT DO 80 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1080) LUN = LUNSUM 80 CONTINUE SETNO = 6 CALL DODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL DZERO(LWORK,1,WORK,LWORK) JOB = 00200 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = N SHORT = .FALSE. TAUFAC = P01 ELSE IF (ITEST.EQ.9) THEN * C TEST DETECTION OF INCORRECT DERIVATIVES * LUN = LUNRPT DO 90 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1090) LUN = LUNSUM 90 CONTINUE SETNO = 6 CALL DODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL DZERO(LWORK,1,WORK,LWORK) JOB = 00011 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = N SHORT = .FALSE. ELSE IF (ITEST.EQ.10) THEN * C TEST DETECTION OF INCORRECT DERIVATIVES * LUN = LUNRPT DO 100 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1100) LUN = LUNSUM 100 CONTINUE SETNO = 6 CALL DODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL DZERO(LWORK,1,WORK,LWORK) JOB = 00010 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = N SHORT = .FALSE. END IF * CALL DIWINF + (M,NP, + MSGB,MSGX,JPVTI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) CALL DWINF + (N,M,NP, + DELTAI,EPSI, + WSSI,WSSDEI,WSSEPI,RVARI, + PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI, + FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,DELTSI, + DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,TAUI, + ALPHAI,VCVI,OMEGAI,YTI,UI,QRAUXI,WRK1I,SEI,RCONDI, + ETAI,ACTRSI,PNORMI,PRERSI,RNORSI, + LWKMN) CALL DODRXW + (N,M,NP,LIWMIN,LWMIN) * C COMPUTE OLS SOLUTION USING ODRPAK WITH F.D. DERIVATIVES * WRITE (LUNRPT,2200) TITLE WRITE (LUNSUM,2200) TITLE IF (SHORT) THEN CALL DODR + (DODRXF,DODRXJ, + N,M,NP, + X,LDX, + Y, + BETA, + WD,LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + WORK,LWMIN,IWORK,LIWMIN, + INFO) ELSE CALL DODRC + (DODRXF,DODRXJ, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWMIN,IWORK,LIWMIN, + INFO) END IF * C COMPARE RESULTS WITH THOSE OBTAINED ON THE CDC CYBER 205 C USING DOUBLE PRECISION VERSION OF ODRPACK * BNRM = DNRM2(NP,BETA,1) RSSQ = WORK(WSSI) * IF (IDP205(ITEST).EQ.INFO) THEN * C STOPPING CONDITIONS AGREE * IF (INFO.GE.10000) THEN FAILS = .FALSE. MSG = 1 * ELSE IF (MOD(INFO,10).EQ.1) THEN FAILS = ABS(RSSQ-DP205(2,ITEST)).GT. + DP205(2,ITEST)*WORK(SSTOLI)*TSTTOL MSG = 2 * ELSE IF (MOD(INFO,10).EQ.2) THEN FAILS = ABS(BNRM-DP205(1,ITEST)).GT. + DP205(1,ITEST)*WORK(PARTLI)*TSTTOL MSG = 2 * ELSE IF (MOD(INFO,10).EQ.3) THEN FAILS = (ABS(RSSQ-DP205(2,ITEST)).GT. + DP205(2,ITEST)*WORK(SSTOLI)*TSTTOL) + .AND. + (ABS(BNRM-DP205(1,ITEST)).GT. + DP205(1,ITEST)*WORK(PARTLI)*TSTTOL) MSG = 2 * ELSE IF (MOD(INFO,10).EQ.4) THEN FAILS = .FALSE. MSG = 1 * ELSE FAILS = .TRUE. MSG = 4 END IF END IF * ELSE IF (INFO.GE.10000) THEN FAILS = .TRUE. MSG = 3 * ELSE IF (MOD(INFO,10).EQ.1) THEN FAILS = ABS(RSSQ-DP205(2,ITEST)).GT. + DP205(2,ITEST)*WORK(SSTOLI)*TSTTOL MSG = 2 * ELSE IF (MOD(INFO,10).EQ.2) THEN FAILS = ABS(BNRM-DP205(1,ITEST)).GT. + DP205(1,ITEST)*WORK(PARTLI)*TSTTOL MSG = 2 * ELSE IF (MOD(INFO,10).EQ.3) THEN FAILS = (ABS(RSSQ-DP205(2,ITEST)).GT. + DP205(2,ITEST)*WORK(SSTOLI)*TSTTOL) + .AND. + (ABS(BNRM-DP205(1,ITEST)).GT. + DP205(1,ITEST)*WORK(PARTLI)*TSTTOL) MSG = 2 * ELSE FAILS = .TRUE. MSG = 3 END IF END IF END IF * FAILED = FAILED .OR. FAILS * LUN = LUNRPT DO 300 L=1,2 WRITE (LUN,3100) WRITE (LUN,3210) ' CDC CYBER 205 RESULT = ', + DP205(1,ITEST),DP205(2,ITEST),IDP205(ITEST) WRITE (LUN,3210) ' NEW TEST RESULT = ', + BNRM,RSSQ,INFO WRITE (LUN,3210) ' DIFFERENCE = ', + ABS(DP205(1,ITEST)-BNRM),ABS(DP205(2,ITEST)-RSSQ), + ABS(IDP205(ITEST)-INFO) * IF (MSG.EQ.1) THEN WRITE (LUN,3310) ELSE IF (MSG.EQ.2) THEN IF (FAILS) THEN WRITE (LUN,3320) ELSE WRITE (LUN,3330) END IF ELSE IF (MSG.EQ.3) THEN WRITE (LUN,3340) ELSE IF (MSG.EQ.4) THEN WRITE (LUN,3350) END IF * LUN = LUNSUM 300 CONTINUE 400 CONTINUE * IF (FAILED) THEN WRITE (LUNSUM,4100) PASSED = .FALSE. ELSE WRITE (LUNSUM,4200) PASSED = .TRUE. END IF * C FORMAT STATEMENTS * 1000 FORMAT('1EXAMPLE ', I2/) 1010 FORMAT(' TEST SIMPLE ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING DODR.') 1020 FORMAT(' TEST SIMPLE OLS PROBLEM'/ + ' WITH FINITE DIFFERENCE DERIVATIVES', + ' USING DODR.') 1030 FORMAT(' TEST PARAMETER FIXING CAPABILITIES', + ' FOR POORLY SCALED OLS PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING DODRC.') 1040 FORMAT(' TEST WEIGHTING CAPABILITIES', + ' FOR ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING DODRC. '/ + ' ALSO SHOWS SOLUTION OF POORLY SCALED', + ' ODR PROBLEM.'/ + ' (DERIVATIVE CHECKING TURNED OFF.)') 1050 FORMAT(' TEST DELTA INITIALIZATION CAPABILITIES'/ + ' AND USE OF ISTOPF TO RESTRICT PARAMETER VALUES', + ' FOR ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING DODRC.') 1060 FORMAT(' TEST STIFF STOPPING CONDITIONS', + ' FOR UNSCALED ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING DODRC.') 1070 FORMAT(' TEST RESTART', + ' FOR UNSCALED ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING DODRC.') 1080 FORMAT(' TEST USE OF TAUFAC TO RESTRICT FIRST STEP', + ' FOR ODR PROBLEM'/ + ' WITH FINITE DIFFERENCE DERIVATIVES', + ' USING DODRC.') 1090 FORMAT(' TEST DETECTION OF QUESTIONABLE ANALYTIC DERIVATIVES', + ' FOR OLS PROBLEM'/ + ' USING DODRC.') 1100 FORMAT(' TEST DETECTION OF INCORRECT ANALYTIC DERIVATIVES', + ' FOR ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING DODRC.') 2200 FORMAT (' DATA SET REFERENCE: ', A80) 3100 FORMAT + (//' *** COMPARISON OF NEW RESULTS WITH', + ' DOUBLE PRECISION CDC CYBER 205 RESULT ***'// + ' NORM OF BETA', + ' SUM OF SQUARED WTD OBS ERRORS INFO') 3210 FORMAT + (/A25/2D37.30,I6) 3310 FORMAT + (///' NEW STOPPING CONDITION AND EXPECTED STOPPING CONDITION', + ' AGREE,'/ + ' BUT INDICATE CONVERGENCE WAS NOT ATTAINED.'/ + ' NO FURTHER COMPARISONS WILL BE MADE BETWEEN NEW AND', + ' EXPECTED RESULTS.') 3320 FORMAT + (///' *** WARNING ***'// + ' NEW RESULTS AND EXPECTED RESULTS DO NOT', + ' AGREE TO WITHIN STOPPING TOLERANCE'/ + ' OF NEW RESULT.') 3330 FORMAT + (///' NEW RESULTS AND EXPECTED RESULTS', + ' AGREE TO WITHIN STOPPING TOLERANCE'/ + ' OF NEW RESULTS.') 3340 FORMAT + (///' *** WARNING ***'// + ' NEW STOPPING CONDITION AND EXPECTED STOPPING CONDITION', + ' DO NOT AGREE.'/ + ' NO FURTHER COMPARISONS WILL BE MADE BETWEEN NEW AND', + ' EXPECTED RESULTS.') 3350 FORMAT + (///' *** WARNING ***'// + ' UNEXPECTED STOPPING CONDITION.'/ + ' PLEASE CONTACT PACKAGE AUTHORS.') 4100 FORMAT + (/// + '1*** WARNING ***'// + ' RESULTS FROM ONE OR MORE OF THE TESTS DO NOT', + ' AGREE WITH THE EXPECTED RESULTS'/ + ' (OBTAINED USING DOUBLE PRECISION VERSION OF ODRPACK', + ' RUN ON CDC CYBER 205).'/ + ' INSTALLATION OF ODRPACK SHOULD NOT BE CONSIDERED', + ' SUCCESSFUL'/ + ' UNLESS FURTHER EXAMINATION OF THE RESULTS FINDS', + ' THE DISCREPANCY TO BE INSIGNIFICANT.') 4200 FORMAT + (/// + '1RESULTS FROM ALL OF THE TESTS', + ' AGREE WITH THE EXPECTED RESULTS'/ + ' (OBTAINED USING DOUBLE PRECISION VERSION OF ODRPACK', + ' RUN ON CDC CYBER 205).'/ + ' INSTALLATION OF ODRPACK CAN BE CONSIDERED SUCCESSFUL.') * END *DODRXD SUBROUTINE DODRXD + (TITLE,N,M,NP,X,LDX,Y,BETA) C***BEGIN PROLOGUE DODRXD C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SET UP DATA FOR ODRPACK EXERCISER C***END PROLOGUE DODRXD * C SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER, WHERE C MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED, C MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE C INDEPENDENT VARIABLE ALLOWED, C MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS C ALLOWED, AND C MAXSET IS THE NUMBER OF DIFFERENT DATA SETS AVAILABLE. * C...PARAMETERS INTEGER + MAXN,MAXM,MAXNP,MAXSET PARAMETER + (MAXN=50,MAXNP=10,MAXM=3,MAXSET=10) * C...SCALAR ARGUMENTS INTEGER + LDX,M,N,NP CHARACTER TITLE*80 * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(*),X(LDX,*),Y(*) * C...SCALARS IN COMMON INTEGER + SETNO * C...LOCAL SCALARS INTEGER + I,J,K * C...LOCAL ARRAYS DOUBLE PRECISION + BDATA(MAXNP,MAXSET),XDATA(MAXN,MAXM,MAXSET), + YDATA(MAXN,MAXSET) INTEGER + MDATA(MAXSET),NDATA(MAXSET),NPDATA(MAXSET) CHARACTER TDATA(MAXSET)*80 * C...COMMON BLOCKS COMMON /SETID/SETNO * C...DATA STATEMENTS DATA + TDATA(1) + /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 1'/ DATA + NDATA(1),MDATA(1),NPDATA(1) + /40,1,2/ DATA + (BDATA(K,1),K=1,2) + /1.0D+0,1.0D+0/ DATA + YDATA(1,1),XDATA(1,1,1) + /-0.119569795672791172D+1,-0.213701920211315155D-1/ DATA + YDATA(2,1),XDATA(2,1,1) + /-0.128023349509594288D+1,0.494813247025012969D-1/ DATA + YDATA(3,1),XDATA(3,1,1) + /-0.125270693343174591D+1,0.127889194935560226D+0/ DATA + YDATA(4,1),XDATA(4,1,1) + /-0.996698267935287383D+0,0.128615394085645676D+0/ DATA + YDATA(5,1),XDATA(5,1,1) + /-0.104681033065801934D+1,0.232544285655021667D+0/ DATA + YDATA(6,1),XDATA(6,1,1) + /-0.146724952092847308D+1,0.268151108026504516D+0/ DATA + YDATA(7,1),XDATA(7,1,1) + /-0.123366891873487528D+1,0.309041029810905456D+0/ DATA + YDATA(8,1),XDATA(8,1,1) + /-0.165665097907185554D+1,0.405991539210081099D+0/ DATA + YDATA(9,1),XDATA(9,1,1) + /-0.168476460930907119D+1,0.376611424833536147D+0/ DATA + YDATA(10,1),XDATA(10,1,1) + /-0.198571971169224491D+1,0.475875890851020811D+0/ DATA + YDATA(11,1),XDATA(11,1,1) + /-0.195691696638051344D+1,0.499246935397386550D+0/ DATA + YDATA(12,1),XDATA(12,1,1) + /-0.211871342665769836D+1,0.536615037024021147D+0/ DATA + YDATA(13,1),XDATA(13,1,1) + /-0.268642932558671020D+1,0.581830765902996060D+0/ DATA + YDATA(14,1),XDATA(14,1,1) + /-0.281123260058024347D+1,0.684512710422277446D+0/ DATA + YDATA(15,1),XDATA(15,1,1) + /-0.328704486581785920D+1,0.660219819694757458D+0/ DATA + YDATA(16,1),XDATA(16,1,1) + /-0.423062993461887032D+1,0.766990323960781092D+0/ DATA + YDATA(17,1),XDATA(17,1,1) + /-0.512043906552226903D+1,0.808270426690578456D+0/ DATA + YDATA(18,1),XDATA(18,1,1) + /-0.731032616379005535D+1,0.897410020083189004D+0/ DATA + YDATA(19,1),XDATA(19,1,1) + /-0.109002759485608993D+2,0.959199774116277687D+0/ DATA + YDATA(20,1),XDATA(20,1,1) + /-0.251810238510370206D+2,0.914675474762916558D+0/ DATA + YDATA(21,1),XDATA(21,1,1) + /0.100123028650879944D+3,0.997759691476821892D+0/ DATA + YDATA(22,1),XDATA(22,1,1) + /0.168225085871915048D+2,0.107136870384216308D+1/ DATA + YDATA(23,1),XDATA(23,1,1) + /0.894830510866913009D+1,0.108033321037888526D+1/ DATA + YDATA(24,1),XDATA(24,1,1) + /0.645853815227747004D+1,0.116064198672771453D+1/ DATA + YDATA(25,1),XDATA(25,1,1) + /0.498218564760117328D+1,0.119080889359116553D+1/ DATA + YDATA(26,1),XDATA(26,1,1) + /0.382971664718710476D+1,0.129418875187635420D+1/ DATA + YDATA(27,1),XDATA(27,1,1) + /0.344116492497344184D+1,0.135594148099422453D+1/ DATA + YDATA(28,1),XDATA(28,1,1) + /0.276840496973858949D+1,0.135302808716893195D+1/ DATA + YDATA(29,1),XDATA(29,1,1) + /0.259521665196956666D+1,0.137994666010141371D+1/ DATA + YDATA(30,1),XDATA(30,1,1) + /0.205996022794557661D+1,0.147630019545555113D+1/ DATA + YDATA(31,1),XDATA(31,1,1) + /0.197939614345337836D+1,0.153450708076357840D+1/ DATA + YDATA(32,1),XDATA(32,1,1) + /0.156739340562905589D+1,0.152805351451039313D+1/ DATA + YDATA(33,1),XDATA(33,1,1) + /0.159032057073028366D+1,0.157147316247224806D+1/ DATA + YDATA(34,1),XDATA(34,1,1) + /0.173102268158937949D+1,0.166649596005678175D+1/ DATA + YDATA(35,1),XDATA(35,1,1) + /0.155512561664824758D+1,0.166505665838718412D+1/ DATA + YDATA(36,1),XDATA(36,1,1) + /0.149635994944133260D+1,0.175214128553867338D+1/ DATA + YDATA(37,1),XDATA(37,1,1) + /0.147487601463073568D+1,0.180567992463707922D+1/ DATA + YDATA(38,1),XDATA(38,1,1) + /0.117244575233306998D+1,0.184624404296278952D+1/ DATA + YDATA(39,1),XDATA(39,1,1) + /0.910931336069172580D+0,0.195568727388978002D+1/ DATA + YDATA(40,1),XDATA(40,1,1) + /0.126172980914513272D+1,0.199326394036412237D+1/ DATA + TDATA(2) + /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 2'/ DATA + NDATA(2),MDATA(2),NPDATA(2) + /50,2,3/ DATA + (BDATA(K,2),K=1,3) + /-1.0D+0,1.0D+0,1.0D+0/ DATA + YDATA(1,2),XDATA(1,1,2),XDATA(1,2,2) + /0.680832777217942900D+0, + 0.625474598833994800D-1,0.110179064209783100D+0/ DATA + YDATA(2,2),XDATA(2,1,2),XDATA(2,2,2) + /0.122183594595302200D+1, + 0.202500343620642400D+0,-0.196140862891327600D-1/ DATA + YDATA(3,2),XDATA(3,1,2),XDATA(3,2,2) + /0.118958678734608200D+1, + 0.164943738599876500D+0,0.166514874750996600D+0/ DATA + YDATA(4,2),XDATA(4,1,2),XDATA(4,2,2) + /0.146982623764094600D+1, + 0.304874137610506100D+0,0.612908688041490500D-2/ DATA + YDATA(5,2),XDATA(5,1,2),XDATA(5,2,2) + /0.167775338189355300D+1, + 0.532727445580665100D+0,0.938248787552444600D-1/ DATA + YDATA(6,2),XDATA(6,1,2),XDATA(6,2,2) + /0.202485721906026200D+1, + 0.508823707598910200D+0,0.499605775020505400D-2/ DATA + YDATA(7,2),XDATA(7,1,2),XDATA(7,2,2) + /0.258912851935938800D+1, + 0.704227041878554000D+0,0.819354849092326200D-1/ DATA + YDATA(8,2),XDATA(8,1,2),XDATA(8,2,2) + /0.366894203254154800D+1, + 0.592077736111512000D+0,0.127113960672389100D-1/ DATA + YDATA(9,2),XDATA(9,1,2),XDATA(9,2,2) + /0.574609583351347300D+1, + 0.104940945646421600D+1,0.258095243658316100D-1/ DATA + YDATA(10,2),XDATA(10,1,2),XDATA(10,2,2) + /0.127676424026489300D+2,0.979382517558619200D+0, + 0.124280755181027900D+0/ DATA + YDATA(11,2),XDATA(11,1,2),XDATA(11,2,2) + /0.123473079693623100D+1,0.637870453165538700D-1, + 0.304856401137196400D+0/ DATA + YDATA(12,2),XDATA(12,1,2),XDATA(12,2,2) + /0.142256120864082800D+1,0.176123312906025700D+0, + 0.262387028078896900D+0/ DATA + YDATA(13,2),XDATA(13,1,2),XDATA(13,2,2) + /0.169889534013024700D+1,0.310965082300263000D+0, + 0.226430765474758800D+0/ DATA + YDATA(14,2),XDATA(14,1,2),XDATA(14,2,2) + /0.173485577901204400D+1,0.311394269116782100D+0, + 0.271375840410281800D+0/ DATA + YDATA(15,2),XDATA(15,1,2),XDATA(15,2,2) + /0.277761263972834600D+1,0.447076126190612500D+0, + 0.255000858902618300D+0/ DATA + YDATA(16,2),XDATA(16,1,2),XDATA(16,2,2) + /0.339163324662617300D+1,0.384786230998211100D+0, + 0.154958003178364000D+0/ DATA + YDATA(17,2),XDATA(17,1,2),XDATA(17,2,2) + /0.589615137312147500D+1,0.649093176450780500D+0, + 0.258301685463773200D+0/ DATA + YDATA(18,2),XDATA(18,1,2),XDATA(18,2,2) + /0.124415625214576800D+2,0.685612005372525500D+0, + 0.107391260603228600D+0/ DATA + YDATA(19,2),XDATA(19,1,2),XDATA(19,2,2) + /-0.498491739153861600D+2,0.968747139425088400D+0, + 0.151932526135740700D+0/ DATA + YDATA(20,2),XDATA(20,1,2),XDATA(20,2,2) + /-0.832795509000618600D+1,0.869789367989532900D+0, + 0.625507500586400000D-1/ DATA + YDATA(21,2),XDATA(21,1,2),XDATA(21,2,2) + /0.184934617774239900D+1,-0.465309930332736600D-2, + 0.546795662595375200D+0/ DATA + YDATA(22,2),XDATA(22,1,2),XDATA(22,2,2) + /0.175192979176839200D+1,0.604753397196646000D-2, + 0.230905749473922700D+0/ DATA + YDATA(23,2),XDATA(23,1,2),XDATA(23,2,2) + /0.253949381238535800D+1,0.239418809621756000D+0, + 0.190752069681170700D+0/ DATA + YDATA(24,2),XDATA(24,1,2),XDATA(24,2,2) + /0.373500774928501700D+1,0.456662468911699800D+0, + 0.328870615170984400D+0/ DATA + YDATA(25,2),XDATA(25,1,2),XDATA(25,2,2) + /0.548408128950331000D+1,0.371115320522079500D+0, + 0.439978556640660500D+0/ DATA + YDATA(26,2),XDATA(26,1,2),XDATA(26,2,2) + /0.125256880521774300D+2,0.586442107042503000D+0, + 0.490689043752286700D+0/ DATA + YDATA(27,2),XDATA(27,1,2),XDATA(27,2,2) + /-0.493587797164916600D+2,0.579796274973298000D+0, + 0.521860998203383100D+0/ DATA + YDATA(28,2),XDATA(28,1,2),XDATA(28,2,2) + /-0.801158974965412700D+1,0.805008094903899900D+0, + 0.292283538955391600D+0/ DATA + YDATA(29,2),XDATA(29,1,2),XDATA(29,2,2) + /-0.437399487061934100D+1,0.637242340835710000D+0, + 0.402261740352486000D+0/ DATA + YDATA(30,2),XDATA(30,1,2),XDATA(30,2,2) + /-0.297800103425979600D+1,0.982132817936118700D+0, + 0.392546836419047000D+0/ DATA + YDATA(31,2),XDATA(31,1,2),XDATA(31,2,2) + /0.271811057454661300D+1,-0.223515657121262700D-1, + 0.650479019708978800D+0/ DATA + YDATA(32,2),XDATA(32,1,2),XDATA(32,2,2) + /0.377035865613392400D+1,0.136081427545033600D+0, + 0.753020101897661800D+0/ DATA + YDATA(33,2),XDATA(33,1,2),XDATA(33,2,2) + /0.560111053917143100D+1,0.145367053019870600D+0, + 0.611153532003093100D+0/ DATA + YDATA(34,2),XDATA(34,1,2),XDATA(34,2,2) + /0.128152376174926800D+2,0.308221919576435500D+0, + 0.455217283290423900D+0/ DATA + YDATA(35,2),XDATA(35,1,2),XDATA(35,2,2) + /-0.498709177732467200D+2,0.432658769133528300D+0, + 0.678607663414113000D+0/ DATA + YDATA(36,2),XDATA(36,1,2),XDATA(36,2,2) + /-0.815797696908314300D+1,0.477785501079980300D+0, + 0.536178207572157000D+0/ DATA + YDATA(37,2),XDATA(37,1,2),XDATA(37,2,2) + /-0.440240491195158600D+1,0.727986827616619000D+0, + 0.668497920573493900D+0/ DATA + YDATA(38,2),XDATA(38,1,2),XDATA(38,2,2) + /-0.276723957061767500D+1,0.745950385588265100D+0, + 0.786077589007263700D+0/ DATA + YDATA(39,2),XDATA(39,1,2),XDATA(39,2,2) + /-0.223203667288734800D+1,0.732537503527113500D+0, + 0.582625164046828400D+0/ DATA + YDATA(40,2),XDATA(40,1,2),XDATA(40,2,2) + /-0.169728270310622000D+1,0.967352361433846300D+0, + 0.460779396016832800D+0/ DATA + YDATA(41,2),XDATA(41,1,2),XDATA(41,2,2) + /0.551015652153227000D+1,0.129761784310891100D-1, + 0.700009537931860000D+0/ DATA + YDATA(42,2),XDATA(42,1,2),XDATA(42,2,2) + /0.128036180496215800D+2,0.170163243950629700D+0, + 0.853131830764348700D+0/ DATA + YDATA(43,2),XDATA(43,1,2),XDATA(43,2,2) + /-0.498257683396339000D+2,0.162768461906274000D+0, + 0.865315129048175000D+0/ DATA + YDATA(44,2),XDATA(44,1,2),XDATA(44,2,2) + /-0.877334550221761900D+1,0.222914807946165800D+0, + 0.797511758502094500D+0/ DATA + YDATA(45,2),XDATA(45,1,2),XDATA(45,2,2) + /-0.453820192156867600D+1,0.402910095604624900D+0, + 0.761492958727023100D+0/ DATA + YDATA(46,2),XDATA(46,1,2),XDATA(46,2,2) + /-0.297499315738677900D+1,0.233770812593443200D+0, + 0.896000095844223500D+0/ DATA + YDATA(47,2),XDATA(47,1,2),XDATA(47,2,2) + /-0.212743255978538900D+1,0.646528693486914700D+0, + 0.968574333700755700D+0/ DATA + YDATA(48,2),XDATA(48,1,2),XDATA(48,2,2) + /-0.209703205365401000D+1,0.802811658568969400D+0, + 0.904866450476711600D+0/ DATA + YDATA(49,2),XDATA(49,1,2),XDATA(49,2,2) + /-0.155287292042086200D+1,0.837137859891222900D+0, + 0.835684424990021900D+0/ DATA + YDATA(50,2),XDATA(50,1,2),XDATA(50,2,2) + /-0.161356673770480700D+1,0.103165980756526600D+1, + 0.793902191912346100D+0/ DATA + TDATA(3) + /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3'/ DATA + NDATA(3),MDATA(3),NPDATA(3) + /44,1,9/ DATA + (BDATA(K,3),K=1,9) + /0.281887509408440189D-5, + -0.231290549212363845D-2,0.583035555572801965D+1, + 0.000000000000000000D+0,0.406910776203121026D+8, + 0.138001105225000000D-2,0.596038513209999999D-1, + 0.670582099359999998D+1,0.106994410000000000D+10/ DATA + YDATA(1,3),XDATA(1,1,3) + /0.988227696721327788D+0,0.25D-8/ DATA + YDATA(2,3),XDATA(2,1,3) + /0.988268083998559958D+0,0.64D-8/ DATA + YDATA(3,3),XDATA(3,1,3) + /0.988341022958438831D+0,1.0D-8/ DATA + YDATA(4,3),XDATA(4,1,3) + /0.988380557606306446D+0,0.9D-7/ DATA + YDATA(5,3),XDATA(5,1,3) + /0.988275062411751338D+0,1.0D-6/ DATA + YDATA(6,3),XDATA(6,1,3) + /0.988326680176446987D+0,0.4D-5/ DATA + YDATA(7,3),XDATA(7,1,3) + /0.988306058860433439D+0,0.9D-5/ DATA + YDATA(8,3),XDATA(8,1,3) + /0.988292880079125555D+0,0.16D-4/ DATA + YDATA(9,3),XDATA(9,1,3) + /0.988305279259496905D+0,0.36D-4/ DATA + YDATA(10,3),XDATA(10,1,3) + /0.988278142019574202D+0,0.64D-4/ DATA + YDATA(11,3),XDATA(11,1,3) + /0.988224953369819946D+0,1.0D-4/ DATA + YDATA(12,3),XDATA(12,1,3) + /0.988111989169778223D+0,0.144D-3/ DATA + YDATA(13,3),XDATA(13,1,3) + /0.988045627103840613D+0,0.225D-3/ DATA + YDATA(14,3),XDATA(14,1,3) + /0.987913715667047655D+0,0.400D-3/ DATA + YDATA(15,3),XDATA(15,1,3) + /0.987841994238525678D+0,0.625D-3/ DATA + YDATA(16,3),XDATA(16,1,3) + /0.987638450432434270D+0,0.900D-3/ DATA + YDATA(17,3),XDATA(17,1,3) + /0.987587364331771395D+0,0.1225D-2/ DATA + YDATA(18,3),XDATA(18,1,3) + /0.987576264149633684D+0,0.1600D-2/ DATA + YDATA(19,3),XDATA(19,1,3) + /0.987539209110983643D+0,0.2025D-2/ DATA + YDATA(20,3),XDATA(20,1,3) + /0.987621143807705698D+0,0.25D-2/ DATA + YDATA(21,3),XDATA(21,1,3) + /0.988023229785526217D+0,0.36D-2/ DATA + YDATA(22,3),XDATA(22,1,3) + /0.988558376710994197D+0,0.49D-2/ DATA + YDATA(23,3),XDATA(23,1,3) + /0.989304775352439885D+0,0.64D-2/ DATA + YDATA(24,3),XDATA(24,1,3) + /0.990210452265710472D+0,0.81D-2/ DATA + YDATA(25,3),XDATA(25,1,3) + /0.991095950592263900D+0,1.00D-2/ DATA + YDATA(26,3),XDATA(26,1,3) + /0.991475677297119272D+0,0.11025D-1/ DATA + YDATA(27,3),XDATA(27,1,3) + /0.991901306250746771D+0,0.12100D-1/ DATA + YDATA(28,3),XDATA(28,1,3) + /0.992619222425303263D+0,0.14400D-1/ DATA + YDATA(29,3),XDATA(29,1,3) + /0.993617037631973475D+0,0.16900D-1/ DATA + YDATA(30,3),XDATA(30,1,3) + /0.994727321698030676D+0,0.19600D-1/ DATA + YDATA(31,3),XDATA(31,1,3) + /0.996523114720326189D+0,0.25600D-1/ DATA + YDATA(32,3),XDATA(32,1,3) + /0.998036909563764020D+0,0.32400D-1/ DATA + YDATA(33,3),XDATA(33,1,3) + /0.999151968626971372D+0,0.40000D-1/ DATA + YDATA(34,3),XDATA(34,1,3) + /0.100017083706131769D+1,0.50625D-1/ DATA + YDATA(35,3),XDATA(35,1,3) + /0.100110046382923523D+1,0.75625D-1/ DATA + YDATA(36,3),XDATA(36,1,3) + /0.100059103180404652D+1,0.12250D+0/ DATA + YDATA(37,3),XDATA(37,1,3) + /0.999211829791257561D+0,0.16000D+0/ DATA + YDATA(38,3),XDATA(38,1,3) + /0.994711451526761862D+0,0.25000D+0/ DATA + YDATA(39,3),XDATA(39,1,3) + /0.989844132928847109D+0,0.33640D+0/ DATA + YDATA(40,3),XDATA(40,1,3) + /0.987234104554490439D+0,0.38440D+0/ DATA + YDATA(41,3),XDATA(41,1,3) + /0.980928240178404887D+0,0.49D+0/ DATA + YDATA(42,3),XDATA(42,1,3) + /0.970888680366055576D+0,0.64D+0/ DATA + YDATA(43,3),XDATA(43,1,3) + /0.960043769857327398D+0,0.81D+0/ DATA + YDATA(44,3),XDATA(44,1,3) + /0.947277159259551068D+0,1.00D+0/ DATA + TDATA(4) + /' HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188'/ DATA + NDATA(4),MDATA(4),NPDATA(4) + /13,2,3/ DATA + (BDATA(K,4),K=1,3) + /3.0D+0,3.0D+0,-0.5D+0/ DATA + YDATA(1,4),XDATA(1,1,4),XDATA(1,2,4) + /2.93D+0,0.0D+0,0.0D+0/ DATA + YDATA(2,4),XDATA(2,1,4),XDATA(2,2,4) + /1.95D+0,0.0D+0,1.0D+0/ DATA + YDATA(3,4),XDATA(3,1,4),XDATA(3,2,4) + /0.81D+0,0.0D+0,2.0D+0/ DATA + YDATA(4,4),XDATA(4,1,4),XDATA(4,2,4) + /0.58D+0,0.0D+0,3.0D+0/ DATA + YDATA(5,4),XDATA(5,1,4),XDATA(5,2,4) + /5.90D+0,1.0D+0,0.0D+0/ DATA + YDATA(6,4),XDATA(6,1,4),XDATA(6,2,4) + /4.74D+0,1.0D+0,1.0D+0/ DATA + YDATA(7,4),XDATA(7,1,4),XDATA(7,2,4) + /4.18D+0,1.0D+0,2.0D+0/ DATA + YDATA(8,4),XDATA(8,1,4),XDATA(8,2,4) + /4.05D+0,1.0D+0,2.0D+0/ DATA + YDATA(9,4),XDATA(9,1,4),XDATA(9,2,4) + /9.03D+0,2.0D+0,0.0D+0/ DATA + YDATA(10,4),XDATA(10,1,4),XDATA(10,2,4) + /7.85D+0,2.0D+0,1.0D+0/ DATA + YDATA(11,4),XDATA(11,1,4),XDATA(11,2,4) + /7.22D+0,2.0D+0,2.0D+0/ DATA + YDATA(12,4),XDATA(12,1,4),XDATA(12,2,4) + /8.50D+0,2.5D+0,2.0D+0/ DATA + YDATA(13,4),XDATA(13,1,4),XDATA(13,2,4) + /9.81D+0,2.9D+0,1.8D+0/ DATA + TDATA(5) + /' DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522'/ DATA + NDATA(5),MDATA(5),NPDATA(5) + /8,2,2/ DATA + (BDATA(K,5),K=1,2) + /0.01155D+0,5000.0D+0/ DATA + YDATA(1,5),XDATA(1,1,5),XDATA(1,2,5) + /0.912D+0,109.0D+0,600.0D+0/ DATA + YDATA(2,5),XDATA(2,1,5),XDATA(2,2,5) + /0.382D+0,65.0D+0,640.0D+0/ DATA + YDATA(3,5),XDATA(3,1,5),XDATA(3,2,5) + /0.397D+0,1180.0D+0,600.0D+0/ DATA + YDATA(4,5),XDATA(4,1,5),XDATA(4,2,5) + /0.376D+0,66.0D+0,640.0D+0/ DATA + YDATA(5,5),XDATA(5,1,5),XDATA(5,2,5) + /0.342D+0,1270.0D+0,600.0D+0/ DATA + YDATA(6,5),XDATA(6,1,5),XDATA(6,2,5) + /0.358D+0,69.0D+0,640.0D+0/ DATA + YDATA(7,5),XDATA(7,1,5),XDATA(7,2,5) + /0.348D+0,1230.0D+0,600.0D+0/ DATA + YDATA(8,5),XDATA(8,1,5),XDATA(8,2,5) + /0.376D+0,68.0D+0,640.0D+0/ DATA + TDATA(6) + /' POWELL AND MACDONALD, 1972, TABLES 7 & 8, PAGES 153-154'/ DATA + NDATA(6),MDATA(6),NPDATA(6) + /14,1,3/ DATA + (BDATA(K,6),K=1,3) + /25.0D+0,30.0D+0,6.0D+0/ DATA + YDATA(1,6),XDATA(1,1,6) + /26.38D+0,1.0D+0/ DATA + YDATA(2,6),XDATA(2,1,6) + /25.79D+0,2.0D+0/ DATA + YDATA(3,6),XDATA(3,1,6) + /25.29D+0,3.0D+0/ DATA + YDATA(4,6),XDATA(4,1,6) + /24.86D+0,4.0D+0/ DATA + YDATA(5,6),XDATA(5,1,6) + /24.46D+0,5.0D+0/ DATA + YDATA(6,6),XDATA(6,1,6) + /24.10D+0,6.0D+0/ DATA + YDATA(7,6),XDATA(7,1,6) + /23.78D+0,7.0D+0/ DATA + YDATA(8,6),XDATA(8,1,6) + /23.50D+0,8.0D+0/ DATA + YDATA(9,6),XDATA(9,1,6) + /23.24D+0,9.0D+0/ DATA + YDATA(10,6),XDATA(10,1,6) + /23.00D+0,10.0D+0/ DATA + YDATA(11,6),XDATA(11,1,6) + /22.78D+0,11.0D+0/ DATA + YDATA(12,6),XDATA(12,1,6) + /22.58D+0,12.0D+0/ DATA + YDATA(13,6),XDATA(13,1,6) + /22.39D+0,13.0D+0/ DATA + YDATA(14,6),XDATA(14,1,6) + /22.22D+0,14.0D+0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BDATA(MAXNP,MAXSET) C THE FUNCTION PARAMETER DATA SETS. C DOUBLE PRECISION BETA(*) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER I C AN INDEXING VARIABLE. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MDATA(MAXSET) C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE IN C EACH DATA SET. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NDATA(MAXSET) C THE NUMBER OF OBSERVATIONS PER DATA SET. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPDATA(MAXSET) C THE NUMBER OF FUNCTION PARAMETERS IN EACH DATA SET. C INTEGER SETNO C THE NUMBER OF THE DATA SET BEING ANALYZED. C CHARACTER*80 TDATA(MAXSET) C THE REFERENCE FOR THE DATA SET BEING ANALYZED. C CHARACTER*80 TITLE C THE REFERENCE FOR THE DATA SET BEING ANALYZED. C DOUBLE PRECISION X(LDX,*) C THE ARRAY OF INDEPENDENT VARIABLES. C DOUBLE PRECISION XDATA(MAXN,MAXM,MAXSET) C THE ARRAY OF INDEPENDENT VARIABLES FOR EACH DATA SET. C DOUBLE PRECISION Y(*) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION YDATA(MAXN,MAXSET) C THE DEPENDENT VARIABLES FOR EACH DATA SET. * * C***FIRST EXECUTABLE STATEMENT DODRXD * * TITLE = TDATA(SETNO) * N = NDATA(SETNO) M = MDATA(SETNO) NP = NPDATA(SETNO) * DO 10 I=1,N Y(I) = YDATA(I,SETNO) 10 CONTINUE * DO 30 J=1,M DO 20 I=1,N X(I,J) = XDATA(I,J,SETNO) 20 CONTINUE 30 CONTINUE * DO 40 K=1,NP BETA(K) = BDATA(K,SETNO) 40 CONTINUE * RETURN * END *DODRXF SUBROUTINE DODRXF + (N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOPF) C***BEGIN PROLOGUE DODRXF C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER C CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE FUNCTION VALUES FOR ODRPACK EXERCISER C***END PROLOGUE DODRXF * C...SCALAR ARGUMENTS INTEGER + ISTOPF,LDXPD,M,N,NP * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),F(N),XPLUSD(LDXPD,M) * C...SCALARS IN COMMON INTEGER + SETNO * C...LOCAL SCALARS DOUBLE PRECISION + ONE,ZERO INTEGER + I,J * C...INTRINSIC FUNCTIONS INTRINSIC + EXP * C...COMMON BLOCKS COMMON /SETID/SETNO * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0D0,1.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER I C AN INDEXING VARIABLE. C INTEGER ISTOPF C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHETHER THE C THE VALUES OF BETA AND XPLUSD ARE ACCEPTABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C INTEGER SETNO C THE NUMBER OF THE DATA SET BEING ANALYZED. C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DODRXF * * IF (SETNO.EQ.1) THEN * C SETNO. 1: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 1 * IF (BETA(1).LE.1.01D0) THEN DO 100 I=1,N F(I) = BETA(1)/(XPLUSD(I,1)-BETA(2)) 100 CONTINUE ISTOPF = 0 ELSE ISTOPF = 1 END IF * ELSE IF (SETNO.EQ.2) THEN * C SETNO. 2: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 2 * DO 200 I=1,N F(I) = BETA(1)/(BETA(2)*XPLUSD(I,1)+BETA(3)*XPLUSD(I,2)-ONE) 200 CONTINUE ISTOPF = 0 * ELSE IF (SETNO.EQ.3) THEN * C SETNO. 3: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3 * DO 310 I=1,N F(I) = ZERO DO 300 J=1,4 F(I) = F(I) + BETA(J)/(XPLUSD(I,1)+BETA(J+5)) 300 CONTINUE F(I) = F(I) + BETA(5) 310 CONTINUE ISTOPF = 0 * ELSE IF (SETNO.EQ.4) THEN * C SETNO. 4: HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188 * DO 400 I = 1, N F(I) = BETA(1)*XPLUSD(I,1) + + BETA(2)*EXP(BETA(3)*XPLUSD(I,2)) 400 CONTINUE ISTOPF = 0 * ELSE IF (SETNO.EQ.5) THEN * C SETNO. 5: DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522 * DO 500 I=1,N F(I) = EXP(-BETA(1)*XPLUSD(I,1)* + EXP(-BETA(2)*(ONE/XPLUSD(I,2) - ONE/620.0D0))) 500 CONTINUE ISTOPF = 0 * ELSE IF (SETNO.EQ.6) THEN * C SETNO. 6: POWELL AND MACDONALD, 1972, TABLES 7 & 8, PAGE 153-154 * DO 600 I=1,N F(I) = BETA(1)* + (ONE+BETA(3)*XPLUSD(I,1)/BETA(2))**(-ONE/BETA(3)) 600 CONTINUE ISTOPF = 0 END IF * RETURN * END *DODRXJ SUBROUTINE DODRXJ + (N,NP,M,BETA,XPLUSD,LDXPD, + FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOPJ) C***BEGIN PROLOGUE DODRXJ C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE JACOBIAN MATRICIES FOR ODRPACK EXERCISER C***END PROLOGUE DODRXJ * C...SCALAR ARGUMENTS INTEGER + ISTOPJ,LDFJB,LDFJX,LDXPD,M,N,NP LOGICAL + ISODR * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),FJACB(LDFJB,NP),FJACX(LDFJX,M), + XPLUSD(LDXPD,M) * C...SCALARS IN COMMON INTEGER + SETNO * C...LOCAL SCALARS DOUBLE PRECISION + FAC1,FAC2,FAC3,FAC4,ONE,ZERO INTEGER + I,K * C...INTRINSIC FUNCTIONS INTRINSIC + EXP * C...COMMON BLOCKS COMMON /SETID/SETNO * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0D0,1.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION FAC1,FAC2,FAC3,FAC4 C VARIOUS FACTORS AND TERMS USED IN COMPUTING THE JACOBIANS. C DOUBLE PRECISION FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C DOUBLE PRECISION FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO XPLUSD. C INTEGER ISTOPJ C AN INDICATOR VARIABLE, USED TO DESIGNATE WHETHER THE C THE VALUES OF BETA AND XPLUSD ARE ACCEPTABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C INTEGER SETNO C THE NUMBER OF THE DATA SET BEING ANALYZED. C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DODRXJ * * IF (SETNO.EQ.1) THEN * C SETNO. 1: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 1 * DO 110 I=1,N FJACB(I,1) = ONE/(XPLUSD(I,1)-BETA(2)) FJACB(I,2) = BETA(1)*(XPLUSD(I,1)-BETA(2))**(-2) 110 CONTINUE * IF (ISODR) THEN DO 120 I=1,N FJACX(I,1) = -BETA(1)*(XPLUSD(I,1)-BETA(2))**(-2) 120 CONTINUE END IF * ELSE IF (SETNO.EQ.2) THEN * C SETNO. 2: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 2 * DO 200 I=1,N FJACB(I,1) = ONE/ + (BETA(2)*XPLUSD(I,1)+BETA(3)*XPLUSD(I,2)-ONE) FJACB(I,2) = -BETA(1)* + ((BETA(2)*XPLUSD(I,1)+BETA(3)* + XPLUSD(I,2)-ONE)**(-2))* + XPLUSD(I,1) FJACB(I,3) = -BETA(1)* + ((BETA(2)*XPLUSD(I,1)+BETA(3)* + XPLUSD(I,2)-ONE)**(-2))* + XPLUSD(I,2) 200 CONTINUE * IF (ISODR) THEN DO 220 I=1,N FJACX(I,1) = -BETA(1)* + ((BETA(2)*XPLUSD(I,1)+BETA(3)* + XPLUSD(I,2)-ONE)**(-2))* + BETA(2) FJACX(I,2) = -BETA(1)* + ((BETA(2)*XPLUSD(I,1)+BETA(3)* + XPLUSD(I,2)-ONE)**(-2))* + BETA(3) 220 CONTINUE END IF * ELSE IF (SETNO.EQ.3) THEN * C SETNO. 3: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3 * DO 310 I=1,N FJACB(I,5) = ONE DO 300 K=1,4 FJACB(I,K) = ONE/(XPLUSD(I,1)+BETA(K+5)) FJACB(I,K+5) = -BETA(K)*(XPLUSD(I,1)+BETA(K+5))**(-2) 300 CONTINUE 310 CONTINUE * IF (ISODR) THEN DO 330 I=1,N FJACX(I,1) = ZERO DO 320 K=4,1,-1 FJACX(I,1) = FJACX(I,1) - + BETA(K)*(XPLUSD(I,1)+BETA(K+5))**(-2) 320 CONTINUE 330 CONTINUE END IF * ELSE IF (SETNO.EQ.4) THEN * C SETNO. 4: HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188 * DO 410 I=1,N FJACB(I,1) = XPLUSD(I,1) FJACB(I,2) = EXP(BETA(3)*XPLUSD(I,2)) FJACB(I,3) = BETA(2)*EXP(BETA(3)*XPLUSD(I,2))*XPLUSD(I,2) 410 CONTINUE * IF (ISODR) THEN DO 420 I=1,N FJACX(I,1) = BETA(1) FJACX(I,2) = BETA(2)*EXP(BETA(3)*XPLUSD(I,2))*BETA(3) 420 CONTINUE END IF * ELSE IF (SETNO.EQ.5) THEN * C SETNO. 5: DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522 * DO 510 I=1,N FAC1 = ONE/XPLUSD(I,2) - ONE/620.0D0 FAC2 = EXP(-BETA(2)*FAC1) FAC3 = BETA(1)*XPLUSD(I,1) FAC4 = EXP(-FAC3*FAC2) * FJACB(I,1) = -FAC4*XPLUSD(I,1)*FAC2 FJACB(I,2) = FAC4*FAC3*FAC2*FAC1 * IF (ISODR) THEN FJACX(I,1) = -FAC4*BETA(1)*FAC2 FJACX(I,2) = -FAC4*FAC3*FAC2*BETA(2)/XPLUSD(I,2)**2 END IF 510 CONTINUE * ELSE IF (SETNO.EQ.6) THEN * C SETNO. 6: POWELL AND MACDONALD, 1972, TABLES 7 & 8, PAGE 153-154 * C N.B. THIS DERIVATIVE IS INTENTIONALLY CODED INCORRECTLY * DO 610 I=1,N FJACB(I,1) = ZERO FJACB(I,2) = ZERO FJACB(I,3) = ZERO * IF (ISODR) THEN FJACX(I,1) = XPLUSD(I,1) END IF 610 CONTINUE END IF * ISTOPJ = 0 * RETURN * END *DODRXW SUBROUTINE DODRXW + (MAXN,MAXM,MAXNP,LIWMIN,LWMIN) C***BEGIN PROLOGUE DODRXW C***DATE WRITTEN 890205 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE MINIMUM LENGTHS FOR WORK VECTORS C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1987), C "ODRPACK -- SOFTWARE FOR WEIGHTED ORTHOGONAL C DISTANCE REGRESSION," C UNIVERSITY OF COLORADO DEPARTMENT OF COMPUTER SCIENCE C TECHNICAL REPORT NUMBER CU-CS-360-87. C (TO APPEAR IN ACM TRANS. MATH. SOFTWARE.) C BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1989), C "REFERENCE GUIDE FOR ODRPACK SOFTWARE FOR WEIGHTED C ORTHOGONAL DISTANCE REGRESSION," C ONLINE DOCUMENTATION AVAILABLE FROM AUTHORS C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR C ORTHOGONAL DISTANCE REGRESSION," C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. C***ROUTINES CALLED NONE C***END PROLOGUE DODRXW * C...SCALAR ARGUMENTS INTEGER + LIWMIN,LWMIN,MAXN,MAXM,MAXNP * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER LIWMIN C THE MINIMUM LENGTH OF VECTOR IWORK FOR A GIVEN PROBLEM. C INTEGER LWMIN C THE MINIMUM LENGTH OF VECTOR WORK FOR A GIVEN PROBLEM. C INTEGER MAXM C THE NUMBER OF COLUMNS IN THE INDEPENDENT VARIABLE. C INTEGER MAXN C THE NUMBER OF OBSERVATIONS. C INTEGER MAXNP C THE NUMBER OF FUNCTION PARAMETERS. * * C***FIRST EXECUTABLE STATEMENT DODRXW * * LIWMIN = 19 + 2*MAXNP + MAXM LWMIN = 17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP * RETURN END PROGRAM SAMPLE * C SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER C WHERE MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED C MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE C INDEPENDENT VARIABLE ALLOWED C MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS C ALLOWED C LDX IS THE LEADING DIMENSION OF ARRAY X C LDWD IS THE LEADING DIMENSION OF ARRAY WD C LWORK IS THE DIMENSION OF VECTOR WORK C LIWORK IS THE DIMENSION OF VECTOR IWORK * C...PARAMETERS INTEGER + MAXN,MAXM,MAXNP,LDX,LDWD,LWORK,LIWORK PARAMETER C + (MAXN=15, + MAXM=5, + MAXNP=5, + LDX=MAXN, + LDWD=1, + LWORK = 17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP, + LIWORK = 19 + 2*MAXNP + MAXM) * C DECLARE USER-SUPPLIED SUBROUTINES AND C ALL OTHER NECESSARY VARIABLES AND ARRAYS * C...LOCAL SCALARS INTEGER + I,INFO,IPRINT,J,JOB,LUNERR,LUNRPT,M,N,NP * C...LOCAL ARRAYS REAL + BETA(MAXNP),WD(LDWD,MAXM),WORK(LWORK), + X(LDX,MAXM),Y(LDX) INTEGER + IWORK(LIWORK) * C...EXTERNAL SUBROUTINES EXTERNAL + SODR,FUN,JAC * * OPEN(UNIT=5,FILE='DATA1') OPEN(UNIT=6,FILE='REPORT') * C READ NUMBER OF OBSERVATIONS C NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE C NUMBER OF PARAMETERS C OBSERVED VALUES OF INDEPENDENT AND DEPENDENT VARIABLES C STARTING VALUES OF FUNCTION PARAMETERS * READ (5,*) N,M,NP READ (5,*) ((X(I,J),I=1,N),J=1,M) READ (5,*) (Y(I),I=1,N) READ (5,*) (BETA(I),I=1,NP) * C SPECIFY DELTA WEIGHTS * WD(1,1) = 3.0E0 WD(1,2) = 5.0E0 * C SET CONTROL VALUES TO INVOKE DEFAULT SETTING * JOB = -1 IPRINT = -1 LUNERR = -1 LUNRPT = -1 * C COMPUTE ODR SOLUTION USING FINITE-DIFFERENCE DERIVATIVES * CALL SODR + (FUN,JAC, + N,M,NP, + X,LDX, + Y, + BETA, + WD,LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) * END SUBROUTINE FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOPF) * C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) C INTEGER N,NP,M,LDXPD C REAL BETA(NP),XPLUSD(LDXPD,M) C OUTPUT ARGUMENTS C REAL F(N) C INTEGER ISTOPF * C...SCALAR ARGUMENTS INTEGER + ISTOPF,LDXPD,M,N,NP * C...ARRAY ARGUMENTS REAL + BETA(NP),F(N),XPLUSD(LDXPD,M) * C...LOCAL SCALARS INTEGER + I * C...INTRINSIC FUNCTIONS INTRINSIC + EXP * * DO 10 I = 1, N IF (XPLUSD(I,2).NE.0.0E0) THEN F(I) = EXP(-BETA(1)*XPLUSD(I,1)* + EXP(-BETA(2)* + (1.0E0/XPLUSD(I,2) - 1.0E0/620.0E0))) ELSE ISTOPF = 1 RETURN END IF 10 CONTINUE ISTOPF = 0 * RETURN END PROGRAM SAMPLE * C SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER C WHERE MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED C MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE C INDEPENDENT VARIABLE ALLOWED C MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS C ALLOWED C LDX IS THE LEADING DIMENSION OF ARRAY X C LDSCLD IS THE LEADING DIMENSION OF ARRAY SCLD C LDWD IS THE LEADING DIMENSION OF ARRAY WD C LDIFX IS THE LEADING DIMENSION OF ARRAY IFIXX C LWORK IS THE DIMENSION OF VECTOR WORK C LIWORK IS THE DIMENSION OF VECTOR IWORK * C...PARAMETERS INTEGER + MAXN,MAXM,MAXNP,LDSCLD,LDIFX,LDWD,LWORK,LIWORK PARAMETER C + (MAXN=15, + MAXM=5, + MAXNP=5, + LDSCLD=1, + LDWD=1, + LDIFX=1, + LWORK=17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP, + LIWORK=19 + 2*MAXNP + MAXM) * C DECLARE USER-SUPPLIED SUBROUTINES AND C ALL OTHER NECESSARY VARIABLES AND ARRAYS * C...LOCAL SCALARS REAL + PARTOL,SSTOL,TAUFAC INTEGER + I,INFO,IPRINT,J,JOB,LDX,LUNERR,LUNRPT,M,MAXIT,N,NDIGIT,NP * C...LOCAL ARRAYS REAL + BETA(MAXNP),WD(LDWD,MAXM),SCLB(MAXNP), + SCLD(LDSCLD,MAXM),W(MAXN),WORK(LWORK),X(MAXN,MAXM),Y(MAXN) INTEGER + IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK) * C...EXTERNAL SUBROUTINES EXTERNAL + SODRC,FUN,JAC * * OPEN(UNIT=5,FILE='DATA1') OPEN(UNIT=6,FILE='REPORT') * C SPECIFY LEADING DIMENSION OF ARRAY X * LDX = MAXN * C READ NUMBER OF OBSERVATIONS C NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE C NUMBER OF PARAMETERS C OBSERVED VALUES OF INDEPENDENT AND DEPENDENT VARIABLES C STARTING VALUES OF FUNCTION PARAMETERS * READ (5,*) N,M,NP READ (5,*) ((X(I,J),I=1,N),J=1,M) READ (5,*) (Y(I),I=1,N) READ (5,*) (BETA(I),I=1,NP) * C FIX SECOND COLUMN OF INDEPENDENT VARIABLE AT OBSERVED VALUES * IFIXX(1,1) = 1 IFIXX(1,2) = 0 * C SPECIFY USE OF DEFAULT SCALING * SCLD(1,1) = -1.0E0 SCLB(1) = -1.0E0 * C INDICATE ALL BETA'S ARE TO BE ESTIMATED * IFIXB(1) = -1 * C SPECIFY WEIGHTS * WD(1,1) = 3.0E0 WD(1,2) = 5.0E0 W(1) = -1.0E0 * C SET CONTROL VALUES AND STOPPING CRITERIA * JOB = 10 NDIGIT = -1 TAUFAC = -1.0E0 SSTOL = -1.0E0 PARTOL = -1.0E0 MAXIT = -1 IPRINT = 1111 LUNERR = -1 LUNRPT = -1 * C COMPUTE ODR SOLUTION USING USER-SUPPLIED ANALYTIC DERIVATIVES * CALL SODRC + (FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) * END SUBROUTINE FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOPF) * C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) * C INTEGER N,NP,M,LDXPD C REAL BETA(NP),XPLUSD(LDXPD,M) * C OUTPUT ARGUMENTS * C REAL F(N) C INTEGER ISTOPF * C...SCALAR ARGUMENTS INTEGER + ISTOPF,LDXPD,M,N,NP * C...ARRAY ARGUMENTS REAL + BETA(NP),F(N),XPLUSD(LDXPD,M) * C...LOCAL SCALARS INTEGER + I * C...INTRINSIC FUNCTIONS INTRINSIC + EXP * * DO 10 I = 1, N IF (XPLUSD(I,2).NE.0.0E0) THEN F(I) = EXP(-BETA(1)*XPLUSD(I,1)* + EXP(-BETA(2)* + (1.0E0/XPLUSD(I,2) - 1.0E0/620.0E0))) ELSE ISTOPF = 1 RETURN END IF 10 CONTINUE ISTOPF = 0 * RETURN END SUBROUTINE JAC(N,NP,M,BETA,XPLUSD,LDXPD, + FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOPJ) * C INPUT ARGUMENTS C (WHICH MUST NOT BE CHANGED BY THIS ROUTINE) * C INTEGER N,NP,M,LDXPD C REAL BETA(NP),XPLUSD(LDXPD,M) C LOGICAL ISODR * C OUTPUT ARGUMENTS * C REAL FJACB(LDFJB,NP),FJACX(LDFJX,M) C INTEGER ISTOPJ * C...SCALAR ARGUMENTS INTEGER + ISTOPJ,LDFJB,LDFJX,LDXPD,M,N,NP LOGICAL + ISODR * C...ARRAY ARGUMENTS REAL + BETA(NP),FJACB(LDFJB,NP),FJACX(LDFJX,M),XPLUSD(LDXPD,M) * C...LOCAL SCALARS REAL + FAC1,FAC2,FAC3,FAC4 INTEGER + I * C...INTRINSIC FUNCTIONS INTRINSIC + EXP * * DO 10 I=1,N FAC1 = 1.0E0/XPLUSD(I,2) - 1.0E0/620.0E0 FAC2 = EXP(-BETA(2)*FAC1) FAC3 = BETA(1)*XPLUSD(I,1) FAC4 = EXP(-FAC3*FAC2) * FJACB(I,1) = -FAC4*XPLUSD(I,1)*FAC2 FJACB(I,2) = FAC4*FAC3*FAC2*FAC1 * IF (ISODR) THEN FJACX(I,1) = -FAC4*BETA(1)*FAC2 FJACX(I,2) = -FAC4*FAC3*FAC2*BETA(2)/XPLUSD(I,2)**2 END IF 10 CONTINUE ISTOPJ = 0 * RETURN END *STEST PROGRAM STEST C***BEGIN PROLOGUE TEST C***REFER TO SODR,SODRC C***ROUTINES CALLED SODRX C***DATE WRITTEN 861229 (YYMMDD) C***REVISION DATE 890727 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE EXERCISE FEATURES OF ODRPACK SOFTWARE C***END PROLOGUE ODRPACK * C...SCALARS IN COMMON INTEGER + NTEST * C...LOCAL SCALARS REAL + TSTFAC INTEGER + LUNERR,LUNRPT,LUNSUM LOGICAL + PASSED * C...EXTERNAL SUBROUTINES EXTERNAL + SODRX * C...COMMON BLOCKS COMMON /TSTSET/ NTEST * C***VARIABLE DECLARATIONS (ALPHABETICALLY) * C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNSUM C THE LOGICAL UNIT NUMBER USED FOR A SUMMARY REPORT THAT LISTS C ONLY THE TEST COMPARISONS AND NOT THE ODRPACK GENERATED C REPORTS. C INTEGER NTEST C THE NUMBER OF TESTS TO BE RUN. C LOGICAL PASSED C THE INDICATOR VALUE USED TO DESIGNATES WHETHER THE RESULTS OF C ALL OF THE TESTS AGREE WITH THOSE FROM THE CDC CYBER 205 USING C DOUBLE PRECISION (PASSED=TRUE), OR WHETHER SOME OF THE RESULTS C DISAGREED (PASSED=FALSE). C REAL TSTFAC C THE USER-SUPPLIED FACTOR FOR SCALING THE TEST TOLERANCES USED C TO CHECK FOR AGREEMENT BETWEEN COMPUTED RESULTS AND RESULTS C OBTAINED USING DOUBLE PRECISION VERSION ON CDC CYBER 205. C VALUES OF TSTFAC GREATER THAN ONE INCREASE THE TEST TOLERANCES, C MAKING THE TESTS EASIER TO PASS AND ALLOWING SMALL C DISCREPANCIES BETWEEN THE COMPUTED AND EXPECTED RESULTS TO BE C AUTOMATICALLY DISCOUNTED. * * C***FIRST EXECUTABLE STATEMENT TEST * * C SET UP NECESSARY FILES * C NOTE: ODRPACK GENERATES COMPUTATION AND ERROR REPORTS ON C LOGICAL UNIT 6 BY DEFAULT; C LOGICAL UNIT 'LUNSUM' USED TO SUMMARIZE RESULTS OF COMPARISONS C FROM EXERCISE ROUTINE SODRX. * LUNRPT = 18 LUNERR = 18 LUNSUM = 19 * OPEN(UNIT=LUNRPT,FILE='REPORT') OPEN(UNIT=LUNERR,FILE='REPORT') OPEN(UNIT=LUNSUM,FILE='SUMMARY') * C EXERCISE SINGLE PRECISION VERSION OF ODRPACK C (TEST REPORTS GENERATED ON FILE 'RESULTS' AND C SUMMARIZED IN FILE 'SUMMARY') * NTEST = 10 TSTFAC = 1.0E0 CALL SODRX(TSTFAC,PASSED,LUNSUM) * END *SODRX SUBROUTINE SODRX + (TSTFAC,PASSED,LUNSUM) C***BEGIN PROLOGUE SODRX C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890727 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE EXERCISE FEATURES OF ODRPACK SOFTWARE C***DESCRIPTION C SODRX SUBPROGRAM ARGUMENTS: C REAL TSTFAC C THE USER-SUPPLIED FACTOR FOR SCALING THE TEST TOLERANCES USED C TO CHECK FOR AGREEMENT BETWEEN COMPUTED RESULTS AND RESULTS C OBTAINED USING DOUBLE PRECISION VERSION ON CDC CYBER 205. C VALUES OF TSTFAC GREATER THAN ONE INCREASE THE TEST TOLERANCES, C MAKING THE TESTS EASIER TO PASS AND ALLOWING SMALL C DISCREPANCIES BETWEEN THE COMPUTED AND EXPECTED RESULTS TO BE C AUTOMATICALLY DISCOUNTED. C LOGICAL PASSED C THE INDICATOR VALUE USED TO DESIGNATES WHETHER THE RESULTS OF C ALL OF THE TESTS AGREE WITH THOSE FROM THE CDC CYBER 205 USING C DOUBLE PRECISION (PASSED=TRUE), OR WHETHER SOME OF THE RESULTS C DISAGREED (PASSED=FALSE). C INTEGER LUNSUM C THE LOGICAL UNIT NUMBER USED FOR A SUMMARY REPORT THAT LISTS C ONLY THE TEST COMPARISONS AND NOT THE ODRPACK GENERATED C REPORTS, WHICH ARE WRITTEN TO UNIT 6. C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1987), C "ODRPACK -- SOFTWARE FOR WEIGHTED ORTHOGONAL C DISTANCE REGRESSION," C UNIVERSITY OF COLORADO DEPARTMENT OF COMPUTER SCIENCE C TECHNICAL REPORT NUMBER CU-CS-360-87. C (TO APPEAR IN ACM TRANS. MATH. SOFTWARE.) C BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1989), C "REFERENCE GUIDE FOR ODRPACK SOFTWARE FOR WEIGHTED C ORTHOGONAL DISTANCE REGRESSION," C ONLINE DOCUMENTATION AVAILABLE FROM AUTHORS C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR C ORTHOGONAL DISTANCE REGRESSION," C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. C***ROUTINES CALLED SIWINF,SMPREC,SNRM2,SODR,SODRC,SODRXD, C SODRXF,SODRXJ,SODRXW,SWINF,SZERO, C***END PROLOGUE SODRX * C SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER, WHERE C LIWORK IS THE LENGTH OF THE WORK VECTOR IWORK. C LWORK IS THE LENGTH OF THE WORK VECTOR WORK. C MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED, C MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE C INDEPENDENT VARIABLE ALLOWED, C MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS C ALLOWED, AND C NTESTS IS THE NUMBER OF DIFFERENT TESTS THAT CAN BE RUN. * C...PARAMETERS INTEGER + LIWORK,LWORK,MAXN,MAXM,MAXNP,NTESTS PARAMETER C + (MAXN=50, MAXNP=10, MAXM=3, NTESTS=10, + LWORK = 17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP, + LIWORK = 19 + 2*MAXNP + MAXM) * C...SCALAR ARGUMENTS REAL + TSTFAC INTEGER + LUNSUM LOGICAL + PASSED * C...SCALARS IN COMMON INTEGER + NTEST,SETNO * C...LOCAL SCALARS REAL + BNRM,EPSMAC,HUNDRD,ONE,P01,P2,PARTOL,RSSQ,SSTOL, + TAUFAC,TSTTOL,TWO,ZERO INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,DDELTI,DELTAI,DELTNI,DELTSI, + EPSI,EPSMAI,ETAI,FJACBI,FJACXI,FNI,FSI,I,IDFI,INFO,INT2I, + IPRINI,IPRINT,IRANKI,ITEST,JOB,JOBI,JPVTI,L,LDIFX,LDSCLD,LDTTI, + LDWD,LDX,LIWKMN,LIWMIN,LUN,LUNERI,LUNERR,LUNRPI,LUNRPT,LWKMN, + LWMIN,M,MAXIT,MAXITI,MSG,MSGB,MSGX,N,NDIGIT,NETAI,NFEVI,NITERI, + NJEVI,NNZWI,NP,NPPI,NROWI,NTOLI,OLMAVI,OMEGAI,PARTLI,PNORMI, + PRERSI,QRAUXI,RCONDI,RNORSI,RVARI,SEI,SI,SSFI,SSI,SSSI, + SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI,WRK1I,WSSI,WSSDEI,WSSEPI, + XPLUSI,YTI LOGICAL + FAILED,FAILS,SHORT CHARACTER TITLE*80 * C...LOCAL ARRAYS REAL + BETA(MAXNP),DP205(2,NTESTS), + SCLB(MAXNP),SCLD(MAXN,MAXM),W(MAXN),WD(MAXN,MAXM),WORK(LWORK), + X(MAXN,MAXM),Y(MAXN) INTEGER + IDP205(NTESTS),IFIXB(MAXNP),IFIXX(MAXN,MAXM),IWORK(LIWORK) * C...EXTERNAL FUNCTIONS REAL + SMPREC,SNRM2 EXTERNAL + SMPREC,SNRM2 * C...EXTERNAL SUBROUTINES EXTERNAL + SIWINF,SODR,SODRC,SODRXD,SODRXF,SODRXJ,SODRXW,SWINF,SZERO * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MOD * C...COMMON BLOCKS COMMON /SETID/SETNO COMMON /TSTSET/ NTEST * C...DATA STATEMENTS DATA + ZERO,P01,P2,ONE,TWO,HUNDRD + /0.0E0,0.01E0,0.2E0,1.0E0,2.0E0,100.0E0/ * DATA + (DP205(I,1),I=1,2) + /0.276273319578025680897844934084E+05, + 0.753263956902291894369510458488E-03/ DATA + (DP205(I,2),I=1,2) + /0.276273263014367271057285851346E+05, + 0.753846772268713150687427932817E-03/ DATA + (DP205(I,3),I=1,2) + /0.106994410000000002794090519414E+10, + 0.121280859325605635962966065824E-04/ DATA + (DP205(I,4),I=1,2) + /0.106994410000000002662346114304E+10, + 0.545208463379060601757201499747E-06/ DATA + (DP205(I,5),I=1,2) + /0.142698815637725861752157173592E+01, + 0.108472868712743221975390382045E+01/ DATA + (DP205(I,6),I=1,2) + /0.426132182951397887187250887403E+01, + 0.147796721039842073356542433095E-01/ DATA + (DP205(I,7),I=1,2) + /0.426127230714288607663880633106E+01, + 0.147796612546537433680413855128E-01/ DATA + (DP205(I,8),I=1,2) + /0.437148731790976277721640707488E+02, + 0.114441947440828606711224215902E-02/ DATA + (DP205(I,9),I=1,2) + /0.395094925302768220710923336357E+02, + 0.665183875083491081963688151467E+02/ DATA + (DP205(I,10),I=1,2) + /0.395094925302768220710923336357E+02, + 0.665183875083491081963688151467E+02/ * DATA + (IDP205(I),I=1,10) + /1,1,1,1,101,4,1,1,1023,40100/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL SODRXF C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL SODRXJ C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER ACTRSI C THE LOCATION IN ARRAY WORK OF C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER ALPHAI C THE LOCATION IN ARRAY WORK OF C THE LEVENBERG-MARQUARDT PARAMETER. C REAL BETA(MAXNP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER BETACI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETANI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETASI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C REAL BNRM C THE NORM OF THE BETA. C INTEGER DDELTI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (W*D)**2 * DELTA. C INTEGER DELTAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C REAL DP205(2,NTESTS) C THE FLOATING POINT RESULTS FROM A CDC CYBER 205 USING C DOUBLE PRECISION. C INTEGER EPSI C THE STARTING LOCATION IN ARRAY WORK OF C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C REAL EPSMAC C THE VALUE OF MACHINE PRECISION. C INTEGER EPSMAI C THE LOCATION IN ARRAY WORK OF C THE VALUE OF MACHINE PRECISION. C INTEGER ETAI C THE LOCATION IN ARRAY WORK OF C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C LOGICAL FAILED C THE INDICATOR VALUE USED TO DESIGNATE WHETHER THE RESULTS OF C ALL OF THE DEMONSTRATION RUNS AGREED WITH THOSE FROM THE C CDC CYBER 205 USING DOUBLE PRECISION (FAILED=FALSE) OR WHETHER C SOME OF THE TESTS DISAGREED (FAILED=TRUE). C LOGICAL FAILS C THE INDICATOR VALUE USED TO DESIGNATE WHETHER THE RESULTS OF C AN INDIVIDUAL DEMONSTRATION RUN AGREED WITH THOSE FROM THE C CDC CYBER 205 USING DOUBLE PRECISION (FAILS=FALSE) OR DISAGREE C (FAILS=TRUE). C INTEGER FJACBI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO BETA. C INTEGER FJACXI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO X. C INTEGER FNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON. C REAL HUNDRD C THE VALUE 100.0E0. C INTEGER I C AN INDEX VARIABLE. C INTEGER IDFI C THE STARTING LOCATION IN ARRAY IWORK OF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IDP205(NTESTS) C THE INTEGER RESULTS FROM A CDC CYBER 205 USING C DOUBLE PRECISION. C INTEGER IFIXB(MAXNP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(MAXN,MAXM) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INT2I C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF INTERNAL DOUBLING STEPS. C INTEGER IPRINI C THE LOCATION IN ARRAY IWORK OF C THE PRINT CONTROL VARIABLE. C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IRANKI C THE LOCATION IN ARRAY IWORK OF C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C INTEGER ITEST C THE NUMBER OF THE CURRENT TEST BEING RUN. C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOBI C THE LOCATION IN ARRAY IWORK OF C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C INTEGER JPVTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE PIVOT VECTOR. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LIWMIN C THE MINIMUM LENGTH OF VECTOR IWORK FOR A GIVEN PROBLEM. C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUN C THE LOGICAL UNIT NUMBER CURRENTLY BEING USED. C INTEGER LUNERI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNSUM C THE LOGICAL UNIT NUMBER USED FOR A SUMMARY REPORT. C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER LWMIN C THE MINIMUM LENGTH OF VECTOR WORK FOR A GIVEN PROBLEM. C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXITI C THE LOCATION IN ARRAY IWORK OF C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MSG C AN INDICATOR VARIABLE USED TO DESIGNATE WHICH MESSAGE IS C TO BE PRINTED AS A RESULT OF THE COMPARISON WITH THE CDC CYBER C 205 RESULTS. C INTEGER MSGB C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NDIGIT C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETAI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITERI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NJEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NNZWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPPI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C INTEGER NROWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTEST C THE NUMBER OF TESTS TO BE RUN. C INTEGER NTESTS C THE NUMBER OF DIFFERENT TESTS AVAILABLE. C INTEGER NTOLI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C TO BE SET BY SJCK. C INTEGER OLMAVI C THE LOCATION IN ARRAY WORK OF C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OMEGAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C REAL ONE C THE VALUE 1.0E0. C LOGICAL PASSED C THE INDICATOR VALUE USED TO DESIGNATES WHETHER THE RESULTS OF C ALL OF THE DEMONSTRATION RUNS AGREED WITH THOSE FROM THE C CDC CYBER 205 USING DOUBLE PRECISION (PASSED=TRUE), OR WHETHER C SOME OF THE RESULTS DISAGREED (PASSED=FALSE). C REAL P01 C THE VALUE 0.01E0. C REAL P2 C THE VALUE 0.2E0. C INTEGER PARTLI C THE LOCATION IN ARRAY WORK OF C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C REAL PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER PNORMI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C INTEGER PRERSI C THE LOCATION IN ARRAY WORK OF C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER QRAUXI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C INTEGER RCONDI C THE LOCATION IN ARRAY WORK OF C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C INTEGER RNORSI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C REAL RSSQ C THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER RVARI C THE LOCATION IN ARRAY WORK OF C THE RESIDUAL VARIANCE. C REAL SCLB(MAXNP) C THE SCALE VALUE FOR EACH VALUE OF BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SCLD(MAXN,MAXM) C THE SCALE VALUE FOR EACH VALUE OF DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SEI C THE STARTING LOCATION IN ARRAY WORK OF C THE STANDARD ERRORS FOR THE PARAMETERS, ALSO USED AS A C WORK ARRAY. C INTEGER SETNO C THE NUMBER OF THE DATA SET BEING ANALYZED. C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER ODRPACK IS TO C BE INVOKED BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG-CALL C (SHORT=.FALSE.). C INTEGER SI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED BETA'S. C INTEGER SSFI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE BETA'S. C INTEGER SSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE ESTIMATED BETA'S. C INTEGER SSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C REAL SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SSTOLI C THE LOCATION IN ARRAY WORK OF C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C REAL TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER TAUFCI C THE LOCATION IN ARRAY WORK OF C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C INTEGER TAUI C THE LOCATION IN ARRAY WORK OF C THE TRUST REGION DIAMETER. C INTEGER TI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED DELTA'S. C CHARACTER*80 TITLE C THE REFERENCE FOR THE DATA SET BEING ANALYZED. C REAL TSTFAC C THE USER-SUPPLIED FACTOR FOR SCALING THE TEST TOLERANCES C USED TO CHECK FOR AGREEMENT BETWEEN COMPUTED RESULTS AND C RESULTS OBTAINED USING DOUBLE PRECISION VERSION ON CDC C CYBER 205. C REAL TSTTOL C THE TEST TOLERANCE USED IN CHECKING COMPUTED VALUES FOR C PURPOSES OF DETERMINING PROPER INSTALLATION. C INTEGER TTI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE DELTA'S. C REAL TWO C THE VALUE 2.0E0. C INTEGER UI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR TFJACB. C INTEGER VCVI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE VARIANCE COVARIANCE MATRIX, ALSO USED C TO STORE THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C REAL W(MAXN) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(MAXN,MAXM) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WORK(LWORK) C THE REAL WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER WRK1I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C INTEGER WSSDEI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C INTEGER WSSEPI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C REAL X(MAXN,MAXM) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER XPLUSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY X + DELTA. C REAL Y(MAXN) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER YTI C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SODRX * * C SET LOGICAL UNITS FOR ERROR AND COMPUTATION REPORTS * LUNERR = 18 LUNRPT = 18 * C INITIALIZE TEST TOLERANCE * IF (TSTFAC.GT.ONE) THEN TSTTOL = TSTFAC ELSE TSTTOL = ONE END IF * C INITIALIZE MACHINE PRECISION * EPSMAC = SMPREC() * C INITIALIZE LEADING DIMENSION OF X * LDX = MAXN * C INITIALIZE MISCELLANEOUS VARIABLES USED IN THE EXERCISE PROCEDURE * FAILED = .FALSE. SHORT = .TRUE. N = 0 * C BEGIN EXERCISING ODRPACK * DO 400 ITEST=1,NTEST * C SET CONTROL VALUES TO INVOKE DEFAULT VALUES * IFIXX(1,1) = -1 LDIFX = MAXN IFIXB(1) = -1 W(1) = -ONE NDIGIT = -1 TAUFAC = -ONE SSTOL = -ONE PARTOL = -ONE MAXIT = -1 IPRINT = 2112 * IF (ITEST.EQ.1) THEN * C TEST SIMPLE ODR PROBLEM WITH ANALYTIC DERIVATIVES USING SODR * LUN = LUNRPT DO 10 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1010) LUN = LUNSUM 10 CONTINUE SETNO = 5 CALL SODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL SZERO(LWORK,1,WORK,LWORK) JOB = 00010 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = 1 SHORT = .TRUE. ELSE IF (ITEST.EQ.2) THEN * C TEST SIMPLE OLS PROBLEM WITH FINITE DIFFERENCE DERIVATIVES USING SODR * LUN = LUNRPT DO 20 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1020) LUN = LUNSUM 20 CONTINUE SETNO = 5 CALL SODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL SZERO(LWORK,1,WORK,LWORK) JOB = 00001 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = 1 SHORT = .TRUE. ELSE IF (ITEST.EQ.3) THEN * C TEST PARAMETER FIXING CAPABILITIES FOR POORLY SCALED OLS PROBLEM C WITH ANALYTIC DERIVATIVES USING SODRC. * LUN = LUNRPT DO 30 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1030) LUN = LUNSUM 30 CONTINUE SETNO = 3 CALL SODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL SZERO(LWORK,1,WORK,LWORK) JOB = 00031 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = 1 SHORT = .FALSE. IFIXB(1) = 1 IFIXB(2) = 1 IFIXB(3) = 1 IFIXB(4) = 0 IFIXB(5) = 1 IFIXB(6) = 0 IFIXB(7) = 0 IFIXB(8) = 0 IFIXB(9) = 0 ELSE IF (ITEST.EQ.4) THEN * C TEST WEIGHTING CAPABILITIES FOR ODR PROBLEM WITH C ANALYTIC DERIVATIVES USING SODRC. C ALSO SHOWS SOLUTION OF POORLY SCALED ODR PROBLEM C (DERIVATIVE CHECKING TURNED OFF) * LUN = LUNRPT DO 40 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1040) LUN = LUNSUM 40 CONTINUE SETNO = 3 CALL SZERO(LWORK,1,WORK,LWORK) JOB = 00020 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE DO 45 I=1,N WD(I,1) = P01/ABS(X(I,1)) W(I) = ONE 45 CONTINUE LDWD = N W(28) = ZERO SHORT = .FALSE. IFIXB(1) = 1 IFIXB(2) = 1 IFIXB(3) = 1 IFIXB(4) = 0 IFIXB(5) = 1 IFIXB(6) = 1 IFIXB(7) = 1 IFIXB(8) = 0 IFIXB(9) = 0 IPRINT = 2232 ELSE IF (ITEST.EQ.5) THEN * C TEST DELTA INITIALIZATION CAPABILITIES AND USER-SUPPLIED SCALING C TEST DELTA INITIALIZATION CAPABILITIES C AND USE OF ISTOPF TO RESTRICT PARAMETER VALUES C FOR ODR PROBLEM WITH ANALYTIC DERIVATIVES USING SODRC. * LUN = LUNRPT DO 50 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1050) LUN = LUNSUM 50 CONTINUE SETNO = 1 CALL SODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL SZERO(LWORK,1,WORK,LWORK) JOB = 01010 SCLD(1,1) = TWO LDSCLD = 1 SCLB(1) = P2 SCLB(2) = ONE WD(1,1) = -ONE LDWD = N DO 55 I=20,21 WORK(I) = BETA(1)/Y(I) + BETA(2) - X(I,1) 55 CONTINUE SHORT = .FALSE. ELSE IF (ITEST.EQ.6) THEN * C TEST STIFF STOPPING CONDITIONS FOR UNSCALED ODR PROBLEM C WITH ANALYTIC DERIVATIVES USING SODRC * LUN = LUNRPT DO 60 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1060) LUN = LUNSUM 60 CONTINUE SETNO = 4 CALL SODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL SZERO(LWORK,1,WORK,LWORK) JOB = 00010 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = N SHORT = .FALSE. SSTOL = HUNDRD*EPSMAC PARTOL = EPSMAC MAXIT = 2 ELSE IF (ITEST.EQ.7) THEN * C TEST RESTART FOR UNSCALED ODR PROBLEM C WITH ANALYTIC DERIVATIVES USING SODRC * LUN = LUNRPT DO 70 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1070) LUN = LUNSUM 70 CONTINUE SETNO = 4 JOB = 20210 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = N SHORT = .FALSE. SSTOL = HUNDRD*EPSMAC PARTOL = EPSMAC MAXIT = -1 ELSE IF (ITEST.EQ.8) THEN * C TEST USE OF TAUFAC TO RESTRICT FIRST STEP C FOR ODR PROBLEM WITH FINITE DIFFERENCE DERIVATIVES USING SODRC. * LUN = LUNRPT DO 80 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1080) LUN = LUNSUM 80 CONTINUE SETNO = 6 CALL SODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL SZERO(LWORK,1,WORK,LWORK) JOB = 00200 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = N SHORT = .FALSE. TAUFAC = P01 ELSE IF (ITEST.EQ.9) THEN * C TEST DETECTION OF INCORRECT DERIVATIVES * LUN = LUNRPT DO 90 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1090) LUN = LUNSUM 90 CONTINUE SETNO = 6 CALL SODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL SZERO(LWORK,1,WORK,LWORK) JOB = 00011 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = N SHORT = .FALSE. ELSE IF (ITEST.EQ.10) THEN * C TEST DETECTION OF INCORRECT DERIVATIVES * LUN = LUNRPT DO 100 I=1,2 WRITE (LUN,1000) ITEST WRITE (LUN,1100) LUN = LUNSUM 100 CONTINUE SETNO = 6 CALL SODRXD(TITLE,N,M,NP,X,LDX,Y,BETA) CALL SZERO(LWORK,1,WORK,LWORK) JOB = 00010 SCLD(1,1) = -ONE LDSCLD = 1 SCLB(1) = -ONE WD(1,1) = -ONE LDWD = N SHORT = .FALSE. END IF * CALL SIWINF + (M,NP, + MSGB,MSGX,JPVTI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) CALL SWINF + (N,M,NP, + DELTAI,EPSI, + WSSI,WSSDEI,WSSEPI,RVARI, + PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI, + FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,DELTSI, + DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,TAUI, + ALPHAI,VCVI,OMEGAI,YTI,UI,QRAUXI,WRK1I,SEI,RCONDI, + ETAI,ACTRSI,PNORMI,PRERSI,RNORSI, + LWKMN) CALL SODRXW + (N,M,NP,LIWMIN,LWMIN) * C COMPUTE OLS SOLUTION USING ODRPAK WITH F.D. DERIVATIVES * WRITE (LUNRPT,2200) TITLE WRITE (LUNSUM,2200) TITLE IF (SHORT) THEN CALL SODR + (SODRXF,SODRXJ, + N,M,NP, + X,LDX, + Y, + BETA, + WD,LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + WORK,LWMIN,IWORK,LIWMIN, + INFO) ELSE CALL SODRC + (SODRXF,SODRXJ, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWMIN,IWORK,LIWMIN, + INFO) END IF * C COMPARE RESULTS WITH THOSE OBTAINED ON THE CDC CYBER 205 C USING DOUBLE PRECISION VERSION OF ODRPACK * BNRM = SNRM2(NP,BETA,1) RSSQ = WORK(WSSI) * IF (IDP205(ITEST).EQ.INFO) THEN * C STOPPING CONDITIONS AGREE * IF (INFO.GE.10000) THEN FAILS = .FALSE. MSG = 1 * ELSE IF (MOD(INFO,10).EQ.1) THEN FAILS = ABS(RSSQ-DP205(2,ITEST)).GT. + DP205(2,ITEST)*WORK(SSTOLI)*TSTTOL MSG = 2 * ELSE IF (MOD(INFO,10).EQ.2) THEN FAILS = ABS(BNRM-DP205(1,ITEST)).GT. + DP205(1,ITEST)*WORK(PARTLI)*TSTTOL MSG = 2 * ELSE IF (MOD(INFO,10).EQ.3) THEN FAILS = (ABS(RSSQ-DP205(2,ITEST)).GT. + DP205(2,ITEST)*WORK(SSTOLI)*TSTTOL) + .AND. + (ABS(BNRM-DP205(1,ITEST)).GT. + DP205(1,ITEST)*WORK(PARTLI)*TSTTOL) MSG = 2 * ELSE IF (MOD(INFO,10).EQ.4) THEN FAILS = .FALSE. MSG = 1 * ELSE FAILS = .TRUE. MSG = 4 END IF END IF * ELSE IF (INFO.GE.10000) THEN FAILS = .TRUE. MSG = 3 * ELSE IF (MOD(INFO,10).EQ.1) THEN FAILS = ABS(RSSQ-DP205(2,ITEST)).GT. + DP205(2,ITEST)*WORK(SSTOLI)*TSTTOL MSG = 2 * ELSE IF (MOD(INFO,10).EQ.2) THEN FAILS = ABS(BNRM-DP205(1,ITEST)).GT. + DP205(1,ITEST)*WORK(PARTLI)*TSTTOL MSG = 2 * ELSE IF (MOD(INFO,10).EQ.3) THEN FAILS = (ABS(RSSQ-DP205(2,ITEST)).GT. + DP205(2,ITEST)*WORK(SSTOLI)*TSTTOL) + .AND. + (ABS(BNRM-DP205(1,ITEST)).GT. + DP205(1,ITEST)*WORK(PARTLI)*TSTTOL) MSG = 2 * ELSE FAILS = .TRUE. MSG = 3 END IF END IF END IF * FAILED = FAILED .OR. FAILS * LUN = LUNRPT DO 300 L=1,2 WRITE (LUN,3100) WRITE (LUN,3210) ' CDC CYBER 205 RESULT = ', + DP205(1,ITEST),DP205(2,ITEST),IDP205(ITEST) WRITE (LUN,3210) ' NEW TEST RESULT = ', + BNRM,RSSQ,INFO WRITE (LUN,3210) ' DIFFERENCE = ', + ABS(DP205(1,ITEST)-BNRM),ABS(DP205(2,ITEST)-RSSQ), + ABS(IDP205(ITEST)-INFO) * IF (MSG.EQ.1) THEN WRITE (LUN,3310) ELSE IF (MSG.EQ.2) THEN IF (FAILS) THEN WRITE (LUN,3320) ELSE WRITE (LUN,3330) END IF ELSE IF (MSG.EQ.3) THEN WRITE (LUN,3340) ELSE IF (MSG.EQ.4) THEN WRITE (LUN,3350) END IF * LUN = LUNSUM 300 CONTINUE 400 CONTINUE * IF (FAILED) THEN WRITE (LUNSUM,4100) PASSED = .FALSE. ELSE WRITE (LUNSUM,4200) PASSED = .TRUE. END IF * C FORMAT STATEMENTS * 1000 FORMAT('1EXAMPLE ', I2/) 1010 FORMAT(' TEST SIMPLE ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING SODR.') 1020 FORMAT(' TEST SIMPLE OLS PROBLEM'/ + ' WITH FINITE DIFFERENCE DERIVATIVES', + ' USING SODR.') 1030 FORMAT(' TEST PARAMETER FIXING CAPABILITIES', + ' FOR POORLY SCALED OLS PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING SODRC.') 1040 FORMAT(' TEST WEIGHTING CAPABILITIES', + ' FOR ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING SODRC. '/ + ' ALSO SHOWS SOLUTION OF POORLY SCALED', + ' ODR PROBLEM.'/ + ' (DERIVATIVE CHECKING TURNED OFF.)') 1050 FORMAT(' TEST DELTA INITIALIZATION CAPABILITIES'/ + ' AND USE OF ISTOPF TO RESTRICT PARAMETER VALUES', + ' FOR ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING SODRC.') 1060 FORMAT(' TEST STIFF STOPPING CONDITIONS', + ' FOR UNSCALED ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING SODRC.') 1070 FORMAT(' TEST RESTART', + ' FOR UNSCALED ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING SODRC.') 1080 FORMAT(' TEST USE OF TAUFAC TO RESTRICT FIRST STEP', + ' FOR ODR PROBLEM'/ + ' WITH FINITE DIFFERENCE DERIVATIVES', + ' USING SODRC.') 1090 FORMAT(' TEST DETECTION OF QUESTIONABLE ANALYTIC DERIVATIVES', + ' FOR OLS PROBLEM'/ + ' USING SODRC.') 1100 FORMAT(' TEST DETECTION OF INCORRECT ANALYTIC DERIVATIVES', + ' FOR ODR PROBLEM'/ + ' WITH ANALYTIC DERIVATIVES', + ' USING SODRC.') 2200 FORMAT (' DATA SET REFERENCE: ', A80) 3100 FORMAT + (//' *** COMPARISON OF NEW RESULTS WITH', + ' DOUBLE PRECISION CDC CYBER 205 RESULT ***'// + ' NORM OF BETA', + ' SUM OF SQUARED WTD OBS ERRORS INFO') 3210 FORMAT + (/A25/2E37.30,I6) 3310 FORMAT + (///' NEW STOPPING CONDITION AND EXPECTED STOPPING CONDITION', + ' AGREE,'/ + ' BUT INDICATE CONVERGENCE WAS NOT ATTAINED.'/ + ' NO FURTHER COMPARISONS WILL BE MADE BETWEEN NEW AND', + ' EXPECTED RESULTS.') 3320 FORMAT + (///' *** WARNING ***'// + ' NEW RESULTS AND EXPECTED RESULTS DO NOT', + ' AGREE TO WITHIN STOPPING TOLERANCE'/ + ' OF NEW RESULT.') 3330 FORMAT + (///' NEW RESULTS AND EXPECTED RESULTS', + ' AGREE TO WITHIN STOPPING TOLERANCE'/ + ' OF NEW RESULTS.') 3340 FORMAT + (///' *** WARNING ***'// + ' NEW STOPPING CONDITION AND EXPECTED STOPPING CONDITION', + ' DO NOT AGREE.'/ + ' NO FURTHER COMPARISONS WILL BE MADE BETWEEN NEW AND', + ' EXPECTED RESULTS.') 3350 FORMAT + (///' *** WARNING ***'// + ' UNEXPECTED STOPPING CONDITION.'/ + ' PLEASE CONTACT PACKAGE AUTHORS.') 4100 FORMAT + (/// + '1*** WARNING ***'// + ' RESULTS FROM ONE OR MORE OF THE TESTS DO NOT', + ' AGREE WITH THE EXPECTED RESULTS'/ + ' (OBTAINED USING DOUBLE PRECISION VERSION OF ODRPACK', + ' RUN ON CDC CYBER 205).'/ + ' INSTALLATION OF ODRPACK SHOULD NOT BE CONSIDERED', + ' SUCCESSFUL'/ + ' UNLESS FURTHER EXAMINATION OF THE RESULTS FINDS', + ' THE DISCREPANCY TO BE INSIGNIFICANT.') 4200 FORMAT + (/// + '1RESULTS FROM ALL OF THE TESTS', + ' AGREE WITH THE EXPECTED RESULTS'/ + ' (OBTAINED USING DOUBLE PRECISION VERSION OF ODRPACK', + ' RUN ON CDC CYBER 205).'/ + ' INSTALLATION OF ODRPACK CAN BE CONSIDERED SUCCESSFUL.') * END *SODRXD SUBROUTINE SODRXD + (TITLE,N,M,NP,X,LDX,Y,BETA) C***BEGIN PROLOGUE SODRXD C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SET UP DATA FOR ODRPACK EXERCISER C***END PROLOGUE SODRXD * C SET PARAMETERS FOR MAXIMUM PROBLEM SIZE HANDLED BY THIS DRIVER, WHERE C MAXN IS THE MAXIMUM NUMBER OF OBSERVATIONS ALLOWED, C MAXM IS THE MAXIMUM NUMBER OF COLUMNS IN THE C INDEPENDENT VARIABLE ALLOWED, C MAXNP IS THE MAXIMUM NUMBER OF FUNCTION PARAMETERS C ALLOWED, AND C MAXSET IS THE NUMBER OF DIFFERENT DATA SETS AVAILABLE. * C...PARAMETERS INTEGER + MAXN,MAXM,MAXNP,MAXSET PARAMETER + (MAXN=50,MAXNP=10,MAXM=3,MAXSET=10) * C...SCALAR ARGUMENTS INTEGER + LDX,M,N,NP CHARACTER TITLE*80 * C...ARRAY ARGUMENTS REAL + BETA(*),X(LDX,*),Y(*) * C...SCALARS IN COMMON INTEGER + SETNO * C...LOCAL SCALARS INTEGER + I,J,K * C...LOCAL ARRAYS REAL + BDATA(MAXNP,MAXSET),XDATA(MAXN,MAXM,MAXSET), + YDATA(MAXN,MAXSET) INTEGER + MDATA(MAXSET),NDATA(MAXSET),NPDATA(MAXSET) CHARACTER TDATA(MAXSET)*80 * C...COMMON BLOCKS COMMON /SETID/SETNO * C...DATA STATEMENTS DATA + TDATA(1) + /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 1'/ DATA + NDATA(1),MDATA(1),NPDATA(1) + /40,1,2/ DATA + (BDATA(K,1),K=1,2) + /1.0E+0,1.0E+0/ DATA + YDATA(1,1),XDATA(1,1,1) + /-0.119569795672791172E+1,-0.213701920211315155E-1/ DATA + YDATA(2,1),XDATA(2,1,1) + /-0.128023349509594288E+1,0.494813247025012969E-1/ DATA + YDATA(3,1),XDATA(3,1,1) + /-0.125270693343174591E+1,0.127889194935560226E+0/ DATA + YDATA(4,1),XDATA(4,1,1) + /-0.996698267935287383E+0,0.128615394085645676E+0/ DATA + YDATA(5,1),XDATA(5,1,1) + /-0.104681033065801934E+1,0.232544285655021667E+0/ DATA + YDATA(6,1),XDATA(6,1,1) + /-0.146724952092847308E+1,0.268151108026504516E+0/ DATA + YDATA(7,1),XDATA(7,1,1) + /-0.123366891873487528E+1,0.309041029810905456E+0/ DATA + YDATA(8,1),XDATA(8,1,1) + /-0.165665097907185554E+1,0.405991539210081099E+0/ DATA + YDATA(9,1),XDATA(9,1,1) + /-0.168476460930907119E+1,0.376611424833536147E+0/ DATA + YDATA(10,1),XDATA(10,1,1) + /-0.198571971169224491E+1,0.475875890851020811E+0/ DATA + YDATA(11,1),XDATA(11,1,1) + /-0.195691696638051344E+1,0.499246935397386550E+0/ DATA + YDATA(12,1),XDATA(12,1,1) + /-0.211871342665769836E+1,0.536615037024021147E+0/ DATA + YDATA(13,1),XDATA(13,1,1) + /-0.268642932558671020E+1,0.581830765902996060E+0/ DATA + YDATA(14,1),XDATA(14,1,1) + /-0.281123260058024347E+1,0.684512710422277446E+0/ DATA + YDATA(15,1),XDATA(15,1,1) + /-0.328704486581785920E+1,0.660219819694757458E+0/ DATA + YDATA(16,1),XDATA(16,1,1) + /-0.423062993461887032E+1,0.766990323960781092E+0/ DATA + YDATA(17,1),XDATA(17,1,1) + /-0.512043906552226903E+1,0.808270426690578456E+0/ DATA + YDATA(18,1),XDATA(18,1,1) + /-0.731032616379005535E+1,0.897410020083189004E+0/ DATA + YDATA(19,1),XDATA(19,1,1) + /-0.109002759485608993E+2,0.959199774116277687E+0/ DATA + YDATA(20,1),XDATA(20,1,1) + /-0.251810238510370206E+2,0.914675474762916558E+0/ DATA + YDATA(21,1),XDATA(21,1,1) + /0.100123028650879944E+3,0.997759691476821892E+0/ DATA + YDATA(22,1),XDATA(22,1,1) + /0.168225085871915048E+2,0.107136870384216308E+1/ DATA + YDATA(23,1),XDATA(23,1,1) + /0.894830510866913009E+1,0.108033321037888526E+1/ DATA + YDATA(24,1),XDATA(24,1,1) + /0.645853815227747004E+1,0.116064198672771453E+1/ DATA + YDATA(25,1),XDATA(25,1,1) + /0.498218564760117328E+1,0.119080889359116553E+1/ DATA + YDATA(26,1),XDATA(26,1,1) + /0.382971664718710476E+1,0.129418875187635420E+1/ DATA + YDATA(27,1),XDATA(27,1,1) + /0.344116492497344184E+1,0.135594148099422453E+1/ DATA + YDATA(28,1),XDATA(28,1,1) + /0.276840496973858949E+1,0.135302808716893195E+1/ DATA + YDATA(29,1),XDATA(29,1,1) + /0.259521665196956666E+1,0.137994666010141371E+1/ DATA + YDATA(30,1),XDATA(30,1,1) + /0.205996022794557661E+1,0.147630019545555113E+1/ DATA + YDATA(31,1),XDATA(31,1,1) + /0.197939614345337836E+1,0.153450708076357840E+1/ DATA + YDATA(32,1),XDATA(32,1,1) + /0.156739340562905589E+1,0.152805351451039313E+1/ DATA + YDATA(33,1),XDATA(33,1,1) + /0.159032057073028366E+1,0.157147316247224806E+1/ DATA + YDATA(34,1),XDATA(34,1,1) + /0.173102268158937949E+1,0.166649596005678175E+1/ DATA + YDATA(35,1),XDATA(35,1,1) + /0.155512561664824758E+1,0.166505665838718412E+1/ DATA + YDATA(36,1),XDATA(36,1,1) + /0.149635994944133260E+1,0.175214128553867338E+1/ DATA + YDATA(37,1),XDATA(37,1,1) + /0.147487601463073568E+1,0.180567992463707922E+1/ DATA + YDATA(38,1),XDATA(38,1,1) + /0.117244575233306998E+1,0.184624404296278952E+1/ DATA + YDATA(39,1),XDATA(39,1,1) + /0.910931336069172580E+0,0.195568727388978002E+1/ DATA + YDATA(40,1),XDATA(40,1,1) + /0.126172980914513272E+1,0.199326394036412237E+1/ DATA + TDATA(2) + /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 2'/ DATA + NDATA(2),MDATA(2),NPDATA(2) + /50,2,3/ DATA + (BDATA(K,2),K=1,3) + /-1.0E+0,1.0E+0,1.0E+0/ DATA + YDATA(1,2),XDATA(1,1,2),XDATA(1,2,2) + /0.680832777217942900E+0, + 0.625474598833994800E-1,0.110179064209783100E+0/ DATA + YDATA(2,2),XDATA(2,1,2),XDATA(2,2,2) + /0.122183594595302200E+1, + 0.202500343620642400E+0,-0.196140862891327600E-1/ DATA + YDATA(3,2),XDATA(3,1,2),XDATA(3,2,2) + /0.118958678734608200E+1, + 0.164943738599876500E+0,0.166514874750996600E+0/ DATA + YDATA(4,2),XDATA(4,1,2),XDATA(4,2,2) + /0.146982623764094600E+1, + 0.304874137610506100E+0,0.612908688041490500E-2/ DATA + YDATA(5,2),XDATA(5,1,2),XDATA(5,2,2) + /0.167775338189355300E+1, + 0.532727445580665100E+0,0.938248787552444600E-1/ DATA + YDATA(6,2),XDATA(6,1,2),XDATA(6,2,2) + /0.202485721906026200E+1, + 0.508823707598910200E+0,0.499605775020505400E-2/ DATA + YDATA(7,2),XDATA(7,1,2),XDATA(7,2,2) + /0.258912851935938800E+1, + 0.704227041878554000E+0,0.819354849092326200E-1/ DATA + YDATA(8,2),XDATA(8,1,2),XDATA(8,2,2) + /0.366894203254154800E+1, + 0.592077736111512000E+0,0.127113960672389100E-1/ DATA + YDATA(9,2),XDATA(9,1,2),XDATA(9,2,2) + /0.574609583351347300E+1, + 0.104940945646421600E+1,0.258095243658316100E-1/ DATA + YDATA(10,2),XDATA(10,1,2),XDATA(10,2,2) + /0.127676424026489300E+2,0.979382517558619200E+0, + 0.124280755181027900E+0/ DATA + YDATA(11,2),XDATA(11,1,2),XDATA(11,2,2) + /0.123473079693623100E+1,0.637870453165538700E-1, + 0.304856401137196400E+0/ DATA + YDATA(12,2),XDATA(12,1,2),XDATA(12,2,2) + /0.142256120864082800E+1,0.176123312906025700E+0, + 0.262387028078896900E+0/ DATA + YDATA(13,2),XDATA(13,1,2),XDATA(13,2,2) + /0.169889534013024700E+1,0.310965082300263000E+0, + 0.226430765474758800E+0/ DATA + YDATA(14,2),XDATA(14,1,2),XDATA(14,2,2) + /0.173485577901204400E+1,0.311394269116782100E+0, + 0.271375840410281800E+0/ DATA + YDATA(15,2),XDATA(15,1,2),XDATA(15,2,2) + /0.277761263972834600E+1,0.447076126190612500E+0, + 0.255000858902618300E+0/ DATA + YDATA(16,2),XDATA(16,1,2),XDATA(16,2,2) + /0.339163324662617300E+1,0.384786230998211100E+0, + 0.154958003178364000E+0/ DATA + YDATA(17,2),XDATA(17,1,2),XDATA(17,2,2) + /0.589615137312147500E+1,0.649093176450780500E+0, + 0.258301685463773200E+0/ DATA + YDATA(18,2),XDATA(18,1,2),XDATA(18,2,2) + /0.124415625214576800E+2,0.685612005372525500E+0, + 0.107391260603228600E+0/ DATA + YDATA(19,2),XDATA(19,1,2),XDATA(19,2,2) + /-0.498491739153861600E+2,0.968747139425088400E+0, + 0.151932526135740700E+0/ DATA + YDATA(20,2),XDATA(20,1,2),XDATA(20,2,2) + /-0.832795509000618600E+1,0.869789367989532900E+0, + 0.625507500586400000E-1/ DATA + YDATA(21,2),XDATA(21,1,2),XDATA(21,2,2) + /0.184934617774239900E+1,-0.465309930332736600E-2, + 0.546795662595375200E+0/ DATA + YDATA(22,2),XDATA(22,1,2),XDATA(22,2,2) + /0.175192979176839200E+1,0.604753397196646000E-2, + 0.230905749473922700E+0/ DATA + YDATA(23,2),XDATA(23,1,2),XDATA(23,2,2) + /0.253949381238535800E+1,0.239418809621756000E+0, + 0.190752069681170700E+0/ DATA + YDATA(24,2),XDATA(24,1,2),XDATA(24,2,2) + /0.373500774928501700E+1,0.456662468911699800E+0, + 0.328870615170984400E+0/ DATA + YDATA(25,2),XDATA(25,1,2),XDATA(25,2,2) + /0.548408128950331000E+1,0.371115320522079500E+0, + 0.439978556640660500E+0/ DATA + YDATA(26,2),XDATA(26,1,2),XDATA(26,2,2) + /0.125256880521774300E+2,0.586442107042503000E+0, + 0.490689043752286700E+0/ DATA + YDATA(27,2),XDATA(27,1,2),XDATA(27,2,2) + /-0.493587797164916600E+2,0.579796274973298000E+0, + 0.521860998203383100E+0/ DATA + YDATA(28,2),XDATA(28,1,2),XDATA(28,2,2) + /-0.801158974965412700E+1,0.805008094903899900E+0, + 0.292283538955391600E+0/ DATA + YDATA(29,2),XDATA(29,1,2),XDATA(29,2,2) + /-0.437399487061934100E+1,0.637242340835710000E+0, + 0.402261740352486000E+0/ DATA + YDATA(30,2),XDATA(30,1,2),XDATA(30,2,2) + /-0.297800103425979600E+1,0.982132817936118700E+0, + 0.392546836419047000E+0/ DATA + YDATA(31,2),XDATA(31,1,2),XDATA(31,2,2) + /0.271811057454661300E+1,-0.223515657121262700E-1, + 0.650479019708978800E+0/ DATA + YDATA(32,2),XDATA(32,1,2),XDATA(32,2,2) + /0.377035865613392400E+1,0.136081427545033600E+0, + 0.753020101897661800E+0/ DATA + YDATA(33,2),XDATA(33,1,2),XDATA(33,2,2) + /0.560111053917143100E+1,0.145367053019870600E+0, + 0.611153532003093100E+0/ DATA + YDATA(34,2),XDATA(34,1,2),XDATA(34,2,2) + /0.128152376174926800E+2,0.308221919576435500E+0, + 0.455217283290423900E+0/ DATA + YDATA(35,2),XDATA(35,1,2),XDATA(35,2,2) + /-0.498709177732467200E+2,0.432658769133528300E+0, + 0.678607663414113000E+0/ DATA + YDATA(36,2),XDATA(36,1,2),XDATA(36,2,2) + /-0.815797696908314300E+1,0.477785501079980300E+0, + 0.536178207572157000E+0/ DATA + YDATA(37,2),XDATA(37,1,2),XDATA(37,2,2) + /-0.440240491195158600E+1,0.727986827616619000E+0, + 0.668497920573493900E+0/ DATA + YDATA(38,2),XDATA(38,1,2),XDATA(38,2,2) + /-0.276723957061767500E+1,0.745950385588265100E+0, + 0.786077589007263700E+0/ DATA + YDATA(39,2),XDATA(39,1,2),XDATA(39,2,2) + /-0.223203667288734800E+1,0.732537503527113500E+0, + 0.582625164046828400E+0/ DATA + YDATA(40,2),XDATA(40,1,2),XDATA(40,2,2) + /-0.169728270310622000E+1,0.967352361433846300E+0, + 0.460779396016832800E+0/ DATA + YDATA(41,2),XDATA(41,1,2),XDATA(41,2,2) + /0.551015652153227000E+1,0.129761784310891100E-1, + 0.700009537931860000E+0/ DATA + YDATA(42,2),XDATA(42,1,2),XDATA(42,2,2) + /0.128036180496215800E+2,0.170163243950629700E+0, + 0.853131830764348700E+0/ DATA + YDATA(43,2),XDATA(43,1,2),XDATA(43,2,2) + /-0.498257683396339000E+2,0.162768461906274000E+0, + 0.865315129048175000E+0/ DATA + YDATA(44,2),XDATA(44,1,2),XDATA(44,2,2) + /-0.877334550221761900E+1,0.222914807946165800E+0, + 0.797511758502094500E+0/ DATA + YDATA(45,2),XDATA(45,1,2),XDATA(45,2,2) + /-0.453820192156867600E+1,0.402910095604624900E+0, + 0.761492958727023100E+0/ DATA + YDATA(46,2),XDATA(46,1,2),XDATA(46,2,2) + /-0.297499315738677900E+1,0.233770812593443200E+0, + 0.896000095844223500E+0/ DATA + YDATA(47,2),XDATA(47,1,2),XDATA(47,2,2) + /-0.212743255978538900E+1,0.646528693486914700E+0, + 0.968574333700755700E+0/ DATA + YDATA(48,2),XDATA(48,1,2),XDATA(48,2,2) + /-0.209703205365401000E+1,0.802811658568969400E+0, + 0.904866450476711600E+0/ DATA + YDATA(49,2),XDATA(49,1,2),XDATA(49,2,2) + /-0.155287292042086200E+1,0.837137859891222900E+0, + 0.835684424990021900E+0/ DATA + YDATA(50,2),XDATA(50,1,2),XDATA(50,2,2) + /-0.161356673770480700E+1,0.103165980756526600E+1, + 0.793902191912346100E+0/ DATA + TDATA(3) + /' BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3'/ DATA + NDATA(3),MDATA(3),NPDATA(3) + /44,1,9/ DATA + (BDATA(K,3),K=1,9) + /0.281887509408440189E-5, + -0.231290549212363845E-2,0.583035555572801965E+1, + 0.000000000000000000E+0,0.406910776203121026E+8, + 0.138001105225000000E-2,0.596038513209999999E-1, + 0.670582099359999998E+1,0.106994410000000000E+10/ DATA + YDATA(1,3),XDATA(1,1,3) + /0.988227696721327788E+0,0.25E-8/ DATA + YDATA(2,3),XDATA(2,1,3) + /0.988268083998559958E+0,0.64E-8/ DATA + YDATA(3,3),XDATA(3,1,3) + /0.988341022958438831E+0,1.0E-8/ DATA + YDATA(4,3),XDATA(4,1,3) + /0.988380557606306446E+0,0.9E-7/ DATA + YDATA(5,3),XDATA(5,1,3) + /0.988275062411751338E+0,1.0E-6/ DATA + YDATA(6,3),XDATA(6,1,3) + /0.988326680176446987E+0,0.4E-5/ DATA + YDATA(7,3),XDATA(7,1,3) + /0.988306058860433439E+0,0.9E-5/ DATA + YDATA(8,3),XDATA(8,1,3) + /0.988292880079125555E+0,0.16E-4/ DATA + YDATA(9,3),XDATA(9,1,3) + /0.988305279259496905E+0,0.36E-4/ DATA + YDATA(10,3),XDATA(10,1,3) + /0.988278142019574202E+0,0.64E-4/ DATA + YDATA(11,3),XDATA(11,1,3) + /0.988224953369819946E+0,1.0E-4/ DATA + YDATA(12,3),XDATA(12,1,3) + /0.988111989169778223E+0,0.144E-3/ DATA + YDATA(13,3),XDATA(13,1,3) + /0.988045627103840613E+0,0.225E-3/ DATA + YDATA(14,3),XDATA(14,1,3) + /0.987913715667047655E+0,0.400E-3/ DATA + YDATA(15,3),XDATA(15,1,3) + /0.987841994238525678E+0,0.625E-3/ DATA + YDATA(16,3),XDATA(16,1,3) + /0.987638450432434270E+0,0.900E-3/ DATA + YDATA(17,3),XDATA(17,1,3) + /0.987587364331771395E+0,0.1225E-2/ DATA + YDATA(18,3),XDATA(18,1,3) + /0.987576264149633684E+0,0.1600E-2/ DATA + YDATA(19,3),XDATA(19,1,3) + /0.987539209110983643E+0,0.2025E-2/ DATA + YDATA(20,3),XDATA(20,1,3) + /0.987621143807705698E+0,0.25E-2/ DATA + YDATA(21,3),XDATA(21,1,3) + /0.988023229785526217E+0,0.36E-2/ DATA + YDATA(22,3),XDATA(22,1,3) + /0.988558376710994197E+0,0.49E-2/ DATA + YDATA(23,3),XDATA(23,1,3) + /0.989304775352439885E+0,0.64E-2/ DATA + YDATA(24,3),XDATA(24,1,3) + /0.990210452265710472E+0,0.81E-2/ DATA + YDATA(25,3),XDATA(25,1,3) + /0.991095950592263900E+0,1.00E-2/ DATA + YDATA(26,3),XDATA(26,1,3) + /0.991475677297119272E+0,0.11025E-1/ DATA + YDATA(27,3),XDATA(27,1,3) + /0.991901306250746771E+0,0.12100E-1/ DATA + YDATA(28,3),XDATA(28,1,3) + /0.992619222425303263E+0,0.14400E-1/ DATA + YDATA(29,3),XDATA(29,1,3) + /0.993617037631973475E+0,0.16900E-1/ DATA + YDATA(30,3),XDATA(30,1,3) + /0.994727321698030676E+0,0.19600E-1/ DATA + YDATA(31,3),XDATA(31,1,3) + /0.996523114720326189E+0,0.25600E-1/ DATA + YDATA(32,3),XDATA(32,1,3) + /0.998036909563764020E+0,0.32400E-1/ DATA + YDATA(33,3),XDATA(33,1,3) + /0.999151968626971372E+0,0.40000E-1/ DATA + YDATA(34,3),XDATA(34,1,3) + /0.100017083706131769E+1,0.50625E-1/ DATA + YDATA(35,3),XDATA(35,1,3) + /0.100110046382923523E+1,0.75625E-1/ DATA + YDATA(36,3),XDATA(36,1,3) + /0.100059103180404652E+1,0.12250E+0/ DATA + YDATA(37,3),XDATA(37,1,3) + /0.999211829791257561E+0,0.16000E+0/ DATA + YDATA(38,3),XDATA(38,1,3) + /0.994711451526761862E+0,0.25000E+0/ DATA + YDATA(39,3),XDATA(39,1,3) + /0.989844132928847109E+0,0.33640E+0/ DATA + YDATA(40,3),XDATA(40,1,3) + /0.987234104554490439E+0,0.38440E+0/ DATA + YDATA(41,3),XDATA(41,1,3) + /0.980928240178404887E+0,0.49E+0/ DATA + YDATA(42,3),XDATA(42,1,3) + /0.970888680366055576E+0,0.64E+0/ DATA + YDATA(43,3),XDATA(43,1,3) + /0.960043769857327398E+0,0.81E+0/ DATA + YDATA(44,3),XDATA(44,1,3) + /0.947277159259551068E+0,1.00E+0/ DATA + TDATA(4) + /' HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188'/ DATA + NDATA(4),MDATA(4),NPDATA(4) + /13,2,3/ DATA + (BDATA(K,4),K=1,3) + /3.0E+0,3.0E+0,-0.5E+0/ DATA + YDATA(1,4),XDATA(1,1,4),XDATA(1,2,4) + /2.93E+0,0.0E+0,0.0E+0/ DATA + YDATA(2,4),XDATA(2,1,4),XDATA(2,2,4) + /1.95E+0,0.0E+0,1.0E+0/ DATA + YDATA(3,4),XDATA(3,1,4),XDATA(3,2,4) + /0.81E+0,0.0E+0,2.0E+0/ DATA + YDATA(4,4),XDATA(4,1,4),XDATA(4,2,4) + /0.58E+0,0.0E+0,3.0E+0/ DATA + YDATA(5,4),XDATA(5,1,4),XDATA(5,2,4) + /5.90E+0,1.0E+0,0.0E+0/ DATA + YDATA(6,4),XDATA(6,1,4),XDATA(6,2,4) + /4.74E+0,1.0E+0,1.0E+0/ DATA + YDATA(7,4),XDATA(7,1,4),XDATA(7,2,4) + /4.18E+0,1.0E+0,2.0E+0/ DATA + YDATA(8,4),XDATA(8,1,4),XDATA(8,2,4) + /4.05E+0,1.0E+0,2.0E+0/ DATA + YDATA(9,4),XDATA(9,1,4),XDATA(9,2,4) + /9.03E+0,2.0E+0,0.0E+0/ DATA + YDATA(10,4),XDATA(10,1,4),XDATA(10,2,4) + /7.85E+0,2.0E+0,1.0E+0/ DATA + YDATA(11,4),XDATA(11,1,4),XDATA(11,2,4) + /7.22E+0,2.0E+0,2.0E+0/ DATA + YDATA(12,4),XDATA(12,1,4),XDATA(12,2,4) + /8.50E+0,2.5E+0,2.0E+0/ DATA + YDATA(13,4),XDATA(13,1,4),XDATA(13,2,4) + /9.81E+0,2.9E+0,1.8E+0/ DATA + TDATA(5) + /' DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522'/ DATA + NDATA(5),MDATA(5),NPDATA(5) + /8,2,2/ DATA + (BDATA(K,5),K=1,2) + /0.01155E+0,5000.0E+0/ DATA + YDATA(1,5),XDATA(1,1,5),XDATA(1,2,5) + /0.912E+0,109.0E+0,600.0E+0/ DATA + YDATA(2,5),XDATA(2,1,5),XDATA(2,2,5) + /0.382E+0,65.0E+0,640.0E+0/ DATA + YDATA(3,5),XDATA(3,1,5),XDATA(3,2,5) + /0.397E+0,1180.0E+0,600.0E+0/ DATA + YDATA(4,5),XDATA(4,1,5),XDATA(4,2,5) + /0.376E+0,66.0E+0,640.0E+0/ DATA + YDATA(5,5),XDATA(5,1,5),XDATA(5,2,5) + /0.342E+0,1270.0E+0,600.0E+0/ DATA + YDATA(6,5),XDATA(6,1,5),XDATA(6,2,5) + /0.358E+0,69.0E+0,640.0E+0/ DATA + YDATA(7,5),XDATA(7,1,5),XDATA(7,2,5) + /0.348E+0,1230.0E+0,600.0E+0/ DATA + YDATA(8,5),XDATA(8,1,5),XDATA(8,2,5) + /0.376E+0,68.0E+0,640.0E+0/ DATA + TDATA(6) + /' POWELL AND MACDONALD, 1972, TABLES 7 & 8, PAGES 153-154'/ DATA + NDATA(6),MDATA(6),NPDATA(6) + /14,1,3/ DATA + (BDATA(K,6),K=1,3) + /25.0E+0,30.0E+0,6.0E+0/ DATA + YDATA(1,6),XDATA(1,1,6) + /26.38E+0,1.0E+0/ DATA + YDATA(2,6),XDATA(2,1,6) + /25.79E+0,2.0E+0/ DATA + YDATA(3,6),XDATA(3,1,6) + /25.29E+0,3.0E+0/ DATA + YDATA(4,6),XDATA(4,1,6) + /24.86E+0,4.0E+0/ DATA + YDATA(5,6),XDATA(5,1,6) + /24.46E+0,5.0E+0/ DATA + YDATA(6,6),XDATA(6,1,6) + /24.10E+0,6.0E+0/ DATA + YDATA(7,6),XDATA(7,1,6) + /23.78E+0,7.0E+0/ DATA + YDATA(8,6),XDATA(8,1,6) + /23.50E+0,8.0E+0/ DATA + YDATA(9,6),XDATA(9,1,6) + /23.24E+0,9.0E+0/ DATA + YDATA(10,6),XDATA(10,1,6) + /23.00E+0,10.0E+0/ DATA + YDATA(11,6),XDATA(11,1,6) + /22.78E+0,11.0E+0/ DATA + YDATA(12,6),XDATA(12,1,6) + /22.58E+0,12.0E+0/ DATA + YDATA(13,6),XDATA(13,1,6) + /22.39E+0,13.0E+0/ DATA + YDATA(14,6),XDATA(14,1,6) + /22.22E+0,14.0E+0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BDATA(MAXNP,MAXSET) C THE FUNCTION PARAMETER DATA SETS. C REAL BETA(*) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER I C AN INDEXING VARIABLE. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MDATA(MAXSET) C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE IN C EACH DATA SET. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NDATA(MAXSET) C THE NUMBER OF OBSERVATIONS PER DATA SET. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPDATA(MAXSET) C THE NUMBER OF FUNCTION PARAMETERS IN EACH DATA SET. C INTEGER SETNO C THE NUMBER OF THE DATA SET BEING ANALYZED. C CHARACTER*80 TDATA(MAXSET) C THE REFERENCE FOR THE DATA SET BEING ANALYZED. C CHARACTER*80 TITLE C THE REFERENCE FOR THE DATA SET BEING ANALYZED. C REAL X(LDX,*) C THE ARRAY OF INDEPENDENT VARIABLES. C REAL XDATA(MAXN,MAXM,MAXSET) C THE ARRAY OF INDEPENDENT VARIABLES FOR EACH DATA SET. C REAL Y(*) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL YDATA(MAXN,MAXSET) C THE DEPENDENT VARIABLES FOR EACH DATA SET. * * C***FIRST EXECUTABLE STATEMENT SODRXD * * TITLE = TDATA(SETNO) * N = NDATA(SETNO) M = MDATA(SETNO) NP = NPDATA(SETNO) * DO 10 I=1,N Y(I) = YDATA(I,SETNO) 10 CONTINUE * DO 30 J=1,M DO 20 I=1,N X(I,J) = XDATA(I,J,SETNO) 20 CONTINUE 30 CONTINUE * DO 40 K=1,NP BETA(K) = BDATA(K,SETNO) 40 CONTINUE * RETURN * END *SODRXF SUBROUTINE SODRXF + (N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOPF) C***BEGIN PROLOGUE SODRXF C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER C CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE FUNCTION VALUES FOR ODRPACK EXERCISER C***END PROLOGUE SODRXF * C...SCALAR ARGUMENTS INTEGER + ISTOPF,LDXPD,M,N,NP * C...ARRAY ARGUMENTS REAL + BETA(NP),F(N),XPLUSD(LDXPD,M) * C...SCALARS IN COMMON INTEGER + SETNO * C...LOCAL SCALARS REAL + ONE,ZERO INTEGER + I,J * C...INTRINSIC FUNCTIONS INTRINSIC + EXP * C...COMMON BLOCKS COMMON /SETID/SETNO * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0E0,1.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER I C AN INDEXING VARIABLE. C INTEGER ISTOPF C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHETHER THE C THE VALUES OF BETA AND XPLUSD ARE ACCEPTABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ONE C THE VALUE 1.0E0. C INTEGER SETNO C THE NUMBER OF THE DATA SET BEING ANALYZED. C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SODRXF * * IF (SETNO.EQ.1) THEN * C SETNO. 1: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 1 * IF (BETA(1).LE.1.01E0) THEN DO 100 I=1,N F(I) = BETA(1)/(XPLUSD(I,1)-BETA(2)) 100 CONTINUE ISTOPF = 0 ELSE ISTOPF = 1 END IF * ELSE IF (SETNO.EQ.2) THEN * C SETNO. 2: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 2 * DO 200 I=1,N F(I) = BETA(1)/(BETA(2)*XPLUSD(I,1)+BETA(3)*XPLUSD(I,2)-ONE) 200 CONTINUE ISTOPF = 0 * ELSE IF (SETNO.EQ.3) THEN * C SETNO. 3: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3 * DO 310 I=1,N F(I) = ZERO DO 300 J=1,4 F(I) = F(I) + BETA(J)/(XPLUSD(I,1)+BETA(J+5)) 300 CONTINUE F(I) = F(I) + BETA(5) 310 CONTINUE ISTOPF = 0 * ELSE IF (SETNO.EQ.4) THEN * C SETNO. 4: HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188 * DO 400 I = 1, N F(I) = BETA(1)*XPLUSD(I,1) + + BETA(2)*EXP(BETA(3)*XPLUSD(I,2)) 400 CONTINUE ISTOPF = 0 * ELSE IF (SETNO.EQ.5) THEN * C SETNO. 5: DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522 * DO 500 I=1,N F(I) = EXP(-BETA(1)*XPLUSD(I,1)* + EXP(-BETA(2)*(ONE/XPLUSD(I,2) - ONE/620.0E0))) 500 CONTINUE ISTOPF = 0 * ELSE IF (SETNO.EQ.6) THEN * C SETNO. 6: POWELL AND MACDONALD, 1972, TABLES 7 & 8, PAGE 153-154 * DO 600 I=1,N F(I) = BETA(1)* + (ONE+BETA(3)*XPLUSD(I,1)/BETA(2))**(-ONE/BETA(3)) 600 CONTINUE ISTOPF = 0 END IF * RETURN * END *SODRXJ SUBROUTINE SODRXJ + (N,NP,M,BETA,XPLUSD,LDXPD, + FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOPJ) C***BEGIN PROLOGUE SODRXJ C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE JACOBIAN MATRICIES FOR ODRPACK EXERCISER C***END PROLOGUE SODRXJ * C...SCALAR ARGUMENTS INTEGER + ISTOPJ,LDFJB,LDFJX,LDXPD,M,N,NP LOGICAL + ISODR * C...ARRAY ARGUMENTS REAL + BETA(NP),FJACB(LDFJB,NP),FJACX(LDFJX,M), + XPLUSD(LDXPD,M) * C...SCALARS IN COMMON INTEGER + SETNO * C...LOCAL SCALARS REAL + FAC1,FAC2,FAC3,FAC4,ONE,ZERO INTEGER + I,K * C...INTRINSIC FUNCTIONS INTRINSIC + EXP * C...COMMON BLOCKS COMMON /SETID/SETNO * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0E0,1.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL FAC1,FAC2,FAC3,FAC4 C VARIOUS FACTORS AND TERMS USED IN COMPUTING THE JACOBIANS. C REAL FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C REAL FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO XPLUSD. C INTEGER ISTOPJ C AN INDICATOR VARIABLE, USED TO DESIGNATE WHETHER THE C THE VALUES OF BETA AND XPLUSD ARE ACCEPTABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ONE C THE VALUE 1.0E0. C INTEGER SETNO C THE NUMBER OF THE DATA SET BEING ANALYZED. C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SODRXJ * * IF (SETNO.EQ.1) THEN * C SETNO. 1: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 1 * DO 110 I=1,N FJACB(I,1) = ONE/(XPLUSD(I,1)-BETA(2)) FJACB(I,2) = BETA(1)*(XPLUSD(I,1)-BETA(2))**(-2) 110 CONTINUE * IF (ISODR) THEN DO 120 I=1,N FJACX(I,1) = -BETA(1)*(XPLUSD(I,1)-BETA(2))**(-2) 120 CONTINUE END IF * ELSE IF (SETNO.EQ.2) THEN * C SETNO. 2: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 2 * DO 200 I=1,N FJACB(I,1) = ONE/ + (BETA(2)*XPLUSD(I,1)+BETA(3)*XPLUSD(I,2)-ONE) FJACB(I,2) = -BETA(1)* + ((BETA(2)*XPLUSD(I,1)+BETA(3)* + XPLUSD(I,2)-ONE)**(-2))* + XPLUSD(I,1) FJACB(I,3) = -BETA(1)* + ((BETA(2)*XPLUSD(I,1)+BETA(3)* + XPLUSD(I,2)-ONE)**(-2))* + XPLUSD(I,2) 200 CONTINUE * IF (ISODR) THEN DO 220 I=1,N FJACX(I,1) = -BETA(1)* + ((BETA(2)*XPLUSD(I,1)+BETA(3)* + XPLUSD(I,2)-ONE)**(-2))* + BETA(2) FJACX(I,2) = -BETA(1)* + ((BETA(2)*XPLUSD(I,1)+BETA(3)* + XPLUSD(I,2)-ONE)**(-2))* + BETA(3) 220 CONTINUE END IF * ELSE IF (SETNO.EQ.3) THEN * C SETNO. 3: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3 * DO 310 I=1,N FJACB(I,5) = ONE DO 300 K=1,4 FJACB(I,K) = ONE/(XPLUSD(I,1)+BETA(K+5)) FJACB(I,K+5) = -BETA(K)*(XPLUSD(I,1)+BETA(K+5))**(-2) 300 CONTINUE 310 CONTINUE * IF (ISODR) THEN DO 330 I=1,N FJACX(I,1) = ZERO DO 320 K=4,1,-1 FJACX(I,1) = FJACX(I,1) - + BETA(K)*(XPLUSD(I,1)+BETA(K+5))**(-2) 320 CONTINUE 330 CONTINUE END IF * ELSE IF (SETNO.EQ.4) THEN * C SETNO. 4: HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188 * DO 410 I=1,N FJACB(I,1) = XPLUSD(I,1) FJACB(I,2) = EXP(BETA(3)*XPLUSD(I,2)) FJACB(I,3) = BETA(2)*EXP(BETA(3)*XPLUSD(I,2))*XPLUSD(I,2) 410 CONTINUE * IF (ISODR) THEN DO 420 I=1,N FJACX(I,1) = BETA(1) FJACX(I,2) = BETA(2)*EXP(BETA(3)*XPLUSD(I,2))*BETA(3) 420 CONTINUE END IF * ELSE IF (SETNO.EQ.5) THEN * C SETNO. 5: DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522 * DO 510 I=1,N FAC1 = ONE/XPLUSD(I,2) - ONE/620.0E0 FAC2 = EXP(-BETA(2)*FAC1) FAC3 = BETA(1)*XPLUSD(I,1) FAC4 = EXP(-FAC3*FAC2) * FJACB(I,1) = -FAC4*XPLUSD(I,1)*FAC2 FJACB(I,2) = FAC4*FAC3*FAC2*FAC1 * IF (ISODR) THEN FJACX(I,1) = -FAC4*BETA(1)*FAC2 FJACX(I,2) = -FAC4*FAC3*FAC2*BETA(2)/XPLUSD(I,2)**2 END IF 510 CONTINUE * ELSE IF (SETNO.EQ.6) THEN * C SETNO. 6: POWELL AND MACDONALD, 1972, TABLES 7 & 8, PAGE 153-154 * C N.B. THIS DERIVATIVE IS INTENTIONALLY CODED INCORRECTLY * DO 610 I=1,N FJACB(I,1) = ZERO FJACB(I,2) = ZERO FJACB(I,3) = ZERO * IF (ISODR) THEN FJACX(I,1) = XPLUSD(I,1) END IF 610 CONTINUE END IF * ISTOPJ = 0 * RETURN * END *SODRXW SUBROUTINE SODRXW + (MAXN,MAXM,MAXNP,LIWMIN,LWMIN) C***BEGIN PROLOGUE SODRXW C***DATE WRITTEN 890205 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE MINIMUM LENGTHS FOR WORK VECTORS C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1987), C "ODRPACK -- SOFTWARE FOR WEIGHTED ORTHOGONAL C DISTANCE REGRESSION," C UNIVERSITY OF COLORADO DEPARTMENT OF COMPUTER SCIENCE C TECHNICAL REPORT NUMBER CU-CS-360-87. C (TO APPEAR IN ACM TRANS. MATH. SOFTWARE.) C BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1989), C "REFERENCE GUIDE FOR ODRPACK SOFTWARE FOR WEIGHTED C ORTHOGONAL DISTANCE REGRESSION," C ONLINE DOCUMENTATION AVAILABLE FROM AUTHORS C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR C ORTHOGONAL DISTANCE REGRESSION," C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. C***ROUTINES CALLED NONE C***END PROLOGUE SODRXW * C...SCALAR ARGUMENTS INTEGER + LIWMIN,LWMIN,MAXN,MAXM,MAXNP * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER LIWMIN C THE MINIMUM LENGTH OF VECTOR IWORK FOR A GIVEN PROBLEM. C INTEGER LWMIN C THE MINIMUM LENGTH OF VECTOR WORK FOR A GIVEN PROBLEM. C INTEGER MAXM C THE NUMBER OF COLUMNS IN THE INDEPENDENT VARIABLE. C INTEGER MAXN C THE NUMBER OF OBSERVATIONS. C INTEGER MAXNP C THE NUMBER OF FUNCTION PARAMETERS. * * C***FIRST EXECUTABLE STATEMENT SODRXW * * LIWMIN = 19 + 2*MAXNP + MAXM LWMIN = 17 + 7*MAXN + 10*MAXN*MAXM + 2*MAXN*MAXNP + 8*MAXNP * RETURN END 8 2 2 109.0 65.0 1180.0 66.0 1270.0 69.0 1230.0 68.0 600.0 640.0 600.0 640.0 600.0 640.0 600.0 640.0 0.912 0.382 0.397 0.376 0.342 0.358 0.348 0.376 0.01155 5000.0 1EXAMPLE 1 TEST SIMPLE ODR PROBLEM WITH ANALYTIC DERIVATIVES USING DODR. DATA SET REFERENCE: DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* INITIAL SUMMARY FOR FIT BY METHOD OF ODR ======================================== PROBLEM SIZE: ------------- NUMBER OF OBSERVATIONS 8 NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS 8 NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE 2 NUMBER OF FUNCTION PARAMETERS 2 NUMBER OF UNFIXED FUNCTION PARAMETERS 2 INDEPENDENT VARIABLE AND DELTA WEIGHT SUMMARY: ---------------------------------------------- COLUMN 1 COLUMN 2 OBS 1 OBS N OBS 1 OBS N X - 0.10900D+03 0.68000D+02 0.60000D+03 0.64000D+03 FIXED - NO NO NO NO INITIAL DELTA - 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 DELTA SCALE - 0.91743D-02 0.14706D-01 0.15625D-02 0.15625D-02 DELTA WEIGHTS - 0.10000D+01 0.10000D+01 0.10000D+01 0.10000D+01 DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT SUMMARY: ---------------------------------------------------------- OBS 1 OBS N Y - 0.91200D+00 0.37600D+00 OBS. ERROR WTS. - 0.10000D+01 0.10000D+01 FUNCTION PARAMETER SUMMARY: --------------------------- INDEX - 1 2 INITIAL BETA - 0.11550000D-01 0.50000000D+04 FIXED - NO NO BETA SCALE - 0.86580087D+02 0.20000000D-03 CONTROL VALUES AND STOPPING CRITERIA: -------------------------------------- * JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT 00010 15 0.10D+01 0.15D-07 0.37D-10 50 * A. FIT IS NOT A RESTART. B. DELTAS ARE INITIALIZED TO ZERO. C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS WILL BE COMPUTED AT THE SOLUTION. D. DERIVATIVES ARE SUPPLIED BY USER. USER-SUPPLIED DERIVATIVES WERE CHECKED. THE DERIVATIVES APPEAR TO BE CORRECT. E. FIT IS BY METHOD OF ORTHOGONAL DISTANCE REGRESSION. INITIAL SUMS OF SQUARES: ------------------------ SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.67662011D+00 SUM OF SQUARED WEIGHTED DELTAS 0.00000000D+00 SUM OF SQUARED WEIGHTED EPSILONS 0.67662011D+00 ITERATION REPORTS FOR FIT BY METHOD OF ODR ========================================== CUM. ACT. REL. PRED. REL. IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS G-N NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION TAU/PNORM STEP ---- ------ ----------- ----------- ----------- --------- ---- 1 12 0.19694D+00 0.7089D+00 0.4162D+00 0.151D+01 YES 2 13 0.18655D-02 0.9905D+00 0.9957D+00 0.671D+00 YES 3 14 0.75326D-03 0.5962D+00 0.5963D+00 0.463D-01 YES 4 15 0.75326D-03 0.7567D-06 0.7571D-06 0.226D-04 YES 5 16 0.75326D-03 0.3524D-12 0.3321D-12 0.181D-07 YES FINAL SUMMARY FOR FIT BY METHOD OF ODR ====================================== STOPPING CONDITION (INFO = 1): ----------------------------------- THE RELATIVE CHANGE IN THE SUM OF THE SQUARED WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL CONDITION NUMBER OF NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS JAC EVALS (INVERSE) DEFICIENCY 5 17 7 0.1888D-06 0 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.75326396D-03 SUM OF SQUARED WEIGHTED DELTAS 0.58236143D-06 SUM OF SQUARED WEIGHTED EPSILONS 0.75268160D-03 ESTIMATED RESIDUAL VARIANCE 0.12554399D-03 ( 6 DEGREES OF FREEDOM) ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- J BETA(J) STD. DEV. BETA(J) 1 0.36579730D-02 0.42218455D-04 2 0.27627332D+05 0.22245099D+03 ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N: --------------------------------------------------- I EPSILON(I) DELTA(I,1) DELTA(I,2) 1 0.16751965D-02 0.12677198D-05 0.10604403D-04 2 0.20420781D-02 0.11546520D-04 0.50622485D-04 3 -0.20674196D-01 -0.64437475D-05 -0.58352278D-03 4 0.24289506D-02 0.13533286D-04 0.60245720D-04 5 0.72722747D-02 0.21038103D-05 0.20504371D-03 6 0.40766834D-02 0.21732463D-04 0.10114328D-03 7 0.13033178D-01 0.38974007D-05 0.36788839D-03 8 -0.85448233D-02 -0.46227424D-04 -0.21202526D-03 *** COMPARISON OF NEW RESULTS WITH DOUBLE PRECISION CDC CYBER 205 RESULT *** NORM OF BETA SUM OF SQUARED WTD OBS ERRORS INFO CDC CYBER 205 RESULT = 0.276273319578025693772360682487D+05 0.753263956902291888922951201835D-03 1 NEW TEST RESULT = 0.276273319575923051161225885153D+05 0.753263956902281480582095340992D-03 1 DIFFERENCE = 0.210264261113479733467102050781D-06 0.104083408558608425664715468884D-16 0 NEW RESULTS AND EXPECTED RESULTS AGREE TO WITHIN STOPPING TOLERANCE OF NEW RESULTS. 1EXAMPLE 2 TEST SIMPLE OLS PROBLEM WITH FINITE DIFFERENCE DERIVATIVES USING DODR. DATA SET REFERENCE: DRAPER AND SMITH, 1981, EXERCISE I, PAGE 521-522 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* INITIAL SUMMARY FOR FIT BY METHOD OF OLS ======================================== PROBLEM SIZE: ------------- NUMBER OF OBSERVATIONS 8 NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS 8 NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE 2 NUMBER OF FUNCTION PARAMETERS 2 NUMBER OF UNFIXED FUNCTION PARAMETERS 2 INDEPENDENT VARIABLE SUMMARY: ----------------------------- COLUMN 1 COLUMN 2 OBS 1 OBS N OBS 1 OBS N X - 0.10900D+03 0.68000D+02 0.60000D+03 0.64000D+03 DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT SUMMARY: ---------------------------------------------------------- OBS 1 OBS N Y - 0.91200D+00 0.37600D+00 OBS. ERROR WTS. - 0.10000D+01 0.10000D+01 FUNCTION PARAMETER SUMMARY: --------------------------- INDEX - 1 2 INITIAL BETA - 0.11550000D-01 0.50000000D+04 FIXED - NO NO BETA SCALE - 0.86580087D+02 0.20000000D-03 CONTROL VALUES AND STOPPING CRITERIA: -------------------------------------- * JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT 00001 15 0.10D+01 0.15D-07 0.37D-10 50 * A. FIT IS NOT A RESTART. B. DELTAS ARE FIXED AT ZERO. C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS WILL BE COMPUTED AT THE SOLUTION. D. DERIVATIVES ARE COMPUTED BY FINITE DIFFERENCES. E. FIT IS BY METHOD OF ORDINARY LEAST SQUARES. INITIAL SUMS OF SQUARES: ------------------------ SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.67662011D+00 ITERATION REPORTS FOR FIT BY METHOD OF OLS ========================================== CUM. ACT. REL. PRED. REL. IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS G-N NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION TAU/PNORM STEP ---- ------ ----------- ----------- ----------- --------- ---- 1 10 0.19694D+00 0.7089D+00 0.4162D+00 0.151D+01 YES 2 14 0.18660D-02 0.9905D+00 0.9957D+00 0.671D+00 YES 3 18 0.75385D-03 0.5960D+00 0.5961D+00 0.463D-01 YES 4 22 0.75385D-03 0.3659D-06 0.3660D-06 0.224D-04 YES 5 26 0.75385D-03 0.4069D-13 0.3890D-13 0.480D-08 YES FINAL SUMMARY FOR FIT BY METHOD OF OLS ====================================== STOPPING CONDITION (INFO = 1): ----------------------------------- THE RELATIVE CHANGE IN THE SUM OF THE SQUARED WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL CONDITION NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS (INVERSE) DEFICIENCY 5 30 0.1888D-06 0 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.75384677D-03 ESTIMATED RESIDUAL VARIANCE 0.12564113D-03 ( 6 DEGREES OF FREEDOM) ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- J BETA(J) STD. DEV. BETA(J) 1 0.36579727D-02 0.42219582D-04 2 0.27627326D+05 0.22245646D+03 ESTIMATED EPSILON(I), I = 1, ..., N: ------------------------------------ INDEX VALUE --------------> 1 TO 4 0.16752466D-02 0.20435347D-02 -0.20690748D-01 0.24306567D-02 5 TO 8 0.72779765D-02 0.40794451D-02 0.13043484D-01 -0.85501979D-02 *** COMPARISON OF NEW RESULTS WITH DOUBLE PRECISION CDC CYBER 205 RESULT *** NORM OF BETA SUM OF SQUARED WTD OBS ERRORS INFO CDC CYBER 205 RESULT = 0.276273263014367257710546255112D+05 0.753846772268713135982387552048D-03 1 NEW TEST RESULT = 0.276273263015568700211588293314D+05 0.753846772268713786503691043350D-03 1 DIFFERENCE = 0.120144250104203820228576660156D-06 0.650521303491302660404471680522D-18 0 NEW RESULTS AND EXPECTED RESULTS AGREE TO WITHIN STOPPING TOLERANCE OF NEW RESULTS. 1EXAMPLE 3 TEST PARAMETER FIXING CAPABILITIES FOR POORLY SCALED OLS PROBLEM WITH ANALYTIC DERIVATIVES USING DODRC. DATA SET REFERENCE: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* INITIAL SUMMARY FOR FIT BY METHOD OF OLS ======================================== PROBLEM SIZE: ------------- NUMBER OF OBSERVATIONS 44 NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS 44 NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE 1 NUMBER OF FUNCTION PARAMETERS 9 NUMBER OF UNFIXED FUNCTION PARAMETERS 4 INDEPENDENT VARIABLE SUMMARY: ----------------------------- COLUMN 1 OBS 1 OBS N X - 0.25000D-08 0.10000D+01 DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT SUMMARY: ---------------------------------------------------------- OBS 1 OBS N Y - 0.98823D+00 0.94728D+00 OBS. ERROR WTS. - 0.10000D+01 0.10000D+01 FUNCTION PARAMETER SUMMARY: --------------------------- INDEX - 1 2 3 4 INITIAL BETA - 0.28188751D-05 -0.23129055D-02 0.58303556D+01 0.00000000D+00 FIXED - NO NO NO YES BETA SCALE - 0.35475144D+06 0.43235662D+03 0.17151613D+00 0.35475144D+07 INDEX - 5 6 7 8 INITIAL BETA - 0.40691078D+08 0.13800111D-02 0.59603851D-01 0.67058210D+01 FIXED - NO YES YES YES BETA SCALE - 0.24575412D-07 0.72463188D+03 0.16777439D+02 0.14912417D+00 INDEX - 9 INITIAL BETA - 0.10699441D+10 FIXED - YES BETA SCALE - 0.93462827D-09 CONTROL VALUES AND STOPPING CRITERIA: -------------------------------------- * JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT 00031 15 0.10D+01 0.15D-07 0.37D-10 50 * A. FIT IS NOT A RESTART. B. DELTAS ARE FIXED AT ZERO. C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS WILL BE COMPUTED AT THE SOLUTION. D. DERIVATIVES ARE SUPPLIED BY USER. USER-SUPPLIED DERIVATIVES WERE NOT CHECKED. E. FIT IS BY METHOD OF ORDINARY LEAST SQUARES. INITIAL SUMS OF SQUARES: ------------------------ SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.72853607D+17 ITERATION REPORTS FOR FIT BY METHOD OF OLS ========================================== CUM. ACT. REL. PRED. REL. IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS G-N NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION TAU/PNORM STEP ---- ------ ----------- ----------- ----------- --------- ---- 1 7 0.12128D-04 0.1000D+01 0.1000D+01 0.149D+01 YES 2 8 0.12128D-04 0.1367D-09 0.1367D-09 0.916D-05 YES FINAL SUMMARY FOR FIT BY METHOD OF OLS ====================================== STOPPING CONDITION (INFO = 1): ----------------------------------- THE RELATIVE CHANGE IN THE SUM OF THE SQUARED WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL CONDITION NUMBER OF NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS JAC EVALS (INVERSE) DEFICIENCY 2 9 3 0.4567D-05 0 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.12128086D-04 ESTIMATED RESIDUAL VARIANCE 0.30320215D-06 ( 40 DEGREES OF FREEDOM) ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- J BETA(J) STD. DEV. BETA(J) 1 0.23864554D-05 0.44960316D-06 2 -0.22045007D-02 0.40156250D-04 3 0.38227320D+01 0.38316052D-01 4 0.00000000D+00 FIXED 5 0.45336400D+00 0.52741382D-02 6 0.13800111D-02 FIXED 7 0.59603851D-01 FIXED 8 0.67058210D+01 FIXED 9 0.10699441D+10 FIXED ESTIMATED EPSILON(I), I = 1, ..., N: ------------------------------------ INDEX VALUE --------------> 1 TO 4 -0.58532411D-04 -0.98922487D-04 -0.17186403D-03 -0.21145608D-03 5 TO 8 -0.10661300D-03 -0.16037011D-03 -0.14327882D-03 -0.13496826D-03 9 TO 12 -0.16081292D-03 -0.15138965D-03 -0.11918308D-03 -0.29320925D-04 13 TO 16 0.10823924D-05 0.79400445D-04 0.11879506D-03 0.32176927D-03 17 TO 20 0.40932268D-03 0.49532791D-03 0.64470919D-03 0.71021102D-03 21 TO 24 0.69663179D-03 0.65486308D-03 0.48458577D-03 0.21833926D-03 25 TO 28 0.18554334D-04 -0.57216848D-05 -0.69819569D-04 -0.52768863D-04 29 TO 32 -0.30935563D-03 -0.68242284D-03 -0.10501519D-02 -0.12425623D-02 33 TO 36 -0.11814777D-02 -0.96989876D-03 -0.30291858D-03 0.52133870D-03 37 TO 40 0.90553687D-03 0.11147333D-02 0.79051510D-03 0.32658143D-03 41 TO 44 -0.32711425D-03 -0.27655675D-03 -0.58721962D-03 0.92402660D-04 *** COMPARISON OF NEW RESULTS WITH DOUBLE PRECISION CDC CYBER 205 RESULT *** NORM OF BETA SUM OF SQUARED WTD OBS ERRORS INFO CDC CYBER 205 RESULT = 0.106994410000000000000000000000D+10 0.121280859325605632056607752212D-04 1 NEW TEST RESULT = 0.106994410000000000000000000000D+10 0.121280859325602464153385021128D-04 1 DIFFERENCE = 0.000000000000000000000000000000D+00 0.316790322273108326811552615254D-18 0 NEW RESULTS AND EXPECTED RESULTS AGREE TO WITHIN STOPPING TOLERANCE OF NEW RESULTS. 1EXAMPLE 4 TEST WEIGHTING CAPABILITIES FOR ODR PROBLEM WITH ANALYTIC DERIVATIVES USING DODRC. ALSO SHOWS SOLUTION OF POORLY SCALED ODR PROBLEM. (DERIVATIVE CHECKING TURNED OFF.) DATA SET REFERENCE: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 3 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* INITIAL SUMMARY FOR FIT BY METHOD OF ODR ======================================== PROBLEM SIZE: ------------- NUMBER OF OBSERVATIONS 44 NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS 43 NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE 1 NUMBER OF FUNCTION PARAMETERS 9 NUMBER OF UNFIXED FUNCTION PARAMETERS 6 INDEPENDENT VARIABLE AND DELTA WEIGHT SUMMARY: ---------------------------------------------- COLUMN 1 OBS 1 OBS N X - 0.25000D-08 0.10000D+01 FIXED - NO NO INITIAL DELTA - 0.00000D+00 0.00000D+00 DELTA SCALE - 0.40000D+09 0.10000D+01 DELTA WEIGHTS - 0.40000D+07 0.10000D-01 DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT SUMMARY: ---------------------------------------------------------- OBS 1 OBS N Y - 0.98823D+00 0.94728D+00 OBS. ERROR WTS. - 0.10000D+01 0.10000D+01 FUNCTION PARAMETER SUMMARY: --------------------------- INDEX - 1 2 3 4 INITIAL BETA - 0.23864554D-05 -0.22045007D-02 0.38227320D+01 0.00000000D+00 FIXED - NO NO NO YES BETA SCALE - 0.41903150D+06 0.45361746D+03 0.26159302D+00 0.41903150D+07 INDEX - 5 6 7 8 INITIAL BETA - 0.45336400D+00 0.13800111D-02 0.59603851D-01 0.67058210D+01 FIXED - NO NO NO YES BETA SCALE - 0.22057331D+01 0.72463188D+03 0.16777439D+02 0.14912417D+00 INDEX - 9 INITIAL BETA - 0.10699441D+10 FIXED - YES BETA SCALE - 0.93462827D-09 CONTROL VALUES AND STOPPING CRITERIA: -------------------------------------- * JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT 00020 15 0.10D+01 0.15D-07 0.37D-10 50 * A. FIT IS NOT A RESTART. B. DELTAS ARE INITIALIZED TO ZERO. C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS WILL BE COMPUTED AT THE SOLUTION. D. DERIVATIVES ARE SUPPLIED BY USER. USER-SUPPLIED DERIVATIVES WERE NOT CHECKED. E. FIT IS BY METHOD OF ORTHOGONAL DISTANCE REGRESSION. INITIAL SUMS OF SQUARES: ------------------------ SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.12125301D-04 SUM OF SQUARED WEIGHTED DELTAS 0.00000000D+00 SUM OF SQUARED WEIGHTED EPSILONS 0.12125301D-04 ITERATION REPORTS FOR FIT BY METHOD OF ODR ========================================== CUM. ACT. REL. PRED. REL. IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS G-N BETA NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION TAU/PNORM STEP INDEX ---- ------ ----------- ----------- ----------- --------- ---- ----- 1 9 0.56155D-05 0.5369D+00 0.6023D+00 0.125D+00 NO 1 TO 3 4 TO 6 7 TO 9 4 15 0.12073D-05 0.3881D+00 0.4362D+00 0.172D+00 NO 1 TO 3 4 TO 6 7 TO 9 7 21 0.78718D-06 0.9951D-01 0.1135D+00 0.110D+00 NO 1 TO 3 4 TO 6 7 TO 9 10 26 0.62879D-06 0.8138D-01 0.1132D+00 0.129D+00 NO 1 TO 3 4 TO 6 7 TO 9 13 29 0.55851D-06 0.2283D-01 0.3527D-01 0.944D-01 NO 1 TO 3 4 TO 6 7 TO 9 16 32 0.54521D-06 0.4932D-02 0.4932D-02 0.470D-02 YES 1 TO 3 4 TO 6 7 TO 9 FINAL SUMMARY FOR FIT BY METHOD OF ODR ====================================== STOPPING CONDITION (INFO = 1): ----------------------------------- THE RELATIVE CHANGE IN THE SUM OF THE SQUARED WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL CONDITION NUMBER OF NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS JAC EVALS (INVERSE) DEFICIENCY 17 34 18 0.2257D-05 0 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.54520846D-06 SUM OF SQUARED WEIGHTED DELTAS 0.34235911D-06 SUM OF SQUARED WEIGHTED EPSILONS 0.20284935D-06 ESTIMATED RESIDUAL VARIANCE 0.14735364D-07 ( 37 DEGREES OF FREEDOM) ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- J BETA(J) STD. DEV. BETA(J) 1 0.19589651D-04 0.52651889D-05 2 -0.10685215D-02 0.40956379D-04 3 0.34273242D+01 0.33460070D-01 4 0.00000000D+00 FIXED 5 0.50568278D+00 0.46736561D-02 6 0.28878968D-02 0.42486107D-03 7 0.30315459D-01 0.15303239D-02 8 0.67058210D+01 FIXED 9 0.10699441D+10 FIXED ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N: --------------------------------------------------- I EPSILON(I) DELTA(I,1) 1 0.88570461D-04 0.69884348D-17 2 0.48178261D-04 0.24912653D-16 3 -0.24765244D-04 -0.31264364D-16 4 -0.64400881D-04 -0.65847783D-14 5 0.39946257D-04 0.50368051D-12 6 -0.15447229D-04 -0.31049125D-11 7 -0.10879481D-05 -0.11002802D-11 8 0.33883967D-05 0.10737544D-10 9 -0.33464788D-04 -0.52379092D-09 10 -0.39563353D-04 -0.18904777D-08 11 -0.27444853D-04 -0.30614258D-08 12 0.37753909D-04 0.82637213D-08 13 0.22856054D-04 0.11017897D-07 14 0.58219008D-05 0.70398683D-08 15 -0.68155308D-04 -0.14578533D-06 16 0.13731197D-04 0.38359467D-07 17 -0.15868824D-04 -0.38139162D-07 18 -0.33272425D-04 0.18730032D-09 19 0.33752323D-04 -0.18516739D-06 20 0.42226421D-04 -0.63645905D-06 21 -0.37557687D-05 0.18858089D-06 22 0.20062115D-04 -0.22275916D-05 23 -0.55062716D-05 0.11040139D-05 24 -0.68801374D-04 0.21919657D-04 25 -0.50497929D-04 0.23388120D-04 26 0.21076167D-04 -0.11482851D-04 27 0.57401137D-04 -0.36253055D-04 28 0.30238977D-03 0.00000000D+00 29 0.17416601D-03 -0.17716157D-03 30 0.19806465D-04 -0.23943191D-04 31 -0.79041005D-04 0.12467075D-03 32 -0.14768340D-03 0.27645057D-03 33 -0.11227727D-03 0.23147225D-03 34 -0.47955311D-04 0.99315748D-04 35 0.14051142D-03 -0.14258125D-03 36 0.16261422D-03 0.71727153D-03 37 0.10872451D-03 0.12325979D-02 38 -0.11595613D-04 -0.41681566D-03 39 -0.63872134D-04 -0.44257570D-02 40 -0.10320916D-03 -0.94538181D-02 41 -0.93425003D-04 -0.13989513D-01 42 -0.12333649D-04 -0.30925463D-02 43 0.16966648D-04 0.65797140D-02 44 0.65870876D-04 0.37051037D-01 *** COMPARISON OF NEW RESULTS WITH DOUBLE PRECISION CDC CYBER 205 RESULT *** NORM OF BETA SUM OF SQUARED WTD OBS ERRORS INFO CDC CYBER 205 RESULT = 0.106994410000000000000000000000D+10 0.545208463379060564269829383677D-06 1 NEW TEST RESULT = 0.106994410000000000000000000000D+10 0.545208463379086610532957453412D-06 1 DIFFERENCE = 0.000000000000000000000000000000D+00 0.260462631280697354263509168959D-19 0 NEW RESULTS AND EXPECTED RESULTS AGREE TO WITHIN STOPPING TOLERANCE OF NEW RESULTS. 1EXAMPLE 5 TEST DELTA INITIALIZATION CAPABILITIES AND USE OF ISTOPF TO RESTRICT PARAMETER VALUES FOR ODR PROBLEM WITH ANALYTIC DERIVATIVES USING DODRC. DATA SET REFERENCE: BOGGS, BYRD AND SCHNABEL, 1985, EXAMPLE 1 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* INITIAL SUMMARY FOR FIT BY METHOD OF ODR ======================================== PROBLEM SIZE: ------------- NUMBER OF OBSERVATIONS 40 NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS 40 NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE 1 NUMBER OF FUNCTION PARAMETERS 2 NUMBER OF UNFIXED FUNCTION PARAMETERS 2 INDEPENDENT VARIABLE AND DELTA WEIGHT SUMMARY: ---------------------------------------------- COLUMN 1 OBS 1 OBS N X - -0.21370D-01 0.19933D+01 FIXED - NO NO INITIAL DELTA - 0.00000D+00 0.00000D+00 DELTA SCALE - 0.20000D+01 0.20000D+01 DELTA WEIGHTS - 0.10000D+01 0.10000D+01 DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT SUMMARY: ---------------------------------------------------------- OBS 1 OBS N Y - -0.11957D+01 0.12617D+01 OBS. ERROR WTS. - 0.10000D+01 0.10000D+01 FUNCTION PARAMETER SUMMARY: --------------------------- INDEX - 1 2 INITIAL BETA - 0.10000000D+01 0.10000000D+01 FIXED - NO NO BETA SCALE - 0.20000000D+00 0.10000000D+01 CONTROL VALUES AND STOPPING CRITERIA: -------------------------------------- * JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT 01010 15 0.10D+01 0.15D-07 0.37D-10 50 * A. FIT IS NOT A RESTART. B. DELTAS ARE INITIALIZED BY USER. C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS WILL BE COMPUTED AT THE SOLUTION. D. DERIVATIVES ARE SUPPLIED BY USER. USER-SUPPLIED DERIVATIVES WERE CHECKED. THE DERIVATIVES APPEAR TO BE CORRECT. E. FIT IS BY METHOD OF ORTHOGONAL DISTANCE REGRESSION. INITIAL SUMS OF SQUARES: ------------------------ SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.21300300D+03 SUM OF SQUARED WEIGHTED DELTAS 0.22299864D-02 SUM OF SQUARED WEIGHTED EPSILONS 0.21300077D+03 ITERATION REPORTS FOR FIT BY METHOD OF ODR ========================================== CUM. ACT. REL. PRED. REL. IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS G-N NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION TAU/PNORM STEP ---- ------ ----------- ----------- ----------- --------- ---- 1 13 0.26186D+02 0.8771D+00 0.9918D+00 0.718D-01 NO 2 19 0.26949D+01 0.8971D+00 0.9518D+00 0.537D-01 NO 3 24 0.11496D+01 0.5734D+00 0.5813D+00 0.208D-01 NO 4 28 0.10967D+01 0.4596D-01 0.4602D-01 0.404D-02 NO 5 32 0.10891D+01 0.6980D-02 0.6978D-02 0.858D-03 NO 6 37 0.10862D+01 0.2622D-02 0.2621D-02 0.336D-03 NO 7 42 0.10851D+01 0.1028D-02 0.1028D-02 0.133D-03 NO 8 46 0.10849D+01 0.2046D-03 0.2046D-03 0.266D-04 NO 9 51 0.10848D+01 0.8171D-04 0.8171D-04 0.106D-04 NO 10 56 0.10847D+01 0.3266D-04 0.3266D-04 0.425D-05 NO 11 61 0.10847D+01 0.1306D-04 0.1306D-04 0.170D-05 NO 12 64 0.10847D+01 0.1306D-05 0.1306D-05 0.170D-06 NO 13 70 0.10847D+01 0.1045D-05 0.1045D-05 0.136D-06 NO 14 73 0.10847D+01 0.1045D-06 0.1045D-06 0.136D-07 NO 15 78 0.10847D+01 0.4180D-07 0.4180D-07 0.544D-08 NO 16 84 0.10847D+01 0.1672D-08 0.1672D-08 0.218D-09 NO FINAL SUMMARY FOR FIT BY METHOD OF ODR ====================================== STOPPING CONDITION (INFO = 101): ----------------------------------- THE RELATIVE CHANGE IN THE SUM OF THE SQUARED WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL NOTE: THE RESULTS FROM ODRPACK ARE QUESTIONABLE BECAUSE THE MOST RECENTLY TRIED STEP WAS REJECTED BY THE USER AS INDICATED BY THE VALUE OF VARIABLE ISTOPF RETURNED FROM USER-SUPPLIED SUBROUTINE FUN. CONDITION NUMBER OF NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS JAC EVALS (INVERSE) DEFICIENCY 16 85 18 0.6203D+00 0 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.10847287D+01 SUM OF SQUARED WEIGHTED DELTAS 0.84001724D-02 SUM OF SQUARED WEIGHTED EPSILONS 0.10763285D+01 ESTIMATED RESIDUAL VARIANCE 0.28545492D-01 ( 38 DEGREES OF FREEDOM) ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- J BETA(J) STD. DEV. BETA(J) 1 0.10100000D+01 0.54610774D-01 2 0.10080651D+01 0.28682229D-01 ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N: --------------------------------------------------- I EPSILON(I) DELTA(I,1) 1 0.21384066D+00 0.77254676D-03 2 0.22556030D+00 0.94112955D-03 3 0.10449749D+00 0.54542566D-03 4 -0.15087433D+00 -0.66893074D-03 5 -0.25305972D+00 -0.14799579D-02 6 0.10081986D+00 0.76139533D-03 7 -0.20815357D+00 -0.14782722D-02 8 -0.20702085D-01 -0.65643511D-04 9 0.82994169D-01 0.90137371D-03 10 0.83205321D-01 0.13127806D-02 11 -0.27450813D-01 -0.16008898D-03 12 -0.23169388D-01 -0.97700225D-04 13 0.28066202D+00 0.64098334D-02 14 -0.23338057D+00 -0.81810740D-02 15 0.29088630D+00 0.10746943D-01 16 0.55125004D-03 0.23085084D-02 17 -0.85415379D-02 0.28744276D-02 18 -0.31404326D-01 -0.26914690D-01 19 -0.23300280D-01 -0.43595260D-01 20 -0.12567838D-02 0.53282035D-01 21 -0.19797459D-04 0.20392976D-01 22 0.16130354D-02 -0.32707756D-02 23 0.20379162D-01 0.40345932D-01 24 0.37905960D-01 0.28927563D-02 25 0.11536131D+00 0.15390699D-01 26 -0.15926106D+00 -0.10953475D-01 27 -0.40829803D+00 -0.14858163D-01 28 0.13213575D+00 0.32479255D-02 29 0.10561235D+00 0.20776715D-02 30 0.91812855D-01 0.11452297D-02 31 -0.57069265D-01 -0.10370842D-02 32 0.35811193D+00 0.45491883D-02 33 0.19590912D+00 0.20287132D-02 34 -0.19295097D+00 -0.17644917D-02 35 -0.17148546D-01 -0.28478211D-03 36 -0.13714996D+00 -0.99750359D-03 37 -0.20659836D+00 -0.12592594D-02 38 0.32401177D-01 0.10179380D-03 39 0.15424345D+00 0.57898907D-03 40 -0.23559464D+00 -0.92308083D-03 *** COMPARISON OF NEW RESULTS WITH DOUBLE PRECISION CDC CYBER 205 RESULT *** NORM OF BETA SUM OF SQUARED WTD OBS ERRORS INFO CDC CYBER 205 RESULT = 0.142698815637725862082163530431D+01 0.108472868712743220065419791354D+01 101 NEW TEST RESULT = 0.142698815635322628914138931577D+01 0.108472868747640438513712979329D+01 101 DIFFERENCE = 0.240323316802459885366261005402D-10 0.348972184482931879756506532431D-09 0 NEW RESULTS AND EXPECTED RESULTS AGREE TO WITHIN STOPPING TOLERANCE OF NEW RESULTS. 1EXAMPLE 6 TEST STIFF STOPPING CONDITIONS FOR UNSCALED ODR PROBLEM WITH ANALYTIC DERIVATIVES USING DODRC. DATA SET REFERENCE: HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* INITIAL SUMMARY FOR FIT BY METHOD OF ODR ======================================== PROBLEM SIZE: ------------- NUMBER OF OBSERVATIONS 13 NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS 13 NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE 2 NUMBER OF FUNCTION PARAMETERS 3 NUMBER OF UNFIXED FUNCTION PARAMETERS 3 INDEPENDENT VARIABLE AND DELTA WEIGHT SUMMARY: ---------------------------------------------- COLUMN 1 COLUMN 2 OBS 1 OBS N OBS 1 OBS N X - 0.00000D+00 0.29000D+01 0.00000D+00 0.18000D+01 FIXED - NO NO NO NO INITIAL DELTA - 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 DELTA SCALE - 0.10000D+02 0.34483D+00 0.10000D+02 0.33333D+00 DELTA WEIGHTS - 0.10000D+01 0.10000D+01 0.10000D+01 0.10000D+01 DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT SUMMARY: ---------------------------------------------------------- OBS 1 OBS N Y - 0.29300D+01 0.98100D+01 OBS. ERROR WTS. - 0.10000D+01 0.10000D+01 FUNCTION PARAMETER SUMMARY: --------------------------- INDEX - 1 2 3 INITIAL BETA - 0.30000000D+01 0.30000000D+01 -0.50000000D+00 FIXED - NO NO NO BETA SCALE - 0.33333333D+00 0.33333333D+00 0.33333333D+00 CONTROL VALUES AND STOPPING CRITERIA: -------------------------------------- * JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT 00010 15 0.10D+01 0.22D-13 0.22D-15 2 * A. FIT IS NOT A RESTART. B. DELTAS ARE INITIALIZED TO ZERO. C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS WILL BE COMPUTED AT THE SOLUTION. D. DERIVATIVES ARE SUPPLIED BY USER. USER-SUPPLIED DERIVATIVES WERE CHECKED. THE DERIVATIVES APPEAR TO BE CORRECT. E. FIT IS BY METHOD OF ORTHOGONAL DISTANCE REGRESSION. INITIAL SUMS OF SQUARES: ------------------------ SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.17930508D+00 SUM OF SQUARED WEIGHTED DELTAS 0.00000000D+00 SUM OF SQUARED WEIGHTED EPSILONS 0.17930508D+00 ITERATION REPORTS FOR FIT BY METHOD OF ODR ========================================== CUM. ACT. REL. PRED. REL. IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS G-N NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION TAU/PNORM STEP ---- ------ ----------- ----------- ----------- --------- ---- 1 13 0.14822D-01 0.9173D+00 0.9167D+00 0.105D+01 YES 2 14 0.14780D-01 0.2874D-02 0.2897D-02 0.269D-01 YES FINAL SUMMARY FOR FIT BY METHOD OF ODR ====================================== STOPPING CONDITION (INFO = 4): ----------------------------------- MAXIMUM NUMBER OF ITERATIONS REACHED CONDITION NUMBER OF NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS JAC EVALS (INVERSE) DEFICIENCY 2 15 4 0.2281D+00 0 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.14779672D-01 SUM OF SQUARED WEIGHTED DELTAS 0.13389160D-01 SUM OF SQUARED WEIGHTED EPSILONS 0.13905124D-02 ESTIMATED RESIDUAL VARIANCE 0.14779672D-02 ( 10 DEGREES OF FREEDOM) ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- J BETA(J) STD. DEV. BETA(J) 1 0.30212727D+01 0.36887566D-01 2 0.29588335D+01 0.83318859D-01 3 -0.52543271D+00 0.30452500D-01 ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N: --------------------------------------------------- I EPSILON(I) DELTA(I,1) DELTA(I,2) 1 0.23071990D-02 -0.69501229D-02 0.35591065D-02 2 -0.18256324D-01 0.55132025D-01 -0.16914324D-01 3 0.21586476D-01 -0.65074400D-01 0.11658612D-01 4 0.31241338D-02 -0.93540286D-02 0.99921329D-03 5 0.64041532D-02 -0.19329534D-01 0.98682959D-02 6 0.28227936D-02 -0.84860281D-02 0.25775633D-02 7 -0.11911006D-01 0.35997432D-01 -0.65131655D-02 8 0.57192617D-03 -0.16711050D-02 0.30126130D-03 9 -0.22909059D-02 0.68901239D-02 -0.35429853D-02 10 -0.52747995D-02 0.15936835D-01 -0.48603477D-02 11 -0.13712070D-01 0.41421720D-01 -0.74992763D-02 12 0.84341831D-02 -0.25412302D-01 0.45714272D-02 13 0.96307387D-02 -0.29030592D-01 0.57946194D-02 *** COMPARISON OF NEW RESULTS WITH DOUBLE PRECISION CDC CYBER 205 RESULT *** NORM OF BETA SUM OF SQUARED WTD OBS ERRORS INFO CDC CYBER 205 RESULT = 0.426132182951397897596734765102D+01 0.147796721039842073042169801056D-01 4 NEW TEST RESULT = 0.426132182951397897596734765102D+01 0.147796721039841639361300806854D-01 4 DIFFERENCE = 0.000000000000000000000000000000D+00 0.433680868994201773602981120348D-16 0 NEW STOPPING CONDITION AND EXPECTED STOPPING CONDITION AGREE, BUT INDICATE CONVERGENCE WAS NOT ATTAINED. NO FURTHER COMPARISONS WILL BE MADE BETWEEN NEW AND EXPECTED RESULTS. 1EXAMPLE 7 TEST RESTART FOR UNSCALED ODR PROBLEM WITH ANALYTIC DERIVATIVES USING DODRC. DATA SET REFERENCE: HIMMELBLAU, 1970, EXAMPLE 6.2-4, PAGE 188 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* RESTART OF FIT BY METHOD OF ODR =============================== ITERATION REPORTS FOR FIT BY METHOD OF ODR ========================================== CUM. ACT. REL. PRED. REL. IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS G-N NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION TAU/PNORM STEP ---- ------ ----------- ----------- ----------- --------- ---- 3 16 0.14780D-01 0.7336D-06 0.7486D-06 0.841D-03 YES 4 17 0.14780D-01 0.4552D-09 0.4693D-09 0.243D-04 YES 5 18 0.14780D-01 0.4425D-12 0.4537D-12 0.701D-06 YES 6 19 0.14780D-01 -0.6850D-15 0.4718D-15 0.335D-07 YES FINAL SUMMARY FOR FIT BY METHOD OF ODR ====================================== STOPPING CONDITION (INFO = 1): ----------------------------------- THE RELATIVE CHANGE IN THE SUM OF THE SQUARED WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL CONDITION NUMBER OF NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS JAC EVALS (INVERSE) DEFICIENCY 6 20 9 0.2280D+00 0 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.14779661D-01 SUM OF SQUARED WEIGHTED DELTAS 0.13392301D-01 SUM OF SQUARED WEIGHTED EPSILONS 0.13873605D-02 ESTIMATED RESIDUAL VARIANCE 0.14779661D-02 ( 10 DEGREES OF FREEDOM) ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- J BETA(J) STD. DEV. BETA(J) 1 0.30212247D+01 0.36886262D-01 2 0.29588200D+01 0.83316569D-01 3 -0.52538288D+00 0.30448902D-01 ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N: --------------------------------------------------- I EPSILON(I) DELTA(I,1) DELTA(I,2) 1 0.22986990D-02 -0.69448862D-02 0.35666690D-02 2 -0.18241253D-01 0.55110925D-01 -0.16917585D-01 3 0.21554517D-01 -0.65121041D-01 0.11644852D-01 4 0.31076969D-02 -0.93890508D-02 0.99837258D-03 5 0.63905056D-02 -0.19307154D-01 0.98826815D-02 6 0.28129008D-02 -0.84984056D-02 0.25821939D-02 7 -0.11910569D-01 0.35984505D-01 -0.64963209D-02 8 0.55980350D-03 -0.16912922D-02 0.30424180D-03 9 -0.22890884D-02 0.69158505D-02 -0.35650902D-02 10 -0.52764814D-02 0.15941436D-01 -0.48627008D-02 11 -0.13711291D-01 0.41424893D-01 -0.74823551D-02 12 0.84120397D-02 -0.25414662D-01 0.45615579D-02 13 0.96077621D-02 -0.29027208D-01 0.57834834D-02 *** COMPARISON OF NEW RESULTS WITH DOUBLE PRECISION CDC CYBER 205 RESULT *** NORM OF BETA SUM OF SQUARED WTD OBS ERRORS INFO CDC CYBER 205 RESULT = 0.426127230714288618429463895154D+01 0.147796612546537437654636804041D-01 1 NEW TEST RESULT = 0.426127230550321378643729985924D+01 0.147796612546536691723542134014D-01 1 DIFFERENCE = 0.163967239785733909229747951031D-08 0.745931094670027050597127526999D-16 0 NEW RESULTS AND EXPECTED RESULTS AGREE TO WITHIN STOPPING TOLERANCE OF NEW RESULTS. 1EXAMPLE 8 TEST USE OF TAUFAC TO RESTRICT FIRST STEP FOR ODR PROBLEM WITH FINITE DIFFERENCE DERIVATIVES USING DODRC. DATA SET REFERENCE: POWELL AND MACDONALD, 1972, TABLES 7 & 8, PAGES 153-154 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* INITIAL SUMMARY FOR FIT BY METHOD OF ODR ======================================== PROBLEM SIZE: ------------- NUMBER OF OBSERVATIONS 14 NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS 14 NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE 1 NUMBER OF FUNCTION PARAMETERS 3 NUMBER OF UNFIXED FUNCTION PARAMETERS 3 INDEPENDENT VARIABLE AND DELTA WEIGHT SUMMARY: ---------------------------------------------- COLUMN 1 OBS 1 OBS N X - 0.10000D+01 0.14000D+02 FIXED - NO NO INITIAL DELTA - 0.00000D+00 0.00000D+00 DELTA SCALE - 0.10000D+01 0.71429D-01 DELTA WEIGHTS - 0.10000D+01 0.10000D+01 DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT SUMMARY: ---------------------------------------------------------- OBS 1 OBS N Y - 0.26380D+02 0.22220D+02 OBS. ERROR WTS. - 0.10000D+01 0.10000D+01 FUNCTION PARAMETER SUMMARY: --------------------------- INDEX - 1 2 3 INITIAL BETA - 0.25000000D+02 0.30000000D+02 0.60000000D+01 FIXED - NO NO NO BETA SCALE - 0.33333333D-01 0.33333333D-01 0.33333333D-01 CONTROL VALUES AND STOPPING CRITERIA: -------------------------------------- * JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT 00200 15 0.10D-01 0.15D-07 0.37D-10 50 * A. FIT IS NOT A RESTART. B. DELTAS ARE INITIALIZED TO ZERO. C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS WILL NOT BE COMPUTED AT THE SOLUTION. D. DERIVATIVES ARE COMPUTED BY FINITE DIFFERENCES. E. FIT IS BY METHOD OF ORTHOGONAL DISTANCE REGRESSION. INITIAL SUMS OF SQUARES: ------------------------ SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.66518388D+02 SUM OF SQUARED WEIGHTED DELTAS 0.00000000D+00 SUM OF SQUARED WEIGHTED EPSILONS 0.66518388D+02 ITERATION REPORTS FOR FIT BY METHOD OF ODR ========================================== CUM. ACT. REL. PRED. REL. IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS G-N NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION TAU/PNORM STEP ---- ------ ----------- ----------- ----------- --------- ---- 1 19 0.16530D-02 0.1000D+01 0.1000D+01 0.191D+00 YES 2 25 0.11444D-02 0.3077D+00 0.3077D+00 0.574D-02 YES 3 31 0.11444D-02 0.2853D-05 0.2859D-05 0.449D-04 YES 4 37 0.11444D-02 0.9187D-10 0.9551D-10 0.765D-06 YES FINAL SUMMARY FOR FIT BY METHOD OF ODR ====================================== STOPPING CONDITION (INFO = 1): ----------------------------------- THE RELATIVE CHANGE IN THE SUM OF THE SQUARED WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL CONDITION NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS (INVERSE) DEFICIENCY 4 38 0.5379D-02 0 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.11444195D-02 SUM OF SQUARED WEIGHTED DELTAS 0.12503306D-03 SUM OF SQUARED WEIGHTED EPSILONS 0.10193864D-02 ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- INDEX VALUE --------------> 1 TO 3 0.27116749D+02 0.33642704D+02 0.66212191D+01 ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N: --------------------------------------------------- I EPSILON(I) DELTA(I,1) 1 0.75980088D-02 0.49754064D-02 2 0.73916414D-03 0.40657864D-03 3 -0.69419662D-02 -0.32815811D-02 4 -0.17131940D-01 -0.70839174D-02 5 -0.78479213D-02 -0.28757569D-02 6 0.38954447D-02 0.12796037D-02 7 0.10856769D-01 0.32281389D-02 8 0.72331159D-02 0.19628241D-02 9 0.72270110D-02 0.18017788D-02 10 0.76228838D-02 0.17561882D-02 11 0.57454143D-02 0.12294168D-02 12 -0.63416858D-03 -0.12660978D-03 13 -0.37179098D-02 -0.69524195D-03 14 -0.14659176D-01 -0.25768282D-02 *** COMPARISON OF NEW RESULTS WITH DOUBLE PRECISION CDC CYBER 205 RESULT *** NORM OF BETA SUM OF SQUARED WTD OBS ERRORS INFO CDC CYBER 205 RESULT = 0.437148731790976299294015916530D+02 0.114441947440828612793384255752D-02 1 NEW TEST RESULT = 0.437148734934687155373467248864D+02 0.114441947440838348928893175582D-02 1 DIFFERENCE = 0.314371085607945133233442902565D-06 0.973613550891982981738692615181D-16 0 NEW RESULTS AND EXPECTED RESULTS AGREE TO WITHIN STOPPING TOLERANCE OF NEW RESULTS. 1EXAMPLE 9 TEST DETECTION OF QUESTIONABLE ANALYTIC DERIVATIVES FOR OLS PROBLEM USING DODRC. DATA SET REFERENCE: POWELL AND MACDONALD, 1972, TABLES 7 & 8, PAGES 153-154 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF OLS =================================================== * DERIVATIVE DERIVATIVE WRT ASSESSMENT BETA( 1) QUESTIONABLE (3) BETA( 2) QUESTIONABLE (3) BETA( 3) QUESTIONABLE (3) * NUMBERS IN PARENTHESES REFER TO THE FOLLOWING NOTES. (3) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES DISAGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE USER-SUPPLIED DERIVATIVE IS IDENTICALLY ZERO. NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS 15 NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR USER-SUPPLIED DERIVATIVE TO BE CONSIDERED CORRECT 4 ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED 1 -VALUES OF THE INDEPENDENT VARIABLES AT THIS ROW X( 1, 1) 0.10000000D+01 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* INITIAL SUMMARY FOR FIT BY METHOD OF OLS ======================================== PROBLEM SIZE: ------------- NUMBER OF OBSERVATIONS 14 NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS 14 NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE 1 NUMBER OF FUNCTION PARAMETERS 3 NUMBER OF UNFIXED FUNCTION PARAMETERS 3 INDEPENDENT VARIABLE SUMMARY: ----------------------------- COLUMN 1 OBS 1 OBS N X - 0.10000D+01 0.14000D+02 DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT SUMMARY: ---------------------------------------------------------- OBS 1 OBS N Y - 0.26380D+02 0.22220D+02 OBS. ERROR WTS. - 0.10000D+01 0.10000D+01 FUNCTION PARAMETER SUMMARY: --------------------------- INDEX - 1 2 3 INITIAL BETA - 0.25000000D+02 0.30000000D+02 0.60000000D+01 FIXED - NO NO NO BETA SCALE - 0.33333333D-01 0.33333333D-01 0.33333333D-01 CONTROL VALUES AND STOPPING CRITERIA: -------------------------------------- * JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT 00011 15 0.10D+01 0.15D-07 0.37D-10 50 * A. FIT IS NOT A RESTART. B. DELTAS ARE FIXED AT ZERO. C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS WILL BE COMPUTED AT THE SOLUTION. D. DERIVATIVES ARE SUPPLIED BY USER. USER-SUPPLIED DERIVATIVES WERE CHECKED. THE CORRECTNESS OF SOME OF THE DERIVATIVES IS QUESTIONABLE. SEE ERROR MESSAGES FOR DETAILS. E. FIT IS BY METHOD OF ORDINARY LEAST SQUARES. INITIAL SUMS OF SQUARES: ------------------------ SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.66518388D+02 ITERATION REPORTS FOR FIT BY METHOD OF OLS ========================================== CUM. ACT. REL. PRED. REL. IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS G-N NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION TAU/PNORM STEP ---- ------ ----------- ----------- ----------- --------- ---- 1 14 0.66518D+02 0.4337D-16 0.0000D+00 0.000D+00 YES FINAL SUMMARY FOR FIT BY METHOD OF OLS ====================================== STOPPING CONDITION (INFO = 1023): ----------------------------------- THE RELATIVE CHANGE IN THE SUM OF THE SQUARED WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL AND THE RELATIVE CHANGE IN THE NORM OF BETA AND DELTA IS LESS THAN PARTOL NOTE: THE RESULTS FROM ODRPACK ARE QUESTIONABLE BECAUSE THE ODRPACK JACOBIAN MATRIX CHECKING PROCEDURE HAS DETERMINED THAT THE CORRECTNESS OF THE USER-SUPPLIED JACOBIAN MATRICES IS QUESTIONABLE, AND THE RESULTS OF THE MODEL FUNCTION AND/OR ITS DERIVATIVES ARE UNAFFECTED BY CHANGES IN THE UNFIXED FUNCTION PARAMETERS (BETA), INDICATING A PROBABLE ERROR IN USER-SUPPLIED SUBROUTINES FUN AND/OR JAC. CONDITION NUMBER OF NUMBER OF NUMBER OF NUMBER RANK ITERATIONS FN EVALS JAC EVALS (INVERSE) DEFICIENCY 1 15 2 0.0000D+00 3 FINAL SUMS OF SQUARES: ---------------------- SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS 0.66518388D+02 ESTIMATED BETA(J), J = 1, ..., NP: ---------------------------------- N.B. STANDARD ERRORS OF THE ESTIMATED BETAS WERE NOT COMPUTED BECAUSE EITHER THE JACOBIAN IS NOT FULL RANK AT THE SOLUTION, OR THE MOST RECENTLY TRIED VALUES OF BETA AND/OR X+DELTA WERE UNACCEPTABLE. INDEX VALUE --------------> 1 TO 3 0.25000000D+02 0.30000000D+02 0.60000000D+01 ESTIMATED EPSILON(I), I = 1, ..., N: ------------------------------------ INDEX VALUE --------------> 1 TO 4 -0.21282471D+01 -0.21533820D+01 -0.21736101D+01 -0.21929715D+01 5 TO 8 -0.21875320D+01 -0.21785356D+01 -0.21741444D+01 -0.21804623D+01 9 TO 12 -0.21821673D+01 -0.21829206D+01 -0.21856378D+01 -0.21926777D+01 13 TO 14 -0.21959733D+01 -0.22071284D+01 *** COMPARISON OF NEW RESULTS WITH DOUBLE PRECISION CDC CYBER 205 RESULT *** NORM OF BETA SUM OF SQUARED WTD OBS ERRORS INFO CDC CYBER 205 RESULT = 0.395094925302768231745176308323D+02 0.665183875083491074065022985451D+02 1023 NEW TEST RESULT = 0.395094925302768231745176308323D+02 0.665183875083490931956475833431D+02 1023 DIFFERENCE = 0.000000000000000000000000000000D+00 0.142108547152020037174224853516D-13 0 NEW RESULTS AND EXPECTED RESULTS AGREE TO WITHIN STOPPING TOLERANCE OF NEW RESULTS. 1EXAMPLE 10 TEST DETECTION OF INCORRECT ANALYTIC DERIVATIVES FOR ODR PROBLEM WITH ANALYTIC DERIVATIVES USING DODRC. DATA SET REFERENCE: POWELL AND MACDONALD, 1972, TABLES 7 & 8, PAGES 153-154 ******************************************************* * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * ******************************************************* DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ODR =================================================== * DERIVATIVE DERIVATIVE WRT ASSESSMENT BETA( 1) QUESTIONABLE (3) BETA( 2) QUESTIONABLE (3) BETA( 3) QUESTIONABLE (3) X( 1, 1) INCORRECT * NUMBERS IN PARENTHESES REFER TO THE FOLLOWING NOTES. (3) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES DISAGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE USER-SUPPLIED DERIVATIVE IS IDENTICALLY ZERO. NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS 15 NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR USER-SUPPLIED DERIVATIVE TO BE CONSIDERED CORRECT 4 ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED 1 -VALUES OF THE INDEPENDENT VARIABLES AT THIS ROW X( 1, 1) 0.10000000D+01 *** COMPARISON OF NEW RESULTS WITH DOUBLE PRECISION CDC CYBER 205 RESULT *** NORM OF BETA SUM OF SQUARED WTD OBS ERRORS INFO CDC CYBER 205 RESULT = 0.395094925302768231745176308323D+02 0.665183875083491074065022985451D+02 40100 NEW TEST RESULT = 0.395094925302768231745176308323D+02 0.665183875083490931956475833431D+02 40100 DIFFERENCE = 0.000000000000000000000000000000D+00 0.142108547152020037174224853516D-13 0 NEW STOPPING CONDITION AND EXPECTED STOPPING CONDITION AGREE, BUT INDICATE CONVERGENCE WAS NOT ATTAINED. NO FURTHER COMPARISONS WILL BE MADE BETWEEN NEW AND EXPECTED RESULTS. *DACCES SUBROUTINE DACCES + (N,M,NP,WORK,LWORK,IWORK,LIWORK, + ACCESS, + JPVT,WRK1,TFJACB,OMEGA,YT,U,QRAUX,WRK2, + NNZW,NPP, + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,EPSMAC,NETA, + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS) C***BEGIN PROLOGUE DACCES C***REFER TO DODR,DODRC C***ROUTINES CALLED DIWINF,DWINF C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE ACCESS OR STORE VALUES IN THE WORK ARRAYS C***END PROLOGUE DACESS * C...SCALAR ARGUMENTS DOUBLE PRECISION + ACTRS,ALPHA,EPSMAC,OLMAVG,PARTOL,PNORM,PRERS,RCOND, + RNORMS,RVAR,SSTOL,TAU,TAUFAC,WSS,WSSDEL,WSSEPS INTEGER + IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,JOB,JPVT,LIWORK,LUNRPT, + LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV,NNZW,NP,NPP,OMEGA, + QRAUX,TFJACB,U,WRK1,WRK2,YT LOGICAL + ACCESS * C...ARRAY ARGUMENTS DOUBLE PRECISION + WORK(LWORK) INTEGER + IWORK(LIWORK) * C...LOCAL SCALARS INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,DDELTI,DELTAI,DELTNI,DELTSI, + EPSMAI,ETAI,FI,FJACBI,FJACXI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT, + IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI, + MSGB,MSGX,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI,NTOLI, + OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,RNORSI,RVARI, + SI,SSFI,SSI,SSSI,SSTOLI,TAUFCI,TAUI,TFJACI,TI,TTI,UI,WRK1I, + WRK2I,WSSI,WSSDEI,WSSEPI,XPLUSI,YTI * C...EXTERNAL SUBROUTINES EXTERNAL + DIWINF,DWINF * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION ACTRS C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER ACTRSI C THE LOCATION IN ARRAY WORK OF C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C INTEGER ALPHAI C THE LOCATION IN ARRAY WORK OF C THE LEVENBERG-MARQUARDT PARAMETER. C INTEGER BETACI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETANI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETASI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER DDELTI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (W*D)**2 * DELTA. C INTEGER DELTAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C DOUBLE PRECISION EPSMAC C THE VALUE OF MACHINE PRECISION. C INTEGER EPSMAI C THE LOCATION IN ARRAY WORK OF C THE VALUE OF MACHINE PRECISION. C INTEGER ETAI C THE LOCATION IN ARRAY WORK OF C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C INTEGER FI C THE STARTING LOCATION IN ARRAY WORK OF C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FJACBI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO BETA. C INTEGER FJACXI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO X. C INTEGER FNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER IDF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IDFI C THE STARTING LOCATION IN ARRAY IWORK OF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER INT2 C THE NUMBER OF INTERNAL DOUBLING STEPS. C INTEGER INT2I C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF INTERNAL DOUBLING STEPS. C INTEGER IPR1 C THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE INITIAL SUMMARY REPORT. C INTEGER IPR2 C THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE ITERATION REPORTS. C INTEGER IPR2F C THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. C INTEGER IPR3 C THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FINAL SUMMARY REPORT. C INTEGER IPRINI C THE LOCATION IN ARRAY IWORK OF C THE PRINT CONTROL VARIABLE. C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C INTEGER IRANKI C THE LOCATION IN ARRAY IWORK OF C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOBI C THE LOCATION IN ARRAY IWORK OF C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C INTEGER JPVT C THE STARTING LOCATION IN ARRAY IWORK OF C THE PIVOT VECTOR. C INTEGER JPVTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE PIVOT VECTOR. C INTEGER LDTTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNERI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXITI C THE LOCATION IN ARRAY IWORK OF C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MSGB C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NETAI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NFEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NITERI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NJEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NNZW C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NNZWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C INTEGER NPPI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C INTEGER NROWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTOLI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C TO BE SET BY DJCK. C DOUBLE PRECISION OLMAVG C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OLMAVI C THE LOCATION IN ARRAY WORK OF C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OMEGA C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C INTEGER OMEGAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C INTEGER PARTLI C THE LOCATION IN ARRAY WORK OF C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C DOUBLE PRECISION PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION PNORM C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C INTEGER PNORMI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C DOUBLE PRECISION PRERS C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER PRERSI C THE LOCATION IN ARRAY WORK OF C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER QRAUX C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C INTEGER QRAUXI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C DOUBLE PRECISION RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C INTEGER RCONDI C THE LOCATION IN ARRAY WORK OF C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C DOUBLE PRECISION RNORMS C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C INTEGER RNORSI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION RVAR C THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. C INTEGER RVARI C THE LOCATION IN ARRAY WORK OF C THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. C DOUBLE PRECISION SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS C INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG- C CALL (SHORT=.FALSE.). C INTEGER SI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED BETA'S. C INTEGER SSFI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE BETA'S. C INTEGER SSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE ESTIMATED BETA'S. C INTEGER SSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C DOUBLE PRECISION SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SSTOLI C THE LOCATION IN ARRAY WORK OF C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C DOUBLE PRECISION TAU C THE TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER TAUFCI C THE LOCATION IN ARRAY WORK OF C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C INTEGER TAUI C THE LOCATION IN ARRAY WORK OF C THE TRUST REGION DIAMETER. C INTEGER TFJACB C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER TFJACI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER TI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED DELTA'S. C INTEGER TTI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE DELTA'S. C INTEGER U C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR TFJACB. C INTEGER UI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR TFJACB. C DOUBLE PRECISION WORK(LWORK) C THE DOUBLE PRECISION WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER WRK1 C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WRK1I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WRK2 C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WRK2I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C DOUBLE PRECISION WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C INTEGER WSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C INTEGER WSSDEI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C DOUBLE PRECISION WSSDEL C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C INTEGER WSSEPI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C DOUBLE PRECISION WSSEPS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C INTEGER XPLUSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY X + DELTA. C INTEGER YT C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C INTEGER YTI C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). * * C***FIRST EXECUTABLE STATEMENT DACCES * * C FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE * CALL DIWINF(M,NP, + MSGB,MSGX,JPVTI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) * C FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE * CALL DWINF(N,M,NP, + DELTAI,FI, + WSSI,WSSDEI,WSSEPI,RVARI, + PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI, + FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,DELTSI, + DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,TAUI, + ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,RCONDI, + ETAI,ACTRSI,PNORMI,PRERSI,RNORSI, + LWKMN) * IF (ACCESS) THEN * C SET STARTING LOCATIONS FOR WORK VECTORS * JPVT = JPVTI WRK1 = WRK1I TFJACB = TFJACI OMEGA = OMEGAI YT = YTI U = UI QRAUX = QRAUXI WRK2 = WRK2I * C ACCESS VALUES FROM THE WORK VECTORS * ACTRS = WORK(ACTRSI) ALPHA = WORK(ALPHAI) EPSMAC = WORK(EPSMAI) OLMAVG = WORK(OLMAVI) PARTOL = WORK(PARTLI) PNORM = WORK(PNORMI) PRERS = WORK(PRERSI) RCOND = WORK(RCONDI) WSS = WORK(WSSI) WSSDEL = WORK(WSSDEI) WSSEPS = WORK(WSSEPI) RVAR = WORK(RVARI) RNORMS = WORK(RNORSI) SSTOL = WORK(SSTOLI) TAU = WORK(TAUI) TAUFAC = WORK(TAUFCI) * NETA = IWORK(NETAI) IRANK = IWORK(IRANKI) JOB = IWORK(JOBI) LUNRPT = IWORK(LUNRPI) MAXIT = IWORK(MAXITI) NFEV = IWORK(NFEVI) NITER = IWORK(NITERI) NJEV = IWORK(NJEVI) NNZW = IWORK(NNZWI) NPP = IWORK(NPPI) IDF = IWORK(IDFI) INT2 = IWORK(INT2I) * C SET UP PRINT CONTROL VARIABLES * IPRINT = IWORK(IPRINI) * IPR1 = MOD(IPRINT,10000)/1000 IPR2 = MOD(IPRINT,1000)/100 IPR2F = MOD(IPRINT,100)/10 IPR3 = MOD(IPRINT,10) * ELSE * C STORE VALUES INTO THE WORK VECTORS * WORK(ACTRSI) = ACTRS WORK(ALPHAI) = ALPHA WORK(OLMAVI) = OLMAVG WORK(PARTLI) = PARTOL WORK(PNORMI) = PNORM WORK(PRERSI) = PRERS WORK(RCONDI) = RCOND WORK(WSSI) = WSS WORK(WSSDEI) = WSSDEL WORK(WSSEPI) = WSSEPS WORK(RVARI) = RVAR WORK(RNORSI) = RNORMS WORK(SSTOLI) = SSTOL WORK(TAUI) = TAU * IWORK(IRANKI) = IRANK IWORK(NFEVI) = NFEV IWORK(NITERI) = NITER IWORK(NJEVI) = NJEV IWORK(IDFI) = IDF IWORK(INT2I) = INT2 END IF * RETURN END *DDIAGI SUBROUTINE DDIAGI + (N,M,S,LDS,V,LDV,SV,LDSV) C***BEGIN PROLOGUE DDIAGI C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SCALE THE VECTOR V BY THE INVERSE OF THE DIAGONAL MATRIX S C AND RETURN THE RESULT IN VECTOR SV C***END PROLOGUE DDIAGI * C...SCALAR ARGUMENTS INTEGER + LDS,LDSV,LDV,M,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + S(LDS,M),SV(LDSV,M),V(LDV,M) * C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + I,J * C...INTRINSIC FUNCTIONS INTRINSIC + ABS * C...DATA STATEMENTS DATA + ZERO + /0.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDS C THE LEADING DIMENSION OF ARRAY S. C INTEGER LDSV C THE LEADING DIMENSION OF ARRAY SV. C INTEGER LDV C THE LEADING DIMENSION OF ARRAY V. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION S(LDS,M) C THE SCALING ARRAY. C DOUBLE PRECISION SV(LDSV,M) C THE INVERSE SCALED ARRAY. C DOUBLE PRECISION V(LDV,M) C THE ARRAY BEING SCALED. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DDIAGI * * IF (N.EQ.0 .OR. M.EQ.0) RETURN * IF (S(1,1).LT.ZERO) THEN DO 20 J=1,M DO 10 I = 1,N SV(I,J) = V(I,J)/ABS(S(1,1)) 10 CONTINUE 20 CONTINUE ELSE IF (LDS.EQ.1) THEN DO 40 J=1,M DO 30 I=1,N SV(I,J) = V(I,J)/S(1,J) 30 CONTINUE 40 CONTINUE ELSE DO 60 J=1,M DO 50 I=1,N SV(I,J) = V(I,J)/S(I,J) 50 CONTINUE 60 CONTINUE END IF END IF * RETURN END *DDIAGS SUBROUTINE DDIAGS + (N,M,S,LDS,V,LDV,SV,LDSV) C***BEGIN PROLOGUE DDIAGS C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SCALE THE VECTOR V BY THE DIAGONAL MATRIX S C AND RETURN THE RESULT IN VECTOR SV. C***END PROLOGUE DDIAGS * C...SCALAR ARGUMENTS INTEGER + LDS,LDSV,LDV,M,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + S(LDS,M),SV(LDSV,M),V(LDV,M) * C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + I,J * C...INTRINSIC FUNCTIONS INTRINSIC + ABS * C...DATA STATEMENTS DATA + ZERO + /0.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDS C THE LEADING DIMENSION OF ARRAY S. C INTEGER LDSV C THE LEADING DIMENSION OF ARRAY SV. C INTEGER LDV C THE LEADING DIMENSION OF ARRAY V. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION S(LDS,M) C THE SCALING ARRAY. C DOUBLE PRECISION SV(LDSV,M) C THE SCALED ARRAY. C DOUBLE PRECISION V(LDV,M) C THE ARRAY BEING SCALED. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DDIAGS * * IF (N.EQ.0 .OR. M.EQ.0) RETURN * IF (S(1,1).LT.ZERO) THEN DO 20 J=1,M DO 10 I=1,N SV(I,J) = ABS(S(1,1))*V(I,J) 10 CONTINUE 20 CONTINUE ELSE IF (LDS.EQ.1) THEN DO 40 J=1,M DO 30 I=1,N SV(I,J) = S(1,J)*V(I,J) 30 CONTINUE 40 CONTINUE ELSE DO 60 J=1,M DO 50 I=1,N SV(I,J) = S(I,J)*V(I,J) 50 CONTINUE 60 CONTINUE END IF END IF * RETURN END *DDIAGW SUBROUTINE DDIAGW + (N,M,W,V,LDV,WV,LDWV) C***BEGIN PROLOGUE DDIAGW C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SCALE THE N BY M ARRAY V BY THE DIAGONAL OBSERVATIONAL C ERROR WEIGHT MATRIX W AND RETURN THE RESULT IN VECTOR WV. C N.B. IF THE FIRST ELEMENT OF W IS NEGATIVE, THE DEFAULT C WEIGHTING OF ONE FOR ALL ELEMENTS WILL BE INVOKED, I.E., C THE RESULTS WILL BE "UNWEIGHTED." C***END PROLOGUE DDIAGW * C...SCALAR ARGUMENTS INTEGER + LDV,LDWV,M,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + V(LDV,M),W(N),WV(LDWV,M) * C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + I,J * C...DATA STATEMENTS DATA + ZERO + /0.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDV C THE LEADING DIMENSION OF ARRAY V. C INTEGER LDWV C THE LEADING DIMENSION OF ARRAY WV. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION V(LDV,M) C THE ARRAY BEING WEIGHTED. C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C DOUBLE PRECISION WV(LDWV,M) C THE WEIGHTED ARRAY. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DDIAGW * * IF (N.EQ.0 .OR. M.EQ.0) RETURN * IF (W(1).LT.ZERO) THEN DO 20 J=1,M DO 10 I=1,N WV(I,J) = V(I,J) 10 CONTINUE 20 CONTINUE ELSE DO 40 J=1,M DO 30 I=1,N WV(I,J) = W(I)*V(I,J) 30 CONTINUE 40 CONTINUE END IF * RETURN END *DETAF SUBROUTINE DETAF + (FUN,NFEV,N,NP,M,XPLUSD,LDXPD,BETA,ETA,NETA,EPSMAC, + NROW,PARTMP,PVTEMP,ISTOP) C***BEGIN PROLOGUE DETAF C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE ETAFUN) C***END PROLOGUE DETAF * C...SCALAR ARGUMENTS DOUBLE PRECISION + EPSMAC,ETA INTEGER + ISTOP,LDXPD,M,N,NETA,NFEV,NP,NROW * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),PARTMP(NP),PVTEMP(N),XPLUSD(LDXPD,M) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS DOUBLE PRECISION + A,B,FAC,J,ONE,P1,P2,RSSSM,RSSSMJ,SQRTMP,ZERO INTEGER + I,K * C...LOCAL ARRAYS DOUBLE PRECISION + RSS(5) * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,INT,LOG10,MAX,SQRT * C...DATA STATEMENTS DATA + ZERO,P1,P2,ONE + /0.0D0,0.1D0,0.2D0,1.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION A C PARAMETERS OF THE FIT. C DOUBLE PRECISION B C PARAMETERS OF THE FIT. C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION EPSMAC C THE VALUE OF MACHINE PRECISION. C DOUBLE PRECISION ETA C THE NOISE IN THE MODEL RESULTS. C DOUBLE PRECISION FAC C A FACTOR USED IN THE COMPUTATIONS. C INTEGER I C AN INDEXING VARIABLE. C INTEGER ISTOP C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE C USER WISHES THE COMPUTATIONS STOPPED. C DOUBLE PRECISION J C THE VALUE FLOAT(I-3). C INTEGER K C AN INDEX VARIABLE. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION P1 C THE VALUE 0.1D0. C DOUBLE PRECISION P2 C THE VALUE 0.2D0. C DOUBLE PRECISION PARTMP(NP) C MODIFIED MODEL PARAMETERS C DOUBLE PRECISION PVTEMP(N) C PREDICTED VALUES C DOUBLE PRECISION RSS(5) C THE RESIDUAL SUM OF SQUARES FOR EACH VALUE OF J. C DOUBLE PRECISION RSSSM C THE SUM OF THE RESIDUAL SUM OF SQUARES FOR EACH SET OF C PARAMETER VALUES. C DOUBLE PRECISION RSSSMJ C THE SUM OF THE RESIDUAL SUM OF SQUARES TIMES J FOR EACH C SET OF PARAMETER VALUES. C DOUBLE PRECISION SQRTMP C THE SQUARE ROOT OF MACHINE PRECISION (EPSMAC). C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DETAF * * SQRTMP = SQRT(EPSMAC) RSSSM = ZERO RSSSMJ = ZERO DO 20 I=1,5 J = I-3 DO 10 K=1,NP PARTMP(K) = BETA(K)*(ONE+J*SQRTMP) 10 CONTINUE ISTOP = 0 CALL FUN(N,NP,M,PARTMP,XPLUSD,LDXPD,PVTEMP,ISTOP) NFEV = NFEV + 1 IF (ISTOP.NE.0) THEN RETURN END IF * RSS(I) = PVTEMP(NROW) * RSSSM = RSSSM + RSS(I) RSSSMJ = RSSSMJ + J*RSS(I) 20 CONTINUE A = P2*RSSSM B = P1*RSSSMJ IF (RSS(3).NE.ZERO) THEN FAC = ONE/ABS(RSS(3)) ELSE FAC = ONE END IF DO 30 I=1,5 J = I-3 RSS(I) = ABS((RSS(I)-(A+J*B))*FAC) 30 CONTINUE ETA = MAX(RSS(1),RSS(2),RSS(3),RSS(4),RSS(5),EPSMAC) NETA = INT(-LOG10(ETA)) * RETURN END *DEVFUN SUBROUTINE DEVFUN + (N,NP,M,BETAC,BETA,IFIXB,FUN, + X,LDX,Y,DELTA,LDDELT,XPLUSD,LDXPD, + W,F,NFEV,ISTOP) C***BEGIN PROLOGUE DEVFUN C***REFER TO DODR,DODRC C***ROUTINES CALLED DAXPY,DDIAGW,DUNPAC,DXPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE THE WEIGHTED EPSILON'S FOR THE CURRENT POINT C***END PROLOGUE DEVFUN * C...SCALAR ARGUMENTS INTEGER + ISTOP,LDDELT,LDX,LDXPD,M,N,NFEV,NP * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),BETAC(NP),DELTA(LDDELT,M),F(N),W(N), + X(LDX,M),XPLUSD(LDXPD,M),Y(N) INTEGER + IFIXB(NP) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS DOUBLE PRECISION + NEGONE * C...EXTERNAL SUBROUTINES EXTERNAL + DAXPY,DDIAGW,DUNPAC,DXPY * C...DATA STATEMENTS DATA + NEGONE + /-1.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION BETAC(NP) C THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. C DOUBLE PRECISION DELTA(LDDELT,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C DOUBLE PRECISION F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER ISTOP C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE C USER WISHES THE COMPUTATIONS STOPPED. C INTEGER LDDELT C THE LEADING DIMENSION OF ARRAY DELTA. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION NEGONE C THE VALUE -1.0D0. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) * * C***FIRST EXECUTABLE STATEMENT DEVFUN * * C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA * CALL DUNPAC(NP,BETAC,BETA,IFIXB) * C COMPUTE XPLUSD = X + DELTA * CALL DXPY(N,M,X,LDX,DELTA,LDDELT,XPLUSD,LDXPD) * C EVALUATE THE PREDICTED VALUES OF THE FUNCTION FOR THE CURRENT POINT * ISTOP = 1 CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOP) IF (ISTOP.LT.0) THEN RETURN END IF * C INCREMENT COUNT OF NUMBER OF FUNCTION EVALUATIONS * NFEV = NFEV + 1 * C COMPUTE WEIGHTED EPSILONS FOR CURRENT POINT AND STORE IN F * CALL DAXPY(N,NEGONE,Y,1,F,1) CALL DDIAGW(N,1,W,F,N,F,N) * RETURN END *DEVJAC SUBROUTINE DEVJAC + (FUN,JAC,ANAJAC, + N,NP,NPP,M,BETAC,BETA,IFIXB,IFIXX,LDIFX, + X,LDX,DELTA,LDDELT,XPLUSD,LDXPD, + SS,TT,LDTT,NETA,PV,STP, + FJACB,LDFJB,ISODR,FJACX,LDFJX,W,NJEV,NFEV,ISTOP) C***BEGIN PROLOGUE DEVJAC C***REFER TO DODR,DODRC C***ROUTINES CALLED DDIAGW,DJACFD,DUNPAC,DXPY,DZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA C***END PROLOGUE DEVJAC * C...SCALAR ARGUMENTS INTEGER + ISTOP,LDDELT,LDFJB,LDFJX,LDIFX,LDTT,LDX,LDXPD,M,N,NETA,NFEV, + NJEV,NP,NPP LOGICAL + ANAJAC,ISODR * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),BETAC(NP),DELTA(LDDELT,M), + FJACB(LDFJB,NP),FJACX(LDFJX,M),PV(N),SS(NP), + STP(N),TT(LDTT,M),W(N),X(LDX,M),XPLUSD(LDXPD,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + I,J,JFX * C...EXTERNAL SUBROUTINES EXTERNAL + DDIAGW,DJACFD,DUNPAC,DXPY,DZERO * C...DATA STATEMENTS DATA + ZERO + /0.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE FUNCTION. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION BETAC(NP) C THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. C DOUBLE PRECISION DELTA(LDDELT,M) C THE ESTIMATED VALUES OF DELTA. C DOUBLE PRECISION FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C DOUBLE PRECISION FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO X. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER ISTOP C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE C USER WISHES THE COMPUTATIONS STOPPED. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER J C AN INDEXING VARIABLE. C INTEGER JFX C AN INDEXING VARIABLE. C INTEGER LDDELT C THE LEADING DIMENSION OF ARRAY DELTA. C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C DOUBLE PRECISION PV(N) C THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT C POINT. C DOUBLE PRECISION SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION STP(N) C THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES. C DOUBLE PRECISION TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DEVJAC * * C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA * CALL DUNPAC(NP,BETAC,BETA,IFIXB) * C COMPUTE XPLUSD = X + DELTA * CALL DXPY(N,M,X,LDX,DELTA,LDDELT,XPLUSD,LDXPD) * C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND C THE JACOBIAN WRT DELTA (FJACX) * ISTOP = 1 IF (ANAJAC) THEN CALL JAC(N,NP,M,BETA,XPLUSD,LDXPD, + FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOP) NJEV = NJEV+1 ELSE CALL DJACFD(N,NP,M,BETA, + X,LDX,DELTA,XPLUSD,LDXPD,FUN, + SS,TT,LDTT,NETA,PV,STP, + IFIXB,FJACB,LDFJB,ISODR, + IFIXX,LDIFX,FJACX,LDFJX,NFEV,ISTOP) END IF IF (ISTOP.LT.0) THEN RETURN END IF * C WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS * IF (ANAJAC) THEN JFX = 0 IF (IFIXB(1).GE.0) THEN DO 10 J=1,NP IF (IFIXB(J).NE.0) THEN JFX = JFX + 1 CALL DDIAGW(N,1,W,FJACB(1,J),LDFJB, + FJACB(1,JFX),LDFJB) END IF 10 CONTINUE ELSE DO 20 J=1,NP CALL DDIAGW(N,1,W,FJACB(1,J),LDFJB, + FJACB(1,J),LDFJB) 20 CONTINUE END IF ELSE DO 30 J=1,NPP CALL DDIAGW(N,1,W,FJACB(1,J),LDFJB, + FJACB(1,J),LDFJB) 30 CONTINUE END IF * C WEIGHT OR ZERO THE JACOBIAN'S WRT X AS APPROPRIATE * IF (ISODR) THEN IF (IFIXX(1,1).GE.0) THEN * C CHECK FOR POSSIBLY FIXED COLUMNS OR ELEMENTS OF X * IF (LDIFX.EQ.1) THEN DO 40 J=1,M IF (IFIXX(1,J).EQ.0) THEN * C ZERO JACOBIAN WRT X(I,J) FOR I=1,N * CALL DZERO(N,1,FJACX(1,J),LDFJX) ELSE * C WEIGHT JACOBIAN WRT X(I,J) FOR I=1,N * CALL DDIAGW(N,1,W,FJACX(1,J),LDFJX, + FJACX(1,J),LDFJX) END IF 40 CONTINUE ELSE * C WEIGHT JACOBIAN WRT X(I,J) FOR I=1,N AND C THEN ZERO APPROPRIATE ELEMENTS * DO 60 J=1,M CALL DDIAGW(N,1,W,FJACX(1,J),LDFJX, + FJACX(1,J),LDFJX) DO 50 I=1,N IF (IFIXX(I,J).EQ.0) THEN FJACX(I,J) = ZERO END IF 50 CONTINUE 60 CONTINUE END IF ELSE * C WEIGHT JACOBIAN WRT X(I,J) FOR I=1,N AND J=1,M * DO 70 J=1,M CALL DDIAGW(N,1,W,FJACX(1,J),LDFJX, + FJACX(1,J),LDFJX) 70 CONTINUE END IF ELSE * C ZERO ALL ELEMENTS OF FJACX FOR OLS FIT * CALL DZERO(N,M,FJACX,LDFJX) END IF * RETURN END *DFLAGS SUBROUTINE DFLAGS + (JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR,DOVCV) C***BEGIN PROLOGUE DFLAGS C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB C***END PROLOGUE DFLAGS * C...SCALAR ARGUMENTS INTEGER + JOB LOGICAL + ANAJAC,CHKJAC,DOVCV,INITD,ISODR,RESTRT * C...LOCAL SCALARS INTEGER + J * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER J C THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF JOB. C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). * * C***FIRST EXECUTABLE STATEMENT DFLAGS * * IF (JOB.GE.0) THEN RESTRT= JOB.GE.10000 INITD = MOD(JOB,10000)/1000.EQ.0 DOVCV = MOD(JOB,1000)/100.EQ.0 J = MOD(JOB,100)/10 IF (J.EQ.0) THEN ANAJAC = .FALSE. CHKJAC = .FALSE. ELSE IF (J.EQ.1) THEN ANAJAC = .TRUE. CHKJAC = .TRUE. ELSE ANAJAC = .TRUE. CHKJAC = .FALSE. END IF ISODR = MOD(JOB,10).EQ.0 ELSE RESTRT = .FALSE. INITD = .TRUE. DOVCV = .TRUE. ANAJAC = .FALSE. CHKJAC = .FALSE. ISODR = .TRUE. END IF * RETURN END *DIDTS SUBROUTINE DIDTS + (N,M,W,WD,LDWD,ALPHA,TT,LDTT,T,LDT,DTT,LDDTT) C***BEGIN PROLOGUE DIDTS C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SCALE MATRIX TT BY THE INVERSE OF DT, I.E., COMPUTE C DTT = T * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2, C W AND D ARE DEFINED BY EQ.2 OF THE PROLOGUE OF DODR C AND DODRC, AND TT IS THE SCALING MATRIX FOR THE DELTA'S, C ALSO DEFINED IN THE PROLOGUE OF DODR AND DODRC. C***END PROLOGUE DIDTS * C...SCALAR ARGUMENTS DOUBLE PRECISION + ALPHA INTEGER + LDDTT,LDT,LDTT,LDWD,M,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + DTT(LDDTT,M),T(LDT,M),TT(LDTT,M),W(N),WD(LDWD,M) * C...LOCAL SCALARS DOUBLE PRECISION + DT,ONE,TERM1,TERM2,ZERO INTEGER + I,J * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0D0,1.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C N.B. THE LOCATIONS OF W, WD AND TT ACCESSED DEPEND ON THE VALUE C OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSION C OF THE DOUBLY SUBSCRIPTED ARRAYS. C DOUBLE PRECISION ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C DOUBLE PRECISION DT C THE VALUE OF THE FACTOR DT = INV((W*D)**2+ALPHA*TT**2) C DOUBLE PRECISION DTT(LDDTT,M) C THE ARRAY DTT = T * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2. C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDDTT C THE LEADING DIMENSION OF ARRAY DTT. C INTEGER LDT C THE LEADING DIMENSION OF ARRAY T. C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION T(LDT,M) C THE STEP FOR THE ESTIMATED DELTA'S. C DOUBLE PRECISION TERM1 C THE VALUE OF THE TERM (W(I)*WD(I,J))**2 C DOUBLE PRECISION TERM2 C THE VALUE OF THE TERM ALPHA*TT(I,J)**2 C DOUBLE PRECISION TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DIDTS * * IF (N.EQ.0 .OR. M.EQ.0) RETURN * IF (W(1).GE.ZERO) THEN IF (WD(1,1).GT.ZERO) THEN IF (LDWD.GE.N) THEN IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 1120 J=1,M DO 1110 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/ + ((W(I)*WD(I,J))**2 + + ALPHA*TT(I,J)**2) ELSE DTT(I,J) = ZERO END IF 1110 CONTINUE 1120 CONTINUE ELSE DO 1140 J=1,M TERM2 = ALPHA*TT(1,J)**2 DO 1130 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/ + ((W(I)*WD(I,J))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1130 CONTINUE 1140 CONTINUE END IF ELSE TERM2 = ALPHA*TT(1,1)**2 DO 1160 J=1,M DO 1150 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/((W(I)*WD(I,J))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1150 CONTINUE 1160 CONTINUE END IF ELSE IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 1220 J=1,M DO 1210 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/ + ((W(I)*WD(1,J))**2 + + ALPHA*TT(I,J)**2) ELSE DTT(I,J) = ZERO END IF 1210 CONTINUE 1220 CONTINUE ELSE DO 1240 J=1,M TERM2 = ALPHA*TT(1,J)**2 DO 1230 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/ + ((W(I)*WD(1,J))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1230 CONTINUE 1240 CONTINUE END IF ELSE TERM2 = ALPHA*TT(1,1)**2 DO 1260 J=1,M DO 1250 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/((W(I)*WD(1,J))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1250 CONTINUE 1260 CONTINUE END IF END IF ELSE IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 1320 J=1,M DO 1310 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/ + ((W(I)*WD(1,1))**2 + + ALPHA*TT(I,J)**2) ELSE DTT(I,J) = ZERO END IF 1310 CONTINUE 1320 CONTINUE ELSE DO 1340 J=1,M TERM2 = ALPHA*TT(1,J)**2 DO 1330 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/((W(I)*WD(1,1))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1330 CONTINUE 1340 CONTINUE END IF ELSE TERM2 = ALPHA*TT(1,1)**2 DO 1360 J=1,M DO 1350 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/((W(I)*WD(1,1))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1350 CONTINUE 1360 CONTINUE END IF END IF ELSE IF (WD(1,1).GT.ZERO) THEN IF (LDWD.GE.N) THEN IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 2120 J=1,M DO 2110 I=1,N DTT(I,J) = T(I,J)/ + (WD(I,J)**2 + ALPHA*TT(I,J)**2) 2110 CONTINUE 2120 CONTINUE ELSE DO 2140 J=1,M TERM2 = ALPHA*TT(1,J)**2 DO 2130 I=1,N DTT(I,J) = T(I,J)/(WD(I,J)**2+TERM2) 2130 CONTINUE 2140 CONTINUE END IF ELSE TERM2 = ALPHA*TT(1,1)**2 DO 2160 J=1,M DO 2150 I=1,N DTT(I,J) = T(I,J)/(WD(I,J)**2+TERM2) 2150 CONTINUE 2160 CONTINUE END IF ELSE IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 2220 J=1,M TERM1 = WD(1,J)**2 DO 2210 I=1,N DTT(I,J) = T(I,J)/(TERM1+ALPHA*TT(I,J)**2) 2210 CONTINUE 2220 CONTINUE ELSE DO 2240 J=1,M DT = ONE/(WD(1,J)**2+ALPHA*TT(1,J)**2) DO 2230 I=1,N DTT(I,J) = T(I,J)*DT 2230 CONTINUE 2240 CONTINUE END IF ELSE TERM2 = ALPHA*TT(1,1)**2 DO 2260 J=1,M TERM1 = WD(1,J)**2 DT = ONE/(TERM1+TERM2) DO 2250 I=1,N DTT(I,J) = T(I,J)*DT 2250 CONTINUE 2260 CONTINUE END IF END IF ELSE IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN TERM1 = WD(1,1)**2 DO 2320 J=1,M DO 2310 I=1,N DTT(I,J) = T(I,J)/(TERM1 + ALPHA*TT(I,J)**2) 2310 CONTINUE 2320 CONTINUE ELSE TERM1 = WD(1,1)**2 DO 2340 J=1,M TERM2 = ALPHA*TT(1,J)**2 DT = ONE/(TERM1+TERM2) DO 2330 I=1,N DTT(I,J) = T(I,J)*DT 2330 CONTINUE 2340 CONTINUE END IF ELSE DT = ONE/(WD(1,1)**2+ALPHA*TT(1,1)**2) DO 2360 J=1,M DO 2350 I=1,N DTT(I,J) = T(I,J)*DT 2350 CONTINUE 2360 CONTINUE END IF END IF END IF * RETURN END *DINIWK SUBROUTINE DINIWK + (N,M,NP,WORK,LWORK,IWORK,LIWORK, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + BETA,SCLB, + SSTOL,PARTOL,MAXIT,TAUFAC, + JOB,IPRINT,LUNERR,LUNRPT, + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + JOBI,IPRINI,LUNERI,LUNRPI, + SSFI,TTI,LDTTI,DELTAI) C***BEGIN PROLOGUE DINIWK C***REFER TO DODR,DODRC C***ROUTINES CALLED DFLAGS,DMPREC,DSCLB,DSCLD,DZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE INITIALIZE WORK VECTORS AS NECESSARY C***END PROLOGUE DINIWK * C...SCALAR ARGUMENTS DOUBLE PRECISION + PARTOL,SSTOL,TAUFAC INTEGER + DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX, + LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M, + MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M) INTEGER + IFIXX(LDIFX,M),IWORK(LIWORK) * C...LOCAL SCALARS DOUBLE PRECISION + ONE,THREE,TWO,ZERO INTEGER + I,J LOGICAL + ANAJAC,CHKJAC,DOVCV,INITD,ISODR,RESTRT * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DMPREC EXTERNAL + DMPREC * C...EXTERNAL SUBROUTINES EXTERNAL + DCOPY,DFLAGS,DSCLB,DSCLD,DZERO * C...INTRINSIC FUNCTIONS INTRINSIC + SQRT * C...DATA STATEMENTS DATA + ZERO,ONE,TWO,THREE + /0.0D0,1.0D0,2.0D0,3.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C INTEGER DELTAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C INTEGER EPSMAI C THE STARTING LOCATION IN ARRAY WORK OF C THE VALUE OF MACHINE PRECISION. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C INTEGER IPRINI C THE LOCATION IN ARRAY IWORK OF C THE PRINT CONTROL VARIABLE. C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER J C AN INDEXING VARIABLE. C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOBI C THE STARTING LOCATION IN ARRAY IWORK OF C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTTI C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNERI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXITI C THE LOCATION IN ARRAY IWORK OF C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C INTEGER PARTLI C THE LOCATION IN ARRAY WORK OF C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C DOUBLE PRECISION PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C DOUBLE PRECISION SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SSFI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE BETA'S. C DOUBLE PRECISION SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SSTOLI C THE LOCATION IN ARRAY WORK OF C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C DOUBLE PRECISION TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER TAUFCI C THE LOCATION IN ARRAY WORK OF C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C DOUBLE PRECISION THREE C THE VALUE 3.0D0. C INTEGER TTI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE DELTA'S. C DOUBLE PRECISION TWO C THE VALUE 2.0D0. C DOUBLE PRECISION WORK(LWORK) C THE DOUBLE PRECISION WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DINIWK * * CALL DFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR,DOVCV) * C STORE VALUE OF MACHINE PRECISION IN WORK VECTOR * WORK(EPSMAI) = DMPREC() * C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE C PARAMETERS * IF (PARTOL.LT.WORK(EPSMAI) .OR. PARTOL.GE.ONE) THEN WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE) ELSE WORK(PARTLI) = PARTOL END IF * C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE C SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS * IF (SSTOL.LT.WORK(EPSMAI) .OR. SSTOL.GE.ONE) THEN WORK(SSTOLI) = SQRT(WORK(EPSMAI)) ELSE WORK(SSTOLI) = SSTOL END IF * C SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION * IF (TAUFAC.LE.ZERO) THEN WORK(TAUFCI) = ONE ELSE WORK(TAUFCI) = TAUFAC END IF * C SET MAXIMUM NUMBER OF ITERATIONS * IF (MAXIT.LE.0) THEN IWORK(MAXITI) = 50 ELSE IWORK(MAXITI) = MAXIT END IF * C STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL C VARIABLE * IF (JOB.LE.0) THEN IWORK(JOBI) = 0 ELSE IWORK(JOBI) = JOB END IF * C SET PRINT CONTROL * IF (IPRINT.LT.0) THEN IWORK(IPRINI) = 2001 ELSE IWORK(IPRINI) = IPRINT END IF * C SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES * IF (LUNERR.LT.0) THEN IWORK(LUNERI) = 6 ELSE IWORK(LUNERI) = LUNERR END IF * C SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS * IF (LUNRPT.LT.0) THEN IWORK(LUNRPI) = 6 ELSE IWORK(LUNRPI) = LUNRPT END IF * C COMPUTE SCALING FOR BETA'S AND DELTA'S * IF (SCLB(1).LE.ZERO) THEN CALL DSCLB(NP,BETA,WORK(SSFI)) ELSE CALL DCOPY(NP,SCLB,1,WORK(SSFI),1) END IF IF (SCLD(1,1).LE.ZERO) THEN IWORK(LDTTI) = N CALL DSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI)) ELSE IF (LDSCLD.EQ.1) THEN IWORK(LDTTI) = 1 CALL DCOPY(N,SCLD(1,1),1,WORK(TTI),1) ELSE IWORK(LDTTI) = N DO 10 J=1,M CALL DCOPY(N,SCLD(1,J),1,WORK(TTI+(J-1)*IWORK(LDTTI)),1) 10 CONTINUE END IF END IF * C INITIALIZE DELTA'S AS NECESSARY * IF (ISODR) THEN IF (INITD) THEN CALL DZERO(N,M,WORK(DELTAI),N) ELSE IF (IFIXX(1,1).GE.0) THEN IF (LDIFX.EQ.1) THEN DO 20 J=1,M IF (IFIXX(1,J).EQ.0) THEN CALL DZERO(N,1,WORK(DELTAI+(J-1)*N),N) END IF 20 CONTINUE ELSE DO 40 J=1,M DO 30 I=1,N IF (IFIXX(I,J).EQ.0) THEN WORK(DELTAI-1+I+(J-1)*N) = ZERO END IF 30 CONTINUE 40 CONTINUE END IF END IF END IF ELSE CALL DZERO(N,M,WORK(DELTAI),N) END IF * RETURN END *DIWINF SUBROUTINE DIWINF + (M,NP, + MSGB,MSGX,JPVTI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) C***BEGIN PROLOGUE DIWINF C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE C***END PROLOGUE DIWINF * C...SCALAR ARGUMENTS INTEGER + IDFI,INT2I,IPRINI,IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI, + LUNRPI,M,MAXITI,MSGB,MSGX,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NP, + NPPI,NROWI,NTOLI * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER IDFI C THE STARTING LOCATION IN ARRAY IWORK OF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER INT2I C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF INTERNAL DOUBLING STEPS. C INTEGER IPRINI C THE LOCATION IN ARRAY IWORK OF C THE PRINT CONTROL VARIABLE. C INTEGER IRANKI C THE LOCATION IN ARRAY IWORK OF C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C INTEGER JOBI C THE LOCATION IN ARRAY IWORK OF C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C INTEGER JPVTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE PIVOT VECTOR. C INTEGER LDTTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LUNERI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C INTEGER LUNRPI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXITI C THE LOCATION IN ARRAY IWORK OF C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MSGB C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER NETAI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITERI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NJEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NNZWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPPI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C INTEGER NROWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTOLI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C TO BE SET BY DJCK. * * C***FIRST EXECUTABLE STATEMENT DIWINF * * IF (NP.GE.1 .AND. M.GE.1) THEN MSGB = 1 MSGX = MSGB + NP+1 JPVTI = MSGX + M+1 NNZWI = JPVTI + NP NPPI = NNZWI + 1 IDFI = NPPI + 1 JOBI = IDFI + 1 IPRINI = JOBI + 1 LUNERI = IPRINI + 1 LUNRPI = LUNERI + 1 NROWI = LUNRPI + 1 NTOLI = NROWI + 1 NETAI = NTOLI + 1 MAXITI = NETAI + 1 NITERI = MAXITI + 1 NFEVI = NITERI + 1 NJEVI = NFEVI + 1 INT2I = NJEVI + 1 IRANKI = INT2I + 1 LDTTI = IRANKI + 1 LIWKMN = LDTTI ELSE MSGB = 1 MSGX = 1 JPVTI = 1 NNZWI = 1 NPPI = 1 IDFI = 1 JOBI = 1 IPRINI = 1 LUNERI = 1 LUNRPI = 1 NROWI = 1 NTOLI = 1 NETAI = 1 MAXITI = 1 NITERI = 1 NFEVI = 1 NJEVI = 1 INT2I = 1 IRANKI = 1 LDTTI = 1 LIWKMN = 1 END IF * RETURN END *DJACFD SUBROUTINE DJACFD + (N,NP,M,BETA, + X,LDX,DELTA,XPLUSD,LDXPD,FUN, + SS,TT,LDTT,NETA,PV,STP, + IFIXB,FJACB,LDFJB,ISODR, + IFIXX,LDIFX,FJACX,LDFJX,NFEV,ISTOP) C***BEGIN PROLOGUE DJACFD C***REFER TO DODR,DODRC C***ROUTINES CALLED DZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890727 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE FINITE DIFFERENCE APPROXIMATIONS TO THE C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS C***END PROLOGUE DJACFD * C...SCALAR ARGUMENTS INTEGER + ISTOP,LDFJB,LDFJX,LDIFX,LDTT,LDX,LDXPD,M,N,NETA,NFEV,NP LOGICAL + ISODR * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),DELTA(N,M),FJACB(LDFJB,NP), + FJACX(LDFJX,M),PV(N),SS(NP),STP(N),TT(LDTT,M), + X(LDX,M),XPLUSD(LDXPD,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS DOUBLE PRECISION + BETAJ,ONE,SQREPS,TEN,TWO,TYPJ,ZERO INTEGER + I,J,JFX LOGICAL + DOIT * C...EXTERNAL SUBROUTINES EXTERNAL + DZERO * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MAX,SIGN,SQRT * C...DATA STATEMENTS DATA + ZERO,ONE,TWO,TEN + /0.0D0,1.0D0,2.0D0,10.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C DOUBLE PRECISION BETAJ C THE J-TH FUNCTION PARAMETER. C DOUBLE PRECISION DELTA(N,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DOIT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER THE DERIVATIVE C WRT A GIVEN BETA OR X NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT C (DOIT=FALSE). C DOUBLE PRECISION FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C DOUBLE PRECISION FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO X. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER ISTOP C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE C USER WISHES THE COMPUTATIONS STOPPED. C INTEGER J C AN INDEXING VARIABLE. C INTEGER JFX C AN INDEXING VARIABLE. C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION PV(N) C THE PREDICTED VALUES OF THE MODEL FUNCTION AT THE CURRENT C POINT. C DOUBLE PRECISION SQREPS C THE SQUARE ROOT OF MACHINE PRECISION. C DOUBLE PRECISION SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION STP(N) C THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES. C DOUBLE PRECISION TEN C THE VALUE 10.0D0. C DOUBLE PRECISION TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TWO C THE VALUE 2.0D0. C DOUBLE PRECISION TYPJ C THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DJACFD * * C SET THE RELATIVE STEP SIZE FOR COMPUTING THE JACOBIANS * SQREPS = TEN**(-NETA/TWO) * C COMPUTE THE PREDICTED VALUES OF THE FUNCTION AT THE GIVEN POINT * CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PV,ISTOP) NFEV = NFEV + 1 IF (ISTOP.LT.0) THEN RETURN END IF * C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS * JFX = 0 DO 20 J=1,NP IF (IFIXB(1).GE.0) THEN IF (IFIXB(J).EQ.0) THEN DOIT = .FALSE. ELSE DOIT = .TRUE. END IF ELSE DOIT = .TRUE. END IF IF (DOIT) THEN JFX = JFX + 1 BETAJ = BETA(J) TYPJ = ONE/SS(JFX) STP(J) = BETAJ + SQREPS*SIGN(ONE,BETAJ)*MAX(ABS(BETAJ),TYPJ) STP(J) = STP(J) - BETAJ BETA(J) = BETAJ + STP(J) CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,FJACB(1,JFX),ISTOP) NFEV = NFEV + 1 IF (ISTOP.LT.0) THEN RETURN END IF DO 10 I=1,N FJACB(I,JFX) = (FJACB(I,JFX)-PV(I))/STP(J) 10 CONTINUE BETA(J) = BETAJ END IF 20 CONTINUE * C COMPUTE THE JACOBIAN WRT THE X'S * IF (ISODR) THEN DO 70 J=1,M IF (IFIXX(1,1).LT.0) THEN DOIT = .TRUE. ELSE IF (LDIFX.EQ.1) THEN IF (IFIXX(1,J).EQ.0) THEN DOIT = .FALSE. ELSE DOIT = .TRUE. END IF ELSE DO 30 I=1,N IF (IFIXX(I,J).NE.0) THEN DOIT = .TRUE. GO TO 40 END IF 30 CONTINUE DOIT = .FALSE. 40 CONTINUE END IF IF (.NOT.DOIT) THEN CALL DZERO(N,1,FJACX(1,J),N) ELSE DO 50 I=1,N IF (TT(1,1).GT.ZERO) THEN IF (LDTT.EQ.1) THEN TYPJ = ONE/TT(1,J) ELSE TYPJ = ONE/TT(I,J) END IF ELSE TYPJ = ABS(ONE/TT(1,1)) END IF STP(I) = XPLUSD(I,J) + SQREPS*SIGN(ONE,XPLUSD(I,J))* + MAX(ABS(XPLUSD(I,J)),TYPJ) STP(I) = STP(I) - XPLUSD(I,J) XPLUSD(I,J) = XPLUSD(I,J) + STP(I) 50 CONTINUE CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,FJACX(1,J),ISTOP) NFEV = NFEV + 1 IF (ISTOP.LT.0) THEN RETURN END IF DO 60 I=1,N FJACX(I,J) = (FJACX(I,J)-PV(I))/STP(I) XPLUSD(I,J) = X(I,J) + DELTA(I,J) 60 CONTINUE END IF 70 CONTINUE END IF * RETURN END *DJCK SUBROUTINE DJCK + (FUN,JAC,NFEV,NJEV, + N,NP,M,BETA,XPLUSD,LDXPD, + ETA,NETA,NTOL,SS,TT,LDTT,NROW,ISODR,EPSMAC, + PVTEMP,FJACB,LDFJB,FJACX,LDFJX, + MSGB,MSGX,ISTOPF,ISTOPJ) C***BEGIN PROLOGUE DJCK C***REFER TO DODR,DODRC C***ROUTINES CALLED DJCKM C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKCNT) C***END PROLOGUE DJCK * C...SCALAR ARGUMENTS DOUBLE PRECISION + EPSMAC,ETA INTEGER + ISTOPF,ISTOPJ,LDFJB,LDFJX,LDTT,LDXPD,M,N,NETA,NFEV, + NJEV,NP,NROW,NTOL LOGICAL + ISODR * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),FJACB(LDFJB,NP), + FJACX(LDFJX,M),PVTEMP(N),SS(NP), + TT(LDTT,M),XPLUSD(LDXPD,M) INTEGER + MSGB(NP+1),MSGX(M+1) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS DOUBLE PRECISION + ONE,PV,TEN,TOL,TYPJ,ZERO INTEGER + J LOGICAL + ISWRTB * C...EXTERNAL SUBROUTINES EXTERNAL + DJCKM * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,INT,LOG10 * C...DATA STATEMENTS DATA + ZERO,ONE,TEN + /0.0D0,1.0D0,10.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION EPSMAC C THE VALUE OF MACHINE PRECISION. C DOUBLE PRECISION ETA C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C DOUBLE PRECISION FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C DOUBLE PRECISION FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO X. C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER ISTOPJ C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE JACOBIAN GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C LOGICAL ISWRTB C THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT C BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. C INTEGER J C AN INDEX VARIABLE. C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER C SET BY THE USER OR COMPUTED BY DETAF. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY C AT WHICH THE DERIVATIVE IS CHECKED. C INTEGER NTOL C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C EITHER SET BY THE USER OR COMPUTED FROM NETA. C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C DOUBLE PRECISION PVTEMP(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C DOUBLE PRECISION SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TEN C THE VALUE 10.0D0. C DOUBLE PRECISION TOL C THE AGREEMENT TOLERANCE. C DOUBLE PRECISION TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TYPJ C THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DJCK * * C SET TOLERANCE FOR CHECKING DERIVATIVES * IF ((NTOL.LT.1) .OR. (NTOL.GT.(NETA+1)/2)) THEN NTOL = (NETA+3)/4 END IF * TOL = TEN**(-NTOL) * C COMPUTE PREDICTED VALUE OF MODEL USING CURRENT PARAMETER C ESTIMATES, AND COMPUTE USER-SUPPLIED DERIVATIVE VALUES * ISTOPF = 0 CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,ISTOPF) NFEV = NFEV + 1 IF (ISTOPF.NE.0) THEN RETURN END IF PV = PVTEMP(NROW) * ISTOPJ = 0 CALL JAC(N,NP,M,BETA,XPLUSD,LDXPD,FJACB,LDFJB, + ISODR,FJACX,LDFJX,ISTOPJ) NJEV = NJEV + 1 IF (ISTOPJ.NE.0) THEN RETURN END IF * C CHECK DERIVATIVES WRT BETA * ISWRTB = .TRUE. MSGB(1) = 0 * DO 10 J=1,NP * IF (SS(1).GT.ZERO) THEN TYPJ = ONE/SS(J) ELSE TYPJ = ONE/ABS(SS(1)) END IF * C CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW * CALL DJCKM(FUN,NFEV, + N,NP,M,XPLUSD,LDXPD,BETA,TYPJ, + ETA,TOL,EPSMAC, + J,NROW,PV,FJACB(NROW,J),PVTEMP, + ISWRTB,MSGB,NP+1,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF * 10 CONTINUE * C CHECK DERIVATIVES WRT X * MSGX(1) = 0 * IF (ISODR) THEN ISWRTB = .FALSE. DO 20 J=1,M * IF (TT(1,1).GT.ZERO) THEN IF (LDTT.EQ.1) THEN TYPJ = ONE/TT(1,J) ELSE TYPJ = ONE/TT(NROW,J) END IF ELSE TYPJ = ABS(ONE/TT(1,1)) END IF * C CHECK DERIVATIVE WRT THE J-TH COLUMN OF X AT ROW NROW * CALL DJCKM(FUN,NFEV, + N,NP,M,XPLUSD,LDXPD,BETA,TYPJ, + ETA,TOL,EPSMAC, + J,NROW,PV,FJACX(NROW,J),PVTEMP, + ISWRTB,MSGX,M+1,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF * 20 CONTINUE END IF * C PRINT RESULTS IF THEY ARE DESIRED * RETURN * END *DJCKC SUBROUTINE DJCKC + (FUN,NFEV,N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL,EPSMAC, + J,NROW,PV,D,FD,PARMX,PVPSTP,STP, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) C***BEGIN PROLOGUE DJCKC C***REFER TO DODR,DODRC C***ROUTINES CALLED DJCKF,DPVB,DPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE C DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKCRV) C***END PROLOGUE DJCKC * C...SCALAR ARGUMENTS DOUBLE PRECISION + D,EPSMAC,ETA,FD,PARMX,PV,PVPSTP,STP,TOL INTEGER + ISTOPF,J,LDXPD,LMSG,M,N,NFEV,NP,NROW LOGICAL + ISWRTB * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) INTEGER + MSG(LMSG) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS DOUBLE PRECISION + CURVE,FIVE,ONE,PVMCRV,PVPCRV,STPCRV,THIRD,THREE,TWO * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DPVB,DPVD EXTERNAL + DPVB,DPVD * C...EXTERNAL SUBROUTINES EXTERNAL + DJCKF * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SIGN * C...DATA STATEMENTS DATA + ONE,TWO,THREE,FIVE + /1.0D0,2.0D0,3.0D0,5.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION CURVE C A MEASURE OF THE CURVATURE IN THE MODEL. C DOUBLE PRECISION D C THE SCALAR IN WHICH ROW NROW OF THE DERIVATIVE C MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER C IS STORED. C DOUBLE PRECISION EPSMAC C THE VALUE OF MACHINE PRECISION. C DOUBLE PRECISION ETA C THE RELATIVE NOISE IN THE MODEL. C DOUBLE PRECISION FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER. C DOUBLE PRECISION FIVE C THE VALUE 5.0D0. C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C LOGICAL ISWRTB C THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT C BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSG(LMSG) C THE ERROR CHECKING RESULTS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE. C DOUBLE PRECISION PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C DOUBLE PRECISION PVMCRV C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV. C DOUBLE PRECISION PVPCRV C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV. C DOUBLE PRECISION PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP. C DOUBLE PRECISION PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C DOUBLE PRECISION STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C DOUBLE PRECISION STPCRV C THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL. C DOUBLE PRECISION THIRD C THE VALUE 1.0D0/3.0D0. C DOUBLE PRECISION THREE C THE VALUE 3.0D0. C DOUBLE PRECISION TOL C THE AGREEMENT TOLERANCE. C DOUBLE PRECISION TWO C THE VALUE 2.0D0. C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT DJCKC * * THIRD = ONE/THREE * IF (ISWRTB) THEN * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA * STPCRV = (ETA**THIRD*PARMX*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) PVPCRV = DPVB(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STPCRV,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF PVMCRV = DPVB(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,-STPCRV,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF ELSE * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA * STPCRV = (ETA**THIRD*PARMX*SIGN(ONE,XPLUSD(NROW,J))+ + XPLUSD(NROW,J)) - XPLUSD(NROW,J) PVPCRV = DPVD(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STPCRV,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF PVMCRV = DPVD(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,-STPCRV,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF END IF * C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL * CURVE = ((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV) CURVE = CURVE + (ETA ** THIRD) * (ABS(PVPCRV) + + ABS(PVMCRV) + TWO * ABS(PV)) / (PARMX * PARMX) * C COMPARE NUMERICAL AND ANALYTICAL DERIVATIVES USING A FUDGE C FACTOR OF TEN. * IF (ABS(CURVE*STP)*FIVE.LT.ABS(FD-D)) THEN * C CURVATURE CANNOT ACCOUNT FOR DISCREPANCY. * C CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT. * CALL DJCKF(FUN,NFEV,N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL, + J,NROW,PV,D,FD,PARMX,PVPSTP,STP,CURVE, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF * ELSE * C HIGH CURVATURE COULD BE THE PROBLEM. TRY A SMALLER STEP SIZE. * C COMPUTE DERIVATIVE WITH SMALLER STEP SIZE C IF SMALLER STEP SIZE IS TOO SMALL SET MSG(J+1)=1 ELSE COMPUTE C PREDICTED VALUE WITH NEW STEP. * IF (ISWRTB) THEN * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA * STP = (TWO*TOL*ABS(D)*SIGN(ONE,BETA(J)) / + ABS(CURVE)+BETA(J)) - BETA(J) IF (ABS(STP).LE.EPSMAC*ABS(BETA(J))) THEN IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 6 RETURN ELSE PVPSTP = DPVB(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF END IF ELSE * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA * STP = (TWO*TOL*ABS(D)*SIGN(ONE,XPLUSD(NROW,J)) / + ABS(CURVE)+XPLUSD(NROW,J)) - XPLUSD(NROW,J) IF (ABS(STP).LE.EPSMAC*ABS(XPLUSD(NROW,J))) THEN IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 6 RETURN ELSE PVPSTP = DPVD(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF END IF END IF * C COMPUTE THE NEW NUMERICAL DERIVATIVE * FD = (PVPSTP-PV)/STP * C CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK * IF (ABS(FD-D).GT.TWO*TOL*ABS(D)) THEN * C NUMERICAL DERIVATIVE COMPUTED USING NEW STEP SIZE DOES C NOT AGREE WITH ANALYTIC DERIVATIVE. * C CHECK IF THE PROBLEM COULD BE THE FORWARD DIFFERENCE QUOTIENT C DERIVATIVE. * C (FUDGE FACTOR IS 2) * IF (ABS(STP*(FD-D)).GE.TWO*ETA*ABS(PV+PVPSTP)) THEN * C FINITE PRECISION COULD NOT BE THE CULPRIT * MSG(1) = 1 MSG(J+1) = 1 ELSE * C FINITE PRECISION MAY BE THE CULPRIT * IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 6 END IF END IF END IF * RETURN END *DJCKF SUBROUTINE DJCKF + (FUN,NFEV,N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL, + J,NROW,PV,D,FD,PARMX,PVPSTP,STP,CURVE, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) C***BEGIN PROLOGUE DJCKF C***REFER TO DODR,DODRC C***ROUTINES CALLED DPVB,DPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE C CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES. C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKFPA) C***END PROLOGUE DJCKF * C...SCALAR ARGUMENTS DOUBLE PRECISION + CURVE,D,ETA,FD,PARMX,PV,PVPSTP,STP,TOL INTEGER + ISTOPF,J,LDXPD,LMSG,M,N,NFEV,NP,NROW LOGICAL + ISWRTB * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) INTEGER + MSG(LMSG) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS DOUBLE PRECISION + ONE,TEN,TWO LOGICAL + LARGE * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DPVB,DPVD EXTERNAL + DPVB,DPVD * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SIGN * C...DATA STATEMENTS DATA + ONE,TWO,TEN + /1.0D0,2.0D0,10.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION CURVE C A MEASURE OF THE CURVATURE IN THE MODEL. C DOUBLE PRECISION D C THE SCALAR IN WHICH ROW NROW OF THE DERIVATIVE C MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER C IS STORED. C DOUBLE PRECISION ETA C THE RELATIVE NOISE IN THE MODEL C DOUBLE PRECISION FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C LOGICAL ISWRTB C THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT C BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C LOGICAL LARGE C AN INDICATOR VALUE INDICATING WHETHER THE RECOMMENDED C INCREASE IN THE STEP SIZE WOULD BE GREATER THAN PARMX. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSG(LMSG) C THE ERROR CHECKING RESULTS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE C TYPICAL VALUE OF THAT PARAMETER C DOUBLE PRECISION PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C DOUBLE PRECISION PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP. C DOUBLE PRECISION PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C DOUBLE PRECISION STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C DOUBLE PRECISION TEN C THE VALUE 10.0D0. C DOUBLE PRECISION TOL C THE AGREEMENT TOLERANCE. C DOUBLE PRECISION TWO C THE VALUE 2.0D0. C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT DJCKF * * C CHECK WHETHER FINITE PRECISION COULD BE THE PROBLEM * IF (ABS(STP*(FD-D)).GE.TEN*ETA*(ABS(PV)+ABS(PVPSTP))) THEN * C DISCREPANCY BETWEEN NUMERICAL AND ANALYTICAL DERIVATIVES CANNOT C BE ACCOUNTED FOR BY FINITE PRECISION ARITHMETIC * MSG(1) = 1 MSG(J+1) = 1 ELSE * C FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM. C TRY A LARGER STEP SIZE * * IF (ISWRTB) THEN * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA * STP = (ETA*(ABS(PV)+ABS(PVPSTP))*SIGN(ONE,BETA(J))/ + (TOL*ABS(D))+BETA(J)) - BETA(J) IF (ABS(STP).GT.PARMX) THEN STP = PARMX*SIGN(ONE,BETA(J)) LARGE = .TRUE. ELSE LARGE = .FALSE. END IF PVPSTP = DPVB(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) ELSE * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA * STP = (ETA*(ABS(PV)+ABS(PVPSTP))*SIGN(ONE,XPLUSD(NROW,J))/ + (TOL*ABS(D))+XPLUSD(NROW,J)) - XPLUSD(NROW,J) IF (ABS(STP).GT.PARMX) THEN STP = PARMX*SIGN(ONE,XPLUSD(NROW,J)) LARGE = .TRUE. ELSE LARGE = .FALSE. END IF PVPSTP = DPVD(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) END IF IF (ISTOPF.NE.0) THEN RETURN END IF * FD = (PVPSTP-PV)/STP * C CHECK FOR AGREEMENT * IF ((ABS(FD-D)).GT.TWO*TOL*ABS(D)) THEN * C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES STILL DISAGREE. C CHECK IF CURVATURE IS THE PROBLEM * IF (ABS(CURVE*STP).GE.ABS(FD-D) .OR. LARGE) THEN * C CURVATURE MAY BE THE CULPRIT * IF (MSG(1).EQ.0) MSG(1) = 2 IF (LARGE) THEN MSG(J+1) = 5 ELSE MSG(J+1) = 6 END IF ELSE * C CURVATURE COULDNT BE THE CULPRIT * MSG(1) = 1 MSG(J+1) = 1 END IF END IF END IF * RETURN END *DJCKM SUBROUTINE DJCKM + (FUN,NFEV, + N,NP,M,XPLUSD,LDXPD,BETA,TYPJ, + ETA,TOL,EPSMAC, + J,NROW,PV,D,PVTEMP, + ISWRTB,MSG,LMSG,ISTOPF) C***BEGIN PROLOGUE DJCKM C***REFER TO DODR,DODRC C***ROUTINES CALLED DJCKC,DJCKZ,DPVB,DPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE CHECK USER-SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL C DERIVATIVES C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKMN.) C***END PROLOGUE DJCKM * C...SCALAR ARGUMENTS DOUBLE PRECISION + D,EPSMAC,ETA,PV,TOL,TYPJ INTEGER + ISTOPF,J,LDXPD,LMSG,M,N,NFEV,NP,NROW LOGICAL + ISWRTB * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) INTEGER + MSG(LMSG) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS DOUBLE PRECISION + FD,ONE,PARMX,PVPSTP,STP,ZERO * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DPVB,DPVD EXTERNAL + DPVB,DPVD * C...EXTERNAL SUBROUTINES EXTERNAL + DJCKC,DJCKZ * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MAX,SIGN,SQRT * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0D0,1.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION D C THE SCALAR IN WHICH ROW NROW OF THE DERIVATIVE C MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER C IS STORED. C DOUBLE PRECISION EPSMAC C THE VALUE OF MACHINE PRECISION. C DOUBLE PRECISION ETA C THE RELATIVE NOISE IN THE MODEL C DOUBLE PRECISION FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C LOGICAL ISWRTB C THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT C BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSG(LMSG) C THE ERROR CHECKING RESULTS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE C TYPICAL VALUE OF THAT PARAMETER C DOUBLE PRECISION PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C DOUBLE PRECISION PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP. C DOUBLE PRECISION PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C DOUBLE PRECISION STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C DOUBLE PRECISION TOL C THE AGREEMENT TOLERANCE. C DOUBLE PRECISION TYPJ C THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DJCKM * * C CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE C QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES * MSG(J+1) = 0 * IF (ISWRTB) THEN * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA * PARMX = MAX(ABS(BETA(J)),ABS(TYPJ)) STP = (SQRT(ETA)*PARMX*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) PVPSTP = DPVB(FUN,NFEV, + N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) ELSE * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA * PARMX = MAX(ABS(XPLUSD(NROW,J)),ABS(TYPJ)) STP = (SQRT(ETA)*PARMX*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) + - XPLUSD(NROW,J) PVPSTP = DPVD(FUN,NFEV, + N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) END IF IF (ISTOPF.NE.0) THEN RETURN END IF * FD = (PVPSTP-PV)/STP * C CHECK FOR DISAGREEMENT * IF (ABS(FD-D).LE.TOL*ABS(D)) THEN * C NUMERICAL AND ANALYTIC DERIVATIVES AGREE * C CHECK IF ANALYTIC DERIVATIVE IS IDENTICALLY ZERO, INDICATING C THE POSSIBILITY THAT THE DERIVATIVE SHOULD BE RECHECKED AT C ANOTHER POINT. * IF (D.EQ.ZERO) THEN * C JTH ANALYTIC AND NUMERICAL DERIVATIVES BOTH ARE ZERO. C SET MSG FLAG ACCORDINGLY. * IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 2 END IF * ELSE * C NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE * C CHECK WHY * IF (D.EQ.ZERO) THEN CALL DJCKZ(FUN,NFEV, + N,NP,M,XPLUSD,LDXPD,BETA,EPSMAC, + J,NROW,PV,FD,PARMX,PVPSTP,STP, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) ELSE CALL DJCKC(FUN,NFEV, + N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL,EPSMAC, + J,NROW,PV,D,FD,PARMX,PVPSTP,STP, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) END IF END IF * RETURN END *DJCKZ SUBROUTINE DJCKZ + (FUN,NFEV,N,NP,M,XPLUSD,LDXPD,BETA,EPSMAC, + J,NROW,PV,FD,PARMX,PVPSTP,STP, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) C***BEGIN PROLOGUE DJCKZ C***REFER TO DODR,DODRC C***ROUTINES CALLED DPVB,DPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE C DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC C DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO. C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKZRO) C***END PROLOGUE DJCKZ * C...SCALAR ARGUMENTS DOUBLE PRECISION + EPSMAC,FD,PARMX,PV,PVPSTP,STP INTEGER + ISTOPF,J,LDXPD,LMSG,M,N,NFEV,NP,NROW LOGICAL + ISWRTB * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) INTEGER + MSG(LMSG) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS DOUBLE PRECISION + CD,ONE,PVMSTP,THREE,TWO,ZERO * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DPVB,DPVD EXTERNAL + DPVB,DPVD * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MIN * C...DATA STATEMENTS DATA + ZERO,ONE,TWO,THREE + /0.0D0,1.0D0,2.0D0,3.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION CD C THE CENTRAL DIFFERENCE QUOTIENT DERIVATIVE WITH C RESPECT TO THE JTH PARAMETER. C DOUBLE PRECISION EPSMAC C THE VALUE OF MACHINE PRECISION. C DOUBLE PRECISION FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER. C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C LOGICAL ISWRTB C THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT C BETA (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSG(LMSG) C THE ERROR CHECKING RESULTS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE TYPICAL C VALUE OF THAT PARAMETER. C DOUBLE PRECISION PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C DOUBLE PRECISION PVMSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) - STP. C DOUBLE PRECISION PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP. C DOUBLE PRECISION PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C DOUBLE PRECISION STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C DOUBLE PRECISION THREE C THE VALUE 3.0D0. C DOUBLE PRECISION TWO C THE VALUE 2.0D0. C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DJCKZ * * C RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP C SIZE OF 2*STP * IF (ISWRTB) THEN * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA * PVMSTP = DPVB(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,-STP,ISTOPF) ELSE * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA * PVMSTP = DPVD(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,-STP,ISTOPF) END IF IF (ISTOPF.NE.0) THEN RETURN END IF * CD = (PVPSTP-PVMSTP)/(TWO*STP) * C CHECK FOR DISAGREEMENT * IF (CD.EQ.ZERO) THEN * C NUMERICAL AND ANALYTIC DERIVATIVES NOW AGREE, BUT BOTH EQUAL ZERO, C INDICATING THAT DERIVATIVES SHOULD BE RECHECKED AT ANOTHER POINT. * IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 2 ELSE * C NUMERICAL AND ANALYTIC DERIVATIVE STILL DO NOT AGREE. C CHECK IF NUMERICAL DERIVATIVE IS CLOSE TO ZERO. * IF (MIN(ABS(CD),ABS(FD))*PARMX.LE. + ABS(PV*EPSMAC**(ONE/THREE))) THEN * C NUMERICAL DERIVATIVE IS CLOSE TO ZERO * IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 3 ELSE * C NUMERICAL DERIVATIVE NOT CLOSE TO ZERO * IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 4 END IF END IF * RETURN END *DODCHK SUBROUTINE DODCHK + (N,NP,M, + IFIXB, + LDX,LDIFX,LDSCLD,LDWD, + LWORK,LWKMN,LIWORK,LIWKMN, + SCLD,SCLB,W,WD, + INFO) C***BEGIN PROLOGUE DODCHK C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING C NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE C PROLOGUES FOR DODR AND DODRC. C***END PROLOGUE DODCHK * C...SCALAR ARGUMENTS INTEGER + INFO,LDIFX,LDSCLD,LDWD,LDX,LIWKMN,LIWORK,LWKMN,LWORK,M,N, + NP * C...ARRAY ARGUMENTS DOUBLE PRECISION + SCLB(NP),SCLD(LDSCLD,M),W(N),WD(LDWD,M) INTEGER + IFIXB(NP) * C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + I,J,K,LAST,NNZW,NPP * C...INTRINSIC FUNCTIONS INTRINSIC + LOG10 * C...DATA STATEMENTS DATA + ZERO + /0.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER J C AN INDEXING VARIABLE. C INTEGER K C AN INDEXING VARIABLE. C INTEGER LAST C THE LAST ROW OF THE ARRAY TO BE ACCESSED. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NNZW C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C DOUBLE PRECISION SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DODCHK * * C FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED * IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN NPP = NP ELSE NPP = 0 DO 10 K=1,NP IF (IFIXB(K).NE.0) THEN NPP = NPP + 1 END IF 10 CONTINUE END IF * C CHECK PROBLEM SPECIFICATION PARAMETERS * IF (N.LE.0 .OR. M.LE.0 .OR. NPP.LE.0 .OR. NPP.GT.N) THEN INFO = 10000 IF (N.LE.0) THEN INFO = INFO + 1000 END IF IF (M.LE.0) THEN INFO = INFO + 100 END IF IF (NPP.LE.0 .OR. NPP.GT.N) THEN INFO = INFO + 10 END IF RETURN END IF * C CHECK DIMENSION SPECIFICATION PARAMETERS * IF (LDX.LT.N .OR. + (LDIFX.NE.1 .AND. LDIFX.LT.N) .OR. + (LDSCLD.NE.1 .AND. LDSCLD.LT.N) .OR. + (LDWD.NE.1 .AND. LDWD.LT.N) .OR. + LWORK.LT.LWKMN .OR. LIWORK.LT.LIWKMN) THEN INFO = 20000 IF (LDX.LT.N) THEN INFO = INFO + 1000 END IF IF (LDIFX.NE.1 .AND. LDIFX.LT.N) THEN INFO = INFO + 100 END IF IF (LDSCLD.NE.1 .AND. LDSCLD.LT.N) THEN INFO = INFO + 200 END IF IF (LDWD.NE.1 .AND. LDWD.LT.N) THEN INFO = INFO + 400 END IF IF (LWORK.LT.LWKMN) THEN INFO = INFO + 10 END IF IF (LIWORK.LT.LIWKMN) THEN INFO = INFO + 1 END IF RETURN END IF * C CHECK DELTA SCALING * IF (SCLD(1,1).GT.0) THEN DO 30 J=1,M IF (LDSCLD.GE.N) THEN LAST = N ELSE LAST = 1 END IF DO 20 I=1,LAST IF (SCLD(I,J).LE.0) THEN INFO = 31000 GO TO 40 END IF 20 CONTINUE 30 CONTINUE END IF * C CHECK BETA SCALING * 40 IF (SCLB(1).GT.0) THEN DO 50 K=1,NP IF (SCLB(K).LE.0) THEN IF (INFO.EQ.0) THEN INFO = 30100 ELSE INFO = INFO + 100 END IF GO TO 60 END IF 50 CONTINUE END IF * C CHECK OBSERVATIONAL ERROR WEIGHTS IF INDIVIDUALLY SPECIFIED * 60 IF (W(1).GE.ZERO) THEN NNZW = 0 DO 70 I=1,N IF (W(I).LT.ZERO) THEN IF (INFO.EQ.0) THEN INFO = 30010 ELSE INFO = INFO + 10 END IF GO TO 80 ELSE IF (W(I).GT.ZERO) THEN NNZW = NNZW + 1 END IF 70 CONTINUE IF (NNZW.LT.NPP) THEN IF (INFO.EQ.0) THEN INFO = 30020 ELSE INFO = INFO + 20 END IF END IF END IF * C CHECK DELTA WEIGHTS IF INDIVIDUALLY SPECIFIED * 80 IF (WD(1,1).GE.ZERO) THEN DO 100 J=1,M IF (LDWD.GE.N) THEN LAST = N ELSE LAST = 1 END IF DO 90 I=1,LAST IF (WD(I,J).LE.ZERO) THEN IF (INFO.EQ.0) THEN INFO = 30001 ELSE INFO = INFO + 1 END IF GO TO 110 END IF 90 CONTINUE 100 CONTINUE END IF * 110 RETURN * END *DODDRV SUBROUTINE DODDRV + (SHORT, + FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) C***BEGIN PROLOGUE DODDRV C***REFER TO DODR,DODRC C***ROUTINES CALLED DCOPY,DDIAGS,DDOT,DETAF,DEVFUN,DFLAGS, C DINIWK,DIWINF,DJCK,DNRM2,DODCHK,DODMN, C DODPER,DPACK,DSETN,DWDS,DWINF C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN C PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION C (ODR) ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) C***END PROLOGUE DODDRV * C...SCALAR ARGUMENTS DOUBLE PRECISION + PARTOL,SSTOL,TAUFAC INTEGER + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDWD,LDX,LIWORK,LUNERR, + LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP LOGICAL + SHORT * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),SCLB(NP),SCLD(LDSCLD,M), + W(N),WD(LDWD,M),WORK(LWORK),X(LDX,M),Y(N) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS DOUBLE PRECISION + EPSMAC,ETA,TEN,ZERO INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,DDELTI,DELTAI,DELTNI,DELTSI, + EPSMAI,ETAI,FI,FJACBI,FJACXI,FNI,FSI,I,IDFI,INT2I,IPRINI, + IRANKI,ISTOPF,ISTOPJ,JOBI,JPVTI,LDTT,LDTTI,LIWKMN,LUNERI, + LUNRPI,LWKMN,MAXITI,MSGB,MSGX,NETA,NETAI,NFEV,NFEVI,NITERI, + NJEV,NJEVI,NNZWI,NPPI,NROW,NROWI,NTOL,NTOLI,OLMAVI,OMEGAI, + PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,RNORSI,RVARI,SI,SSFI,SSI, + SSSI,SSTOLI,TAUFCI,TAUI,TFJACI,TI,TTI,UI,WRK1I,WRK2I,WSSI, + WSSDEI,WSSEPI,XPLUSI,YTI LOGICAL + ANAJAC,CHKJAC,DOVCV,INITD,ISODR,RESTRT * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT,DNRM2 EXTERNAL + DDOT,DNRM2 * C...EXTERNAL SUBROUTINES EXTERNAL + DCOPY,DDIAGS,DETAF,DEVFUN,DFLAGS,DINIWK,DIWINF,DJCK, + DODCHK,DODMN,DODPER,DPACK,DSETN,DWDS,DWINF * C...DATA STATEMENTS DATA + ZERO,TEN + /0.0D0,10.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE FUNCTION. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER ACTRSI C THE LOCATION IN ARRAY WORK OF C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER ALPHAI C THE LOCATION IN ARRAY WORK OF C THE LEVENBERG-MARQUARDT PARAMETER. C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER BETACI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETANI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETASI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C INTEGER DDELTI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (W*D)**2 * DELTA. C INTEGER DELTAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C INTEGER EPSMAI C THE LOCATION IN ARRAY WORK OF C THE VALUE OF MACHINE PRECISION. C DOUBLE PRECISION ETA C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C INTEGER ETAI C THE LOCATION IN ARRAY WORK OF C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C INTEGER FI C THE STARTING LOCATION IN ARRAY WORK OF C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FJACBI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO BETA. C INTEGER FJACXI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO X. C INTEGER FNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER I C AN INDEX VARIABLE. C INTEGER IDFI C THE STARTING LOCATION IN ARRAY IWORK OF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C INTEGER INT2I C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF INTERNAL DOUBLING STEPS. C INTEGER IPRINI C THE LOCATION IN ARRAY IWORK OF C THE PRINT CONTROL VARIABLE. C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IRANKI C THE LOCATION IN ARRAY IWORK OF C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER ISTOPJ C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE JACOBIAN GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOBI C THE LOCATION IN ARRAY IWORK OF C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C INTEGER JPVTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE PIVOT VECTOR. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDTTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNERI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXITI C THE LOCATION IN ARRAY IWORK OF C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MSGB C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NDIGIT C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NETAI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NFEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITERI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NJEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NNZWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPPI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C INTEGER NROW C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NROWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTOL C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C TO BE SET BY DJCK. C INTEGER NTOLI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C TO BE SET BY DJCK. C INTEGER OLMAVI C THE LOCATION IN ARRAY WORK OF C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OMEGAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C INTEGER PARTLI C THE LOCATION IN ARRAY WORK OF C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C DOUBLE PRECISION PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION PNORM C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C INTEGER PNORMI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C INTEGER PRERSI C THE LOCATION IN ARRAY WORK OF C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER QRAUXI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C INTEGER RCONDI C THE LOCATION IN ARRAY WORK OF C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C INTEGER RNORSI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C INTEGER RVARI C THE LOCATION IN ARRAY WORK OF C THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. C DOUBLE PRECISION SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS C INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG- C CALL (SHORT=.FALSE.). C INTEGER SI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED BETA'S. C INTEGER SSFI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE BETA'S. C INTEGER SSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE ESTIMATED BETA'S. C INTEGER SSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C DOUBLE PRECISION SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SSTOLI C THE LOCATION IN ARRAY WORK OF C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C DOUBLE PRECISION TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER TAUFCI C THE LOCATION IN ARRAY WORK OF C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C INTEGER TAUI C THE LOCATION IN ARRAY WORK OF C THE TRUST REGION DIAMETER. C DOUBLE PRECISION TEN C THE VALUE 10.0D0. C INTEGER TFJACI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER TI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED DELTA'S. C INTEGER TTI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE DELTA'S. C INTEGER UI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR TFJACB. C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WORK(LWORK) C THE DOUBLE PRECISION WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER WRK1I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WRK2I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C INTEGER WSSDEI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C INTEGER WSSEPI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER XPLUSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY X + DELTA. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER YTI C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DODDRV * * C SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE C (INVALID VALUES OF M AND/OR NP ARE HANDLED REASONABLY BY DIWINF) * CALL DIWINF(M,NP, + MSGB,MSGX,JPVTI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) * C SET STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE C (INVALID VALUES OF N, M AND/OR NP ARE HANDLED REASONABLY BY DWINF) * CALL DWINF(N,M,NP, + DELTAI,FI, + WSSI,WSSDEI,WSSEPI,RVARI, + PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI, + FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,DELTSI, + DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,TAUI, + ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,RCONDI, + ETAI,ACTRSI,PNORMI,PRERSI,RNORSI, + LWKMN) * C INITIALIZE NECESSARY VARIABLES * CALL DFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR,DOVCV) INFO = 0 * IF (RESTRT) THEN * C RESET MAXIMUM NUMBER OF ITERATIONS * IWORK(JOBI) = (JOB/10000)*10000 + MOD(IWORK(JOBI),10000) IWORK(MAXITI) = IWORK(MAXITI) + 10 WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI) CALL DCOPY(N,WORK(SSSI),1,WORK(FI),1) * ELSE * C PERFORM ERROR CHECKING * CALL DODCHK(N,NP,M, + IFIXB, + LDX,LDIFX,LDSCLD,LDWD, + LWORK,LWKMN,LIWORK,LIWKMN, + SCLD,SCLB,W,WD, + INFO) IF (INFO.NE.0) THEN GO TO 20 END IF * C INITIALIZE WORK VECTORS AS NECESSARY * CALL DINIWK(N,M,NP,WORK,LWORK,IWORK,LIWORK, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + BETA,SCLB, + SSTOL,PARTOL,MAXIT,TAUFAC, + JOB,IPRINT,LUNERR,LUNRPT, + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + JOBI,IPRINI,LUNERI,LUNRPI, + SSFI,TTI,LDTTI,DELTAI) * IWORK(INT2I) = 0 IWORK(IRANKI) = 0 IWORK(NFEVI) = 0 IWORK(NITERI) = 0 IWORK(NJEVI) = 0 IWORK(IDFI) = 0 * WORK(ACTRSI) = ZERO WORK(ALPHAI) = ZERO WORK(OLMAVI) = ZERO WORK(PNORMI) = ZERO WORK(PRERSI) = ZERO WORK(RCONDI) = ZERO WORK(WSSI) = ZERO WORK(WSSEPI) = ZERO WORK(WSSDEI) = ZERO WORK(RVARI) = ZERO WORK(RNORSI) = ZERO * WORK(TAUI) = -WORK(TAUFCI) * C SET UP FOR PARAMETER ESTIMATION - C PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES C AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY * CALL DPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB) IF (WORK(SSFI).GT.ZERO) THEN CALL DPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB) ELSE WORK(SSI) = WORK(SSFI) END IF * C EVALUATE THE WEIGHTED EPSILONS AT THE STARTING POINT * CALL DEVFUN(N,NP,M,WORK(BETACI),BETA,IFIXB,FUN, + X,LDX,Y,WORK(DELTAI),N,WORK(XPLUSI),N, + W,WORK(FI),IWORK(NFEVI),ISTOPF) IF (ISTOPF.NE.0) THEN INFO = 52000 GO TO 20 END IF * C FIND NUMBER OF NONZERO WEIGHTS * IF (W(1).LT.ZERO) THEN IWORK(NNZWI) = N ELSE IWORK(NNZWI) = 0 DO 10 I=1,N IF (W(I).GT.ZERO) THEN IWORK(NNZWI) = IWORK(NNZWI) + 1 END IF 10 CONTINUE END IF * C COMPUTE NORM OF THE INITIAL ESTIMATES * CALL DDIAGS(IWORK(NPPI),1,WORK(SSI),IWORK(NPPI), + WORK(BETACI),IWORK(NPPI),WORK(SSSI),IWORK(NPPI)) CALL DDIAGS(N,M,WORK(TTI),IWORK(LDTTI),WORK(DELTAI),N, + WORK(SSSI+IWORK(NPPI)),N) WORK(PNORMI) = DNRM2(IWORK(NPPI)+N*M,WORK(SSSI),1) * C COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS * CALL DCOPY(N,WORK(FI),1,WORK(SSSI),1) WORK(WSSEPI) = DDOT(N,WORK(SSSI),1,WORK(SSSI),1) CALL DWDS(N,M,W,WD,LDWD,WORK(DELTAI),N,WORK(SSSI+N),N) WORK(WSSDEI) = DDOT(N*M,WORK(SSSI+N),1,WORK(SSSI+N),1) WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) * C SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS * NROW = -1 CALL DSETN(N,M,WORK(XPLUSI),N,NROW) IWORK(NROWI) = NROW * C SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS * EPSMAC = WORK(EPSMAI) IF ((NDIGIT.LT.2) .OR. + (NDIGIT.GT.INT(-LOG10(EPSMAC)))) THEN IWORK(NETAI) = -1 NFEV = IWORK(NFEVI) CALL DETAF(FUN,NFEV, + N,NP,M,WORK(XPLUSI),N, + BETA,ETA,NETA,EPSMAC, + NROW,WORK(BETANI),WORK(FNI),ISTOPF) IWORK(NFEVI) = NFEV IF (ISTOPF.NE.0) THEN INFO = 53000 IWORK(NETAI) = 0 WORK(ETAI) = ZERO GO TO 20 ELSE IWORK(NETAI) = NETA WORK(ETAI) = ETA END IF ELSE IWORK(NETAI) = NDIGIT WORK(ETAI) = TEN**(-NDIGIT) END IF * C CHECK DERIVATIVES IF NECESSARY * IF (CHKJAC .AND. ANAJAC) THEN NTOL = -1 NFEV = IWORK(NFEVI) NJEV = IWORK(NJEVI) NETA = IWORK(NETAI) LDTT = IWORK(LDTTI) ETA = WORK(ETAI) EPSMAC = WORK(EPSMAI) CALL DJCK(FUN,JAC,NFEV,NJEV, + N,NP,M,BETA,WORK(XPLUSI),N, + ETA,NETA,NTOL, + WORK(SSFI),WORK(TTI),LDTT,NROW, + ISODR,EPSMAC, + WORK(FNI),WORK(FJACBI),N,WORK(FJACXI),N, + IWORK(MSGB),IWORK(MSGX),ISTOPF,ISTOPJ) IWORK(NFEVI) = NFEV IWORK(NJEVI) = NJEV IWORK(NTOLI) = NTOL IF (ISTOPF.NE.0) THEN INFO = 54000 ELSE IF (ISTOPJ.NE.0) THEN INFO = 50200 ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGX).NE.0) THEN INFO = 40000 END IF ELSE * C INDICATE USER-SUPPLIED DERIVATIVES WERE NOT CHECKED * IWORK(MSGB) = -1 IWORK(MSGX) = -1 END IF END IF * C PRINT APPROPRIATE ERROR MESSAGES * 20 IF (INFO.NE.0) THEN IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN CALL DODPER + (INFO,LUNERR,SHORT, + N,NP,M, + LDSCLD,LDWD, + LWKMN,LIWKMN, + SCLD,SCLB,W,WD, + IWORK(MSGB),ISODR,IWORK(MSGX), + WORK(XPLUSI),N,IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI)) END IF * C SET INFO TO REFLECT ERRORS IN THE USER-SUPPLIED JACOBIANS * IF (INFO.EQ.40000) THEN IF (IWORK(MSGB).EQ.1 .OR. IWORK(MSGX).EQ.1) THEN IF (IWORK(MSGB).EQ.1) THEN INFO = INFO + 1000 END IF IF (IWORK(MSGX).EQ.1) THEN INFO = INFO + 100 END IF ELSE INFO = 0 END IF END IF IF (INFO.NE.0) THEN RETURN END IF END IF * C FIND LEAST SQUARES SOLUTION * LDTT = IWORK(LDTTI) CALL DODMN(FUN,JAC, + N,NP,M, + X,LDX,IFIXX,LDIFX,Y, + WORK(BETACI),IFIXB,BETA,WORK(BETANI),WORK(BETASI), + WORK(SI),WORK(DELTAI),WORK(DELTNI),WORK(DELTSI), + WORK(TI),WORK(FI),WORK(FNI),WORK(FSI), + WORK(FJACBI),IWORK(MSGB),WORK(FJACXI),IWORK(MSGX), + W,WD,LDWD, + WORK(SSFI),WORK(SSI),WORK(TTI),LDTT, + WORK(XPLUSI),WORK(DDELTI),WORK(SSSI), + WORK,LWORK,IWORK,LIWORK,INFO) * RETURN * END *DODLM SUBROUTINE DODLM + (N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX, + W,WD,LDWD,SS,TT,LDTT,DDELT, + ALPHA2,TAU,EPSMAC, + SSS,WRK1,TFJACB,OMEGA,YT, + U,QRAUX,WRK2,JPVT, + S,T,NLMS,RCOND,IRANK) C***BEGIN PROLOGUE DODLM C***REFER TO DODR,DODRC C***ROUTINES CALLED DDIAGI,DDOT,DNRM2,DODSTP C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T C USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT C ALGORITHM C***END PROLOGUE DODLM * C...SCALAR ARGUMENTS DOUBLE PRECISION + ALPHA2,EPSMAC,RCOND,TAU INTEGER + IRANK,LDFJB,LDFJX,LDTT,LDWD,M,N,NLMS,NP,NPP * C...ARRAY ARGUMENTS DOUBLE PRECISION + DDELT(N,M),F(N),FJACB(LDFJB,NP),FJACX(LDFJX,M), + OMEGA(N),QRAUX(N),S(NP),SS(NP), + SSS(N+N*M),T(N,M),TFJACB(N,NP),TT(LDTT,M),U(N), + W(N),WD(LDWD,M),WRK1(N,M),WRK2(NP),YT(N) INTEGER + JPVT(NP) * C...LOCAL SCALARS DOUBLE PRECISION + ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO INTEGER + I,J * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT,DNRM2 EXTERNAL + DDOT,DNRM2 * C...EXTERNAL SUBROUTINES EXTERNAL + DDIAGI,DODSTP * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MAX,MIN,SQRT * C...DATA STATEMENTS DATA + ZERO,P001,P1 + /0.0D0,0.001D0,0.1D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION ALPHAN C THE NEW LEVENBERG-MARQUARDT PARAMETER. C DOUBLE PRECISION ALPHA1 C THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER. C DOUBLE PRECISION ALPHA2 C THE CURRENT LEVENBERG-MARQUARDT PARAMETER. C DOUBLE PRECISION BOT C THE LOWER LIMIT FOR SETTING ALPHA. C DOUBLE PRECISION DDELT(N,M) C THE ARRAY (W*D)**2 * DELTA. C DOUBLE PRECISION EPSMAC C THE VALUE OF MACHINE PRECISION. C DOUBLE PRECISION F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C DOUBLE PRECISION FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C DOUBLE PRECISION FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO X. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C INTEGER J C AN INDEXING VARIABLE. C INTEGER JPVT(NP) C THE PIVOT VECTOR. C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NLMS C THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C DOUBLE PRECISION OMEGA(N) C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C DOUBLE PRECISION P001 C THE VALUE 0.001D0 C DOUBLE PRECISION P1 C THE VALUE 0.1D0 C DOUBLE PRECISION PHI1 C THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP C AND THE TRUST REGION DIAMETER. C DOUBLE PRECISION PHI2 C THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP C AND THE TRUST REGION DIAMETER. C DOUBLE PRECISION QRAUX(N) C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C DOUBLE PRECISION RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C DOUBLE PRECISION S(NP) C THE STEP FOR THE ESTIMATED BETA'S. C DOUBLE PRECISION SA C THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2). C DOUBLE PRECISION SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SSS(N+N*M) C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C DOUBLE PRECISION T(N,M) C THE STEP FOR THE ESTIMATED DELTA'S. C DOUBLE PRECISION TAU C THE TRUST REGION DIAMETER. C DOUBLE PRECISION TFJACB(N,NP) C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C DOUBLE PRECISION TOP C THE UPPER LIMIT FOR SETTING ALPHA. C DOUBLE PRECISION TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION U(N) C THE APPROXIMATE NULL VECTOR FOR TFJACB. C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WRK1(N,M) C A WORK ARRAY. C DOUBLE PRECISION WRK2(NP) C A WORK ARRAY. C DOUBLE PRECISION YT(N) C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DODLM * * C COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0) * ALPHA1 = ZERO CALL DODSTP(N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX, + W,WD,LDWD,SS,TT,LDTT,DDELT, + ALPHA1,EPSMAC, + SSS,TFJACB,WRK1,OMEGA, + YT,U,QRAUX,WRK2, + JPVT,S,T,PHI1,IRANK, + RCOND) * C INITIALIZE TAU IF NECESSARY * IF (TAU.LT.ZERO) THEN TAU = ABS(TAU)*PHI1 END IF * C CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL * IF ((PHI1-TAU).LE.P1*TAU) THEN NLMS = 1 ALPHA2 = ZERO RETURN END IF * C FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION - C FIND LOCALLY CONSTRAINED OPTIMAL STEP * PHI1 = PHI1 - TAU * C INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA * BOT = ZERO * IF (NPP.GE.1) THEN DO 10 I=1,NPP SSS(I) = DDOT(N,FJACB(1,I),1,F,1) 10 CONTINUE CALL DDIAGI(NPP,1,SS,NPP,SSS,NPP,SSS,NPP) END IF DO 30 J=1,M DO 20 I=1,N WRK1(I,J) = FJACX(I,J)*F(I) + DDELT(I,J) 20 CONTINUE 30 CONTINUE CALL DDIAGI(N,M,TT,LDTT,WRK1,N,SSS(1+NPP),N) TOP = DNRM2(NPP+N*M,SSS,1)/TAU IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN ALPHA2 = P001*TOP END IF * C MAIN LOOP * DO 40 I=1,10 * C COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR C CURRENT VALUE OF ALPHA * CALL DODSTP(N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX, + W,WD,LDWD,SS,TT,LDTT,DDELT, + ALPHA2,EPSMAC, + SSS,TFJACB,WRK1,OMEGA, + YT,U,QRAUX,WRK2, + JPVT,S,T,PHI2,IRANK, + RCOND) PHI2 = PHI2-TAU * C CHECK WHETHER CURRENT STEP IS OPTIMAL * IF (ABS(PHI2).LE.P1*TAU .OR. + (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN NLMS = I+1 RETURN END IF * C CURRENT STEP IS NOT OPTIMAL * C UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA * IF (PHI1-PHI2.EQ.ZERO) THEN NLMS = 12 RETURN END IF SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2) IF (PHI2.LT.ZERO) THEN TOP = MIN(TOP,ALPHA2) ELSE BOT = MAX(BOT,ALPHA2) END IF IF (PHI1*PHI2.GT.ZERO) THEN BOT = MAX(BOT,ALPHA2-SA) ELSE TOP = MIN(TOP,ALPHA2-SA) END IF * ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT)) END IF * C GET READY FOR NEXT ITERATION * ALPHA1 = ALPHA2 ALPHA2 = ALPHAN PHI1 = PHI2 40 CONTINUE * C SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS * NLMS = 12 * RETURN END *DODMN SUBROUTINE DODMN + (FUN,JAC, + N,NP,M, + X,LDX,IFIXX,LDIFX,Y, + BETAC,IFIXB,BETA,BETAN,BETAS,S, + DELTA,DELTAN,DELTAS,T, + F,FN,FS, + FJACB,MSGB,FJACX,MSGX, + W,WD,LDWD,SSF,SS,TT,LDTT, + XPLUSD,DDELT,SSS, + WORK,LWORK,IWORK,LIWORK,INFO) C***BEGIN PROLOGUE DODMN C***REFER TO DODR,DODRC C***ROUTINES CALLED DACCES,DCOPY,DDIAGS,DDIAGW,DDOT,DEVFUN,DEVJAC, C DFLAGS,DIDTS,DNRM2,DODLM,DODPCR,DQRDC,DPODI, C DSCAL,DUNPAC,DWDS,DXPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE ITERATIVELY COMPUTE LEAST SQUARES SOLUTION C***END PROLOGUE DODMN * C...SCALAR ARGUMENTS INTEGER + INFO,LDIFX,LDTT,LDWD,LDX,LIWORK,LWORK,M, + N,NP * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP), + DDELT(N,M),DELTA(N,M),DELTAN(N,M),DELTAS(N,M), + F(N),FJACB(N,NP),FJACX(N,M),FN(N),FS(N), + S(NP),SS(NP),SSF(NP),SSS(N+N*M), + T(N,M),TT(LDTT,M),W(N),WD(LDWD,M),WORK(LWORK), + X(LDX,M),XPLUSD(N,M),Y(N) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK),MSGB(NP+1),MSGX(M+1) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS DOUBLE PRECISION + ACTRED,ACTRS,ALPHA,DIRDER,EPSMAC,OLMAVG,ONE, + P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS, + RATIO,RCOND,RNORM,RNORMN,RNORMS,RVAR,SSTOL,TAU,TAUFAC, + TEMP,TEMP1,TEMP2,TSNORM,WSS,WSSDEL,WSSEPS,ZERO INTEGER + I,IDF,IFLAG,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOPF,ISTOPJ,J, + JOB,JPVT,JUNFIX,LUNRPT,MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW, + NPP,OMEGA,QRAUX,TFJACB,U,WRK1,WRK2,YT LOGICAL + ACCESS,ANAJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV,FSTITR,HEAD, + INITD,INTDBL,ISODR,LSTEP,RESTRT * C...LOCAL ARRAYS DOUBLE PRECISION + W2(1) * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT,DNRM2 EXTERNAL + DDOT,DNRM2 * C...EXTERNAL SUBROUTINES EXTERNAL + DACCES,DCOPY,DDIAGS,DDIAGW,DEVFUN,DEVJAC,DFLAGS,DIDTS, + DODLM,DODPCR,DQRDC,DPODI,DSCAL,DUNPAC,DWDS,DXPY * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MIN,MOD,SQRT * C...DATA STATEMENTS DATA + ZERO,P0001,P1,P25,P5,P75,ONE,W2(1) + /0.0D0,0.00010D0,0.10D0,0.250D0, + 0.50D0,0.750D0,1.0D0,-1.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE FUNCTION. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ACCESS C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER INFORMATION C IS TO BE ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR C STORED IN THEM (ACCESS=FALSE). C DOUBLE PRECISION ACTRED C THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES OF THE C WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION ACTRS C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION BETAC(NP) C THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. C DOUBLE PRECISION BETAN(NP) C THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C DOUBLE PRECISION BETAS(NP) C THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C LOGICAL CNVPAR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER PARAMETER C CONVERGENCE HAS BEEN ATTAINED (CNVPAR=.TRUE.) OR NOT C (CNVPAR=.FALSE.). C LOGICAL CNVSS C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER SUM-OF-SQUARES C CONVERGENCE HAS BEEN ATTAINED (CNVSS=.TRUE.) OR NOT C (CNVSS=.FALSE.). C DOUBLE PRECISION DDELT(N,M) C THE ARRAY (W*D)**2 * DELTA. C DOUBLE PRECISION DELTA(N,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C DOUBLE PRECISION DELTAN(N,M) C THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C DOUBLE PRECISION DELTAS(N,M) C THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DIDVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX WAS COMPUTED (DIDVCV=.TRUE.) C OR NOT (DIDVCV=.FALSE.). C DOUBLE PRECISION DIRDER C THE DIRECTIONAL DERIVATIVE. C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX SHOULD TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C DOUBLE PRECISION EPSMAC C THE VALUE OF MACHINE PRECISION. C DOUBLE PRECISION F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C DOUBLE PRECISION FJACB(N,NP) C THE JACOBIAN WITH RESPECT TO BETA. C DOUBLE PRECISION FJACX(N,M) C THE JACOBIAN WITH RESPECT TO X. C DOUBLE PRECISION FN(N) C THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON. C DOUBLE PRECISION FS(N) C THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON. C LOGICAL FSTITR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THIS IS THE C FIRST ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). C LOGICAL HEAD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE C HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). C INTEGER I C AN INDEXING VARIABLE. C INTEGER IDF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFLAG C AN INDICATOR VARIABLE, USED TO SPECIFY WHICH COMPUTATION REPORT C IS TO BE PRINTED. C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C INTEGER INT2 C THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN. C LOGICAL INTDBL C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER INTERNAL C DOUBLING IS TO BE USED (INTDBL=.TRUE.) OR NOT (INTDBL=.FALSE.). C INTEGER IPR1 C THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE INITIAL SUMMARY REPORT. C INTEGER IPR2 C THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE ITERATION REPORTS. C INTEGER IPR2F C THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. C INTEGER IPR3 C THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FINAL SUMMARY REPORT. C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER ISTOPJ C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE JACOBIAN GIVEN THE CURRENT ESTIMATES C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER J C AN INDEX VARIABLE. C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JPVT C THE STARTING LOCATION IN IWORK OF C THE PIVOT VECTOR. C INTEGER JUNFIX C THE INDEX OF THE NEXT UNFIXED PARAMETER. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL LSTEP C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER A SUCCESSFUL C STEP HAS BEEN FOUND (LSTEP=.TRUE.) OR NOT (LSTEP=.FALSE.). C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NLMS C THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. C INTEGER NNZW C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C DOUBLE PRECISION OLMAVG C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OMEGA C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION P0001 C THE VALUE 0.0001D0. C DOUBLE PRECISION P1 C THE VALUE 0.1D0. C DOUBLE PRECISION P25 C THE VALUE 0.25D0. C DOUBLE PRECISION P5 C THE VALUE 0.5D0. C DOUBLE PRECISION P75 C THE VALUE 0.75D0. C DOUBLE PRECISION PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION PNORM C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C DOUBLE PRECISION PRERED C THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION PRERS C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER QRAUX C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C DOUBLE PRECISION RATIO C THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED C RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C DOUBLE PRECISION RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C DOUBLE PRECISION RNORM C THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION RNORMN C THE NORM OF THE NEW WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION RNORMS C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION RVAR C THE RESIDUAL VARIANCE. C DOUBLE PRECISION S(NP) C THE STEP FOR THE ESTIMATED BETA'S. C DOUBLE PRECISION SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SSF(NP) C THE SCALE USED FOR THE BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SSS(N+N*M) C THE WORK ARRAY USED PRIMARILY FOR COMPUTING VARIOUS C SUMS-OF-SQUARES. C DOUBLE PRECISION SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION T(N,M) C THE STEP FOR THE ESTIMATED DELTA'S. C DOUBLE PRECISION TAU C THE TRUST REGION DIAMETER. C DOUBLE PRECISION TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TEMP C A TEMPORARY STORAGE LOCATION. C DOUBLE PRECISION TEMP1 C A TEMPORARY STORAGE LOCATION. C DOUBLE PRECISION TEMP2 C A TEMPORARY STORAGE LOCATION. C INTEGER TFJACB C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB, C ALSO USED TO RETURN THE VARIANCE COVARIANCE MATRIX OF THE C ESTIMATORS OF THE PARAMETERS. C DOUBLE PRECISION TSNORM C THE NORM OF THE SCALED STEP. C DOUBLE PRECISION TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER U C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR TFJACB. C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WORK(LWORK) C THE DOUBLE PRECISION WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C DOUBLE PRECISION WSSDEL C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C DOUBLE PRECISION WSSEPS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C DOUBLE PRECISION W2(1) C THE VALUE USED TO INDICATE THAT THE DEFAULT VALUE C OF THE OBSERVATIONAL ERROR WEIGHTS IS TO BE USED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER WRK1 C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WRK2 C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY, C ALSO USED TO RETURN THE STANDARD ERRORS FOR THE PARAMETERS. C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION XPLUSD(N,M) C THE ARRAY X + DELTA. C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER YT C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DODMN * * C INITIALIZE NECESSARY VARIABLES * ACCESS = .TRUE. CALL DACCES(N,M,NP,WORK,LWORK,IWORK,LIWORK, + ACCESS, + JPVT,WRK1,TFJACB,OMEGA,YT,U,QRAUX,WRK2, + NNZW,NPP, + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,EPSMAC,NETA, + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS) RNORM = SQRT(WSS) CALL DFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR,DOVCV) * DIDVCV = .FALSE. INTDBL = .FALSE. LSTEP = .TRUE. HEAD = .TRUE. * FSTITR = .TRUE. * C PRINT INITIAL SUMMARY IF DESIRED * IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN IFLAG = 1 CALL DODPCR(HEAD,IFLAG,IPR1,FSTITR,DIDVCV,LUNRPT, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT,Y,W, + BETA,IFIXB,SSF,WORK(WRK2), + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO) END IF * C STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION * IF (RNORM .EQ. ZERO) THEN INFO = 1 OLMAVG = ZERO GO TO 40 END IF * C MAIN LOOP * 10 CONTINUE * NITER = NITER + 1 RNORMS = RNORM * C EVALUATE JACOBIAN * CALL DEVJAC(FUN,JAC,ANAJAC,N,NP,NPP,M,BETAC,BETA, + IFIXB,IFIXX,LDIFX, + X,LDX,DELTA,N,XPLUSD,N, + SS,TT,LDTT,NETA,FN,SSS, + FJACB,N,ISODR,FJACX,N,W,NJEV,NFEV,ISTOPJ) IF (ISTOPJ.NE.0) THEN INFO = 50100 GO TO 200 END IF * C COMPUTE DDELT = (W*D)**2 * DELTA * CALL DWDS(N,M,W,WD,LDWD,DELTA,N,DDELT,N) CALL DWDS(N,M,W,WD,LDWD,DDELT,N,DDELT,N) * C SUB LOOP FOR C INTERNAL DOUBLING OR C COMPUTING NEW STEP WHEN OLD FAILED * 20 CONTINUE * C COMPUTE STEPS S AND T * CALL DODLM(N,NP,NPP,M, + F,FJACB,N,FJACX,N, + W,WD,LDWD,SS,TT,LDTT,DDELT, + ALPHA,TAU,EPSMAC, + SSS,WORK(WRK1),WORK(TFJACB),WORK(OMEGA),WORK(YT), + WORK(U),WORK(QRAUX),WORK(WRK2),IWORK(JPVT), + S,T,NLMS,RCOND,IRANK) OLMAVG = OLMAVG+NLMS * C COMPUTE BETAN = BETAC + S C DELTAN = DELTA + T * CALL DXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP) CALL DXPY(N,M,DELTA,N,T,N,DELTAN,N) * C COMPUTE NORM OF SCALED STEPS S AND T (TSNORM) * IF (NPP.GE.1) THEN CALL DDIAGS(NPP,1,SS,NPP,S,NPP,SSS,NPP) END IF CALL DDIAGS(N,M,TT,LDTT,T,N,SSS(NPP+1),N) TSNORM = DNRM2(NPP+N*M,SSS,1) * C COMPUTE SCALED PREDICTED REDUCTION * DO 30 I=1,N SSS(I) = DDOT(NPP,FJACB(I,1),N,S,1) + + DDOT(M,FJACX(I,1),N,T(I,1),N) 30 CONTINUE CALL DWDS(N,M,W,WD,LDWD,T,N,SSS(N+1),N) TEMP1 = DNRM2(N+N*M,SSS,1)/RNORM TEMP2 = SQRT(ALPHA)*TSNORM/RNORM PRERED = TEMP1**2+TEMP2**2/P5 * DIRDER = -(TEMP1**2+TEMP2**2) * C EVALUATE WEIGHTED EPSILONS AT NEW POINT * CALL DEVFUN(N,NP,M,BETAN,BETA,IFIXB,FUN, + X,LDX,Y,DELTAN,N,XPLUSD,N, + W,FN,NFEV,ISTOPF) IF (ISTOPF.LT.0) THEN * C SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FUN * INFO = 51000 GO TO 200 ELSE IF (ISTOPF.GT.0) THEN * C SET NORM TO INDICATE STEP SHOULD BE REJECTED * RNORMN = RNORM/(P1*P75) ELSE * C COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN) * CALL DCOPY(N,FN,1,SSS,1) CALL DWDS(N,M,W,WD,LDWD,DELTAN,N,SSS(N+1),N) RNORMN = DNRM2(N+N*M,SSS,1) END IF * C COMPUTE SCALED ACTUAL REDUCTION * IF (P1*RNORMN.LT.RNORM) THEN ACTRED = ONE - (RNORMN/RNORM)**2 ELSE ACTRED = -ONE END IF * C COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION * IF(PRERED .EQ. ZERO) THEN RATIO = ZERO ELSE RATIO = ACTRED/PRERED END IF * C CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE * IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN TAU = TAU*P5 ALPHA = ALPHA/P5 CALL DCOPY(NPP,BETAS,1,BETAN,1) CALL DCOPY(N*M,DELTAS,1,DELTAN,1) CALL DCOPY(N,FS,1,FN,1) ACTRED = ACTRS PRERED = PRERS RNORMN = RNORMS RATIO = P5 END IF * C UPDATE STEP BOUND * INTDBL = .FALSE. IF (RATIO.LT.P25) THEN IF (ACTRED.GE.ZERO) THEN TEMP = P5 ELSE TEMP = P5*DIRDER/(DIRDER+P5*ACTRED) END IF IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN TEMP = P1 END IF TAU = TEMP*MIN(TAU,TSNORM/P1) ALPHA = ALPHA/TEMP * ELSE IF (ALPHA.EQ.ZERO) THEN TAU = TSNORM/P5 * ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN * C STEP QUALIFIES FOR INTERNAL DOUBLING C - UPDATE TAU AND ALPHA C - SAVE INFORMATION FOR CURRENT POINT * INTDBL = .TRUE. * TAU = TSNORM/P5 ALPHA = ALPHA*P5 * CALL DCOPY(NPP,BETAN,1,BETAS,1) CALL DCOPY(N*M,DELTAN,1,DELTAS,1) CALL DCOPY(N,FN,1,FS,1) ACTRS = ACTRED PRERS = PRERED RNORMS = RNORMN END IF * C IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS * IF (INTDBL .AND. TAU.GT.ZERO) THEN INT2 = INT2+1 GO TO 20 END IF * C CHECK ACCEPTANCE * IF (RATIO.GE.P0001) THEN CALL DCOPY(N,FN,1,F,1) CALL DCOPY(NPP,BETAN,1,BETAC,1) CALL DCOPY(N*M,DELTAN,1,DELTA,1) RNORM = RNORMN IF (NPP.GE.1) THEN CALL DDIAGS(NPP,1,SS,NPP,BETAC,NPP,SSS,NPP) END IF CALL DDIAGS(N,M,TT,LDTT,DELTA,N,SSS(NPP+1),N) PNORM = DNRM2(NPP+N*M,SSS,1) LSTEP = .TRUE. ELSE LSTEP = .FALSE. END IF * C TEST CONVERGENCE * INFO = 0 CNVSS = RNORM.EQ.ZERO + .OR. + (ABS(ACTRED).LE.SSTOL .AND. + PRERED.LE.SSTOL .AND. + P5*RATIO.LE.ONE) CNVPAR = TAU.LE.PARTOL*PNORM IF (CNVSS) INFO = 1 IF (CNVPAR) INFO = 2 IF (CNVSS .AND. CNVPAR) INFO = 3 * C PRINT ITERATION REPORT * IF (INFO.NE.0 .OR. LSTEP) THEN IF (IPR2.NE.0 .AND. LUNRPT.NE.0) THEN IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN IFLAG = 2 CALL DUNPAC(NP,BETAC,BETA,IFIXB) WSS = RNORM*RNORM CALL DODPCR(HEAD,IFLAG,IPR2,FSTITR,DIDVCV,LUNRPT, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT,Y,W, + BETA,IFIXB,SSF,WORK(WRK2), + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO) FSTITR = .FALSE. END IF END IF END IF * C CHECK IF FINISHED * IF (INFO.EQ.0) THEN IF (LSTEP) THEN * C BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET * IF (NITER.GE.MAXIT) THEN INFO = 4 ELSE GO TO 10 END IF ELSE * C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET * GO TO 20 END IF END IF * 40 CONTINUE * IF (ISTOPF.GT.0) INFO = INFO + 100 * C COMPUTE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER * CALL DEVFUN(N,NP,M,BETAC,BETA,IFIXB,FUN, + X,LDX,Y,DELTA,N,XPLUSD,N, + W2,F,NFEV,ISTOPF) IF (ISTOPF.LT.0) THEN INFO = 51000 GO TO 200 END IF * C COMPUTE VARIANCE COVARIANCE MATRIX OF ESTIMATED PARAMETERS C IN UPPER TRIANGULAR PORTION OF WORK(TFJACB) IF REQUESTED * IF (DOVCV .AND. IRANK.EQ.0 .AND. ISTOPF.EQ.0) THEN * C EVALUATE JACOBIANS AT FINAL SOLUTION * CALL DEVJAC(FUN,JAC,ANAJAC,N,NP,NPP,M,BETAC,BETA, + IFIXB,IFIXX,LDIFX, + X,LDX,DELTA,N,XPLUSD,N, + SSF,TT,LDTT,NETA,FN,SSS, + FJACB,N,ISODR,FJACX,N,W,NJEV,NFEV,ISTOPJ) IF (ISTOPJ.NE.0) THEN INFO = 50100 GO TO 200 END IF IDF = 0 DO 70 I=1,N DO 50 J=1,NPP IF (FJACB(I,J).NE.ZERO) THEN IDF = IDF + 1 GO TO 70 END IF 50 CONTINUE DO 60 J=1,M IF (FJACX(I,J).NE.ZERO) THEN IDF = IDF + 1 GO TO 70 END IF 60 CONTINUE 70 CONTINUE * IF (ISODR) THEN * C PROBLEM IS ODR -- C SET UP OMEGA AND TFJACB C (VDTD = FJACX * INV(DT) WHERE DT = (W*D)**2) * CALL DIDTS(N,M, + W,WD,LDWD,ZERO,TT,LDTT,FJACX,N,WORK(WRK1),N) DO 90 I=1,N WORK(OMEGA-1+I) = + SQRT(ONE+DDOT(M,WORK(WRK1+I-1),N,FJACX(I,1),N)) DO 80 J=1,NPP WORK(TFJACB-1+I+(J-1)*N) = FJACB(I,J)/WORK(OMEGA-1+I) 80 CONTINUE 90 CONTINUE * ELSE * C PROBLEM IS OLS -- * CALL DCOPY(N*NPP,FJACB,1,WORK(TFJACB),1) * END IF * CALL DQRDC + (WORK(TFJACB),N,N,NPP,WORK(QRAUX),IWORK(JPVT),WORK(WRK2),0) CALL DPODI + (WORK(TFJACB),N,NPP,WORK(WRK2),1) * IF (IDF.GT.NPP) THEN IDF = IDF - NPP RVAR = RNORM*RNORM/IDF ELSE IDF = 0 RVAR = RNORM*RNORM END IF * CALL DSCAL + (N*NPP,RVAR,WORK(TFJACB),1) CALL DCOPY + (NPP,WORK(TFJACB),N+1,WORK(WRK2),1) IF (NP.GT.NPP) THEN JUNFIX = NPP-1 DO 100 J=NP-1,0,-1 IF (IFIXB(J+1).EQ.0) THEN WORK(WRK2+J) = ZERO ELSE WORK(WRK2+J) = SQRT(WORK(WRK2+JUNFIX)) JUNFIX = JUNFIX - 1 END IF 100 CONTINUE ELSE DO 110 J=0,NP-1 WORK(WRK2+J) = SQRT(WORK(WRK2+J)) 110 CONTINUE END IF * DIDVCV = .TRUE. * END IF * C STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER * 200 OLMAVG = OLMAVG/NITER * C COMPUTE WEIGHTED EPSILONS AND WEIGHTED DELTAS FOR RETURN TO USER * CALL DDIAGW(N,1,W,F,N,SSS,N) WSSEPS = DDOT(N,SSS,1,SSS,1) CALL DWDS(N,M,W,WD,LDWD,DELTA,N,SSS(N+1),N) WSSDEL = DDOT(N*M,SSS(N+1),1,SSS(N+1),1) WSS = WSSEPS + WSSDEL * C COMPUTE ESTIMATED RESPONSE VARIABLE RETURN TO USER, I.E., C EST = OBS + EST * CALL DXPY(N,1,Y,N,F,N,FN,N) * ACCESS = .FALSE. CALL DACCES(N,M,NP,WORK,LWORK,IWORK,LIWORK, + ACCESS, + JPVT,WRK1,TFJACB,OMEGA,YT,U,QRAUX,WRK2, + NNZW,NPP, + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,EPSMAC,NETA, + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS) * C ENCODE EXISTANCE OF QUESTIONABLE RESULTS INTO INFO * IF (INFO.LE.9) THEN IF (MSGB(1).EQ.2 .OR. MSGX(1).EQ.2) THEN INFO = INFO + 1000 END IF IF (ISTOPF.NE.0) THEN INFO = INFO + 100 END IF IF (IRANK.GE.1) THEN IF (NPP.GT.IRANK) THEN INFO = INFO + 10 ELSE INFO = INFO + 20 END IF END IF END IF * C PRINT FINAL SUMMARY * IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN IFLAG = 3 * CALL DODPCR(HEAD,IFLAG,IPR3,FSTITR,DIDVCV,LUNRPT, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT,Y,W, + BETA,IFIXB,SSF,WORK(WRK2), + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO) END IF * RETURN * END *DODPC1 SUBROUTINE DODPC1 + (IPR,LUNRPT, + ANAJAC,CHKJAC,INITD,RESTRT,ISODR,DOVCV, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT, + Y,W, + BETA,IFIXB,SSF, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS) C***BEGIN PROLOGUE DODPC1 C***REFER TO DODR,DODRC C***ROUTINES CALLED NONE C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE GENERATE INITIAL SUMMARY REPORT C***END PROLOGUE DODPC1 * C...SCALAR ARGUMENTS DOUBLE PRECISION + PARTOL,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS INTEGER + IPR,JOB,LDIFX,LDTT,LDWD,LDX,LUNRPT,M,MAXIT,N,NETA,NNZW,NP,NPP LOGICAL + ANAJAC,CHKJAC,DOVCV,INITD,ISODR,RESTRT * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),DELTA(N,M),SSF(NP),TT(LDTT,M),W(N),WD(LDWD,M), + X(LDX,M),Y(N) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NP+1),MSGX(M+1) * C...LOCAL SCALARS DOUBLE PRECISION + ONE,ZERO INTEGER + J,K,L,NPLM1 CHARACTER FMT1*90 * C...LOCAL ARRAYS CHARACTER TEMPC(10)*5 * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MIN * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0D0,1.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C DOUBLE PRECISION DELTA(N,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C CHARACTER*90 FMT1 C A CHARACTER VARIABLE USED FOR FORMATS. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C INTEGER IPR C THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER J C AN INDEXING VARIABLE. C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER K C AN INDEXING VARIABLE. C INTEGER L C AN INDEXING VARIABLE. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NNZW C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPLM1 C THE NUMBER OF ITEMS TO PRINT PER LINE, MINUS ONE. C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C DOUBLE PRECISION SSF(NP) C THE SCALE USED FOR THE BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C CHARACTER*5 TEMPC(10) C A TEMPORARY CHARACTER VECTOR. C DOUBLE PRECISION TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C DOUBLE PRECISION WSSDEL C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C DOUBLE PRECISION WSSEPS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DODPC1 * * C PRINT PROBLEM SIZE SPECIFICATION * WRITE (LUNRPT,1000) N,NNZW,M,NP,NPP * IF (IPR.GE.2) THEN * C PRINT INDEPENDENT VARIABLE DATA * IF (ISODR) THEN WRITE (LUNRPT,2010) ELSE WRITE (LUNRPT,2020) END IF NPLM1 = 1 DO 20 J = 1,M,NPLM1+1 IF (.NOT.ISODR) THEN L = MIN(M,J+NPLM1) - J + 1 WRITE (FMT1,7000) 6,L WRITE (LUNRPT,FMT1) (K,K=J,MIN(M,J+NPLM1)) WRITE (FMT1,8000) 5,L WRITE (LUNRPT,FMT1) WRITE (LUNRPT,2100) (X(1,K),X(N,K),K=J,MIN(M,J+NPLM1)) ELSE L = MIN(M,J+NPLM1) - J + 1 WRITE (FMT1,7000) 20,L WRITE (LUNRPT,FMT1) (K,K=J,MIN(M,J+NPLM1)) WRITE (FMT1,8000) 19,L WRITE (LUNRPT,FMT1) WRITE (LUNRPT,2200) (X(1,K),X(N,K),K=J,MIN(M,J+NPLM1)) IF (IFIXX(1,1).LT.0) THEN WRITE (LUNRPT,2300) (' NO',K=1,2*L) ELSE L = 0 DO 10 K=J,MIN(M,J+NPLM1) L = L + 1 IF (IFIXX(1,K).EQ.0) THEN TEMPC(2*L-1) = ' YES' ELSE TEMPC(2*L-1) = ' NO' END IF IF (LDIFX.EQ.1) THEN IF (IFIXX(1,K).EQ.0) THEN TEMPC(2*L) = ' YES' ELSE TEMPC(2*L) = ' NO' END IF ELSE IF (IFIXX(N,K).EQ.0) THEN TEMPC(2*L) = ' YES' ELSE TEMPC(2*L) = ' NO' END IF END IF 10 CONTINUE WRITE (LUNRPT,2300) (TEMPC(K),K=1,2*L) END IF WRITE (LUNRPT,2500) (DELTA(1,K),DELTA(N,K), + K=J,MIN(M,J+NPLM1)) IF (TT(1,1).LT.0) THEN WRITE (LUNRPT,2600) (ABS(TT(1,1)),ABS(TT(1,1)), + K=J,MIN(M,J+NPLM1)) ELSE IF (LDTT.EQ.1) THEN WRITE (LUNRPT,2600) (TT(1,K),TT(1,K), + K=J,MIN(M,J+NPLM1)) ELSE WRITE (LUNRPT,2600) (TT(1,K),TT(N,K), + K=J,MIN(M,J+NPLM1)) END IF END IF IF (WD(1,1).LT.0) THEN WRITE (LUNRPT,2700) (ABS(WD(1,1)),ABS(WD(1,1)), + K=J,MIN(M,J+NPLM1)) ELSE IF (LDWD.EQ.1) THEN WRITE (LUNRPT,2700) (WD(1,K),WD(1,K), + K=J,MIN(M,J+NPLM1)) ELSE WRITE (LUNRPT,2700) (WD(1,K),WD(N,K), + K=J,MIN(M,J+NPLM1)) END IF END IF END IF 20 CONTINUE * C PRINT DEPENDENT VARIABLE DATA AND OBSERVATION ERROR WEIGHTS * WRITE (LUNRPT,3000) WRITE (FMT1,8000) 19,1 WRITE (LUNRPT,FMT1) WRITE (LUNRPT,3100) Y(1),Y(N) IF (W(1).LT.ZERO) THEN WRITE (LUNRPT,3200) ONE,ONE ELSE WRITE (LUNRPT,3200) W(1),W(N) END IF * C PRINT FUNCTION PARAMETER DATA * WRITE (LUNRPT,4000) NPLM1 = 3 DO 50 J=1,NP,NPLM1+1 WRITE (LUNRPT,4100) (K,K=J,MIN(NP,J+NPLM1)) WRITE (LUNRPT,4200) (BETA(K),K=J,MIN(NP,J+NPLM1)) L = 0 IF (IFIXB(1).LT.0) THEN DO 30 K=J,MIN(NP,J+NPLM1) L = L + 1 TEMPC(L) = ' NO' 30 CONTINUE ELSE DO 40 K=J,MIN(NP,J+NPLM1) L = L + 1 IF (IFIXB(K).NE.0) THEN TEMPC(L) = ' NO' ELSE TEMPC(L) = ' YES' END IF 40 CONTINUE END IF WRITE (LUNRPT,4300) (TEMPC(K),K=1,L) IF (SSF(1).LT.ZERO) THEN WRITE (LUNRPT,4400) (ABS(SSF(1)),K=J,MIN(NP,J+NPLM1)) ELSE WRITE (LUNRPT,4400) (SSF(K),K=J,MIN(NP,J+NPLM1)) END IF 50 CONTINUE END IF * C PRINT JOB SPECS AND STOPPING CRITERIA * WRITE (LUNRPT,5000) JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT IF (RESTRT) THEN WRITE (LUNRPT,5110) ELSE WRITE (LUNRPT,5120) END IF IF (ISODR) THEN IF (INITD) THEN WRITE (LUNRPT,5211) ELSE WRITE (LUNRPT,5212) END IF ELSE WRITE (LUNRPT,5220) END IF IF (DOVCV) THEN WRITE (LUNRPT,5310) ELSE WRITE (LUNRPT,5320) END IF IF (ANAJAC) THEN WRITE (LUNRPT,5410) IF (CHKJAC) THEN WRITE (LUNRPT,5411) IF (MSGB(1).EQ.2 .OR. MSGX(1).EQ.2) THEN WRITE (LUNRPT,5412) ELSE WRITE (LUNRPT,5413) END IF ELSE WRITE (LUNRPT,5414) END IF ELSE WRITE (LUNRPT,5420) END IF IF (ISODR) THEN WRITE (LUNRPT,5510) ELSE WRITE (LUNRPT,5520) END IF * C PRINT INITIAL SUM OF SQUARES * WRITE (LUNRPT,6000) WRITE (LUNRPT,6100) WSS IF (ISODR) THEN WRITE (LUNRPT,6200) WSSDEL WRITE (LUNRPT,6300) WSSEPS END IF * RETURN * C FORMAT STATEMENTS * 1000 FORMAT + (///' PROBLEM SIZE:'/ + ' -------------'// + ' NUMBER OF OBSERVATIONS ',I5/ + ' NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS ',I5/ + ' NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE ',I5/ + ' NUMBER OF FUNCTION PARAMETERS ',I5/ + ' NUMBER OF UNFIXED FUNCTION PARAMETERS ',I5) 2010 FORMAT + (///' INDEPENDENT VARIABLE AND DELTA WEIGHT SUMMARY:'/ + ' ----------------------------------------------') 2020 FORMAT + (///' INDEPENDENT VARIABLE SUMMARY:'/ + ' -----------------------------') 2100 FORMAT + (' X - ', 6D13.5) 2200 FORMAT + (' X - ', 6D13.5) 2300 FORMAT + (' FIXED - ', 6(8X,A5)) 2500 FORMAT + (' INITIAL DELTA - ', 6D13.5) 2600 FORMAT + (' DELTA SCALE - ', 6D13.5) 2700 FORMAT + (' DELTA WEIGHTS - ', 6D13.5) 3000 FORMAT + (///' DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT', + ' SUMMARY:'/ + ' -------------------------------------------------', + '---------'/) 3100 FORMAT + (' Y - ', 6D13.5) 3200 FORMAT + (' OBS. ERROR WTS. - ', 6D13.5) 4000 FORMAT + (///' FUNCTION PARAMETER SUMMARY:'/ + ' ---------------------------') 4100 FORMAT + (/' INDEX - ', 5I16) 4200 FORMAT + (' INITIAL BETA - ', 5D16.8) 4300 FORMAT + (' FIXED - ', 5(11X,A5)) 4400 FORMAT + (' BETA SCALE - ', 5D16.8) 5000 FORMAT + (///' CONTROL VALUES AND STOPPING CRITERIA:'/ + ' --------------------------------------'// + ' * '/ + ' JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT'/ + 1X,I6.5,5X,I5,3D10.2,I7//' *') 5110 FORMAT + (' A. FIT IS A RESTART.') 5120 FORMAT + (' A. FIT IS NOT A RESTART.') 5211 FORMAT + (' B. DELTAS ARE INITIALIZED TO ZERO.') 5212 FORMAT + (' B. DELTAS ARE INITIALIZED BY USER.') 5220 FORMAT + (' B. DELTAS ARE FIXED AT ZERO.') 5310 FORMAT + (' C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS'/ + ' WILL BE COMPUTED AT THE SOLUTION.') 5320 FORMAT + (' C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS'/ + ' WILL NOT BE COMPUTED AT THE SOLUTION.') 5410 FORMAT + (' D. DERIVATIVES ARE SUPPLIED BY USER.') 5411 FORMAT + (' USER-SUPPLIED DERIVATIVES WERE CHECKED.') 5412 FORMAT + (' THE CORRECTNESS OF SOME OF THE DERIVATIVES IS'/ + ' QUESTIONABLE. SEE ERROR MESSAGES FOR DETAILS.') 5413 FORMAT + (' THE DERIVATIVES APPEAR TO BE CORRECT.') 5414 FORMAT + (' USER-SUPPLIED DERIVATIVES WERE NOT CHECKED.') 5420 FORMAT + (' D. DERIVATIVES ARE COMPUTED BY FINITE DIFFERENCES.') 5510 FORMAT + (' E. FIT IS BY METHOD OF ORTHOGONAL DISTANCE REGRESSION.') 5520 FORMAT + (' E. FIT IS BY METHOD OF ORDINARY LEAST SQUARES.') 6000 FORMAT + (///' INITIAL SUMS OF SQUARES:'/ + ' ------------------------'/) 6100 FORMAT + ( ' SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS ', D17.8) 6200 FORMAT + ( ' SUM OF SQUARED WEIGHTED DELTAS ', D17.8) 6300 FORMAT + ( ' SUM OF SQUARED WEIGHTED EPSILONS ', D17.8) 7000 FORMAT + ('(/',I2,'X,',I2,'('' COLUMN '',I3,'' ''))') 8000 FORMAT + ('(',I2,'X,',I2,'('' OBS 1 OBS N''))') END *DODPC2 SUBROUTINE DODPC2 + (IPR,FSTITR,LUNRPT,NP, + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,BETA) C***BEGIN PROLOGUE DODPC2 C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE GENERATE ITERATION REPORTS C***END PROLOGUE DODPC2 * C...SCALAR ARGUMENTS DOUBLE PRECISION + ACTRED,ALPHA,PNORM,PRERED,TAU,WSS INTEGER + IPR,LUNRPT,NFEV,NITER,NP LOGICAL + FSTITR * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP) * C...LOCAL SCALARS DOUBLE PRECISION + RATIO,ZERO INTEGER + J,K,L CHARACTER GN*3 * C...INTRINSIC FUNCTIONS INTRINSIC + MIN * C...DATA STATEMENTS DATA + ZERO + /0.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION ACTRED C THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL FSTITR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THIS IS THE C FIRST ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). C CHARACTER*3 GN C THE CHARACTER VARIABLE USED TO INDICATE WHETHER A GAUSS-NEWTON C STEP WAS TAKEN. C INTEGER IPR C THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED. C INTEGER J C AN INDEXING VARIABLE. C INTEGER K C AN INDEXING VARIABLE. C INTEGER L C AN INDEXING VARIABLE. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE NUMBER OF ITERATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION PNORM C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C DOUBLE PRECISION PRERED C THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION RATIO C THE RATIO OF TAU TO PNORM. C DOUBLE PRECISION TAU C THE TRUST REGION DIAMETER. C DOUBLE PRECISION WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DODPC2 * * IF (FSTITR) THEN IF (IPR.EQ.1) THEN WRITE (LUNRPT,1120) ELSE WRITE (LUNRPT,1130) END IF END IF IF (ALPHA.EQ.ZERO) THEN GN = 'YES' ELSE GN = ' NO' END IF IF (PNORM.NE.ZERO) THEN RATIO = TAU/PNORM ELSE RATIO = ZERO END IF IF (IPR.EQ.1) THEN WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + RATIO,GN ELSE J = 1 K = MIN(3,NP) IF (J.EQ.K) THEN WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + RATIO,GN,J,BETA(J) ELSE WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED, + RATIO,GN,J,K,(BETA(L),L=J,K) END IF IF (NP.GT.3) THEN DO 10 J=4,NP,3 K = MIN(J+2,NP) IF (J.EQ.K) THEN WRITE (LUNRPT,1151) J,BETA(J) ELSE WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K) END IF 10 CONTINUE END IF END IF * RETURN * C FORMAT STATEMENTS * 1120 FORMAT + (// + ' CUM. ACT. REL. PRED. REL.'/ + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + ' G-N'/ + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + ' TAU/PNORM STEP'/ + ' ---- ------ ----------- ----------- -----------', + ' --------- ----'/) 1130 FORMAT + (// + ' CUM. ACT. REL. PRED. REL.'/ + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + ' G-N BETA -------------->'/ + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + ' TAU/PNORM STEP INDEX VALUE'/ + ' ---- ------ ----------- ----------- -----------', + ' --------- ---- ----- -----'/) 1141 FORMAT + (1X,I4,I8,1X,D12.5,2D13.4,D11.3,3X,A3,7X,I3,3D16.8) 1142 FORMAT + (1X,I4,I8,1X,D12.5,2D13.4,D11.3,3X,A3,1X,I3,' TO',I3,3D16.8) 1151 FORMAT + (76X,I3,D16.8) 1152 FORMAT + (70X,I3,' TO',I3,3D16.8) END *DODPC3 SUBROUTINE DODPC3 + (IPR,LUNRPT, + N,M,NP,NPP, + INFO,NITER,NFEV,NJEV,RCOND,IRANK, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + BETA,SDBETA,IFIXB,F,ISODR,DIDVCV,DOVCV,ANAJAC,DELTA) C***BEGIN PROLOGUE DODPC3 C***REFER TO DODR,DODRC C***ROUTINES CALLED NONE C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE GENERATE FINAL SUMMARY REPORT C***END PROLOGUE DODPC3 * C...SCALAR ARGUMENTS DOUBLE PRECISION + RCOND,RVAR,WSS,WSSDEL,WSSEPS INTEGER + IDF,INFO,IPR,IRANK,LUNRPT,M,N,NFEV,NITER,NJEV,NP,NPP LOGICAL + ANAJAC,DIDVCV,DOVCV,ISODR * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),DELTA(N,M),F(N),SDBETA(NP) INTEGER + IFIXB(NP) * C...LOCAL SCALARS INTEGER + D1,D2,D3,D4,D5,I,J,K,L,LAST,MAXLST,NPLM1 CHARACTER FMT1*90 * C...INTRINSIC FUNCTIONS INTRINSIC + MIN,MOD * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER D1 C THE FIRST DIGIT OF INFO. C INTEGER D2 C THE SECOND DIGIT OF INFO. C INTEGER D3 C THE THIRD DIGIT OF INFO. C INTEGER D4 C THE FOURTH DIGIT OF INFO. C INTEGER D5 C THE FIFTH DIGIT OF INFO. C DOUBLE PRECISION DELTA(N,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DIDVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX WAS COMPUTED (DIDVCV=.TRUE.) C OR NOT (DIDVCV=.FALSE.). C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C DOUBLE PRECISION F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C CHARACTER*90 FMT1 C A CHARACTER VARIABLE USED FOR FORMATS. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IDF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C INTEGER IPR C THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED. C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER J C AN INDEXING VARIABLE. C INTEGER K C AN INDEXING VARIABLE. C INTEGER L C AN INDEXING VARIABLE. C INTEGER LAST C THE LAST ROW OF THE GIVEN ARRAY TO BE PRINTED. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXLST C THE MAXIMUM NUMBER OF ITEMS TO BE PRINTED. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE NUMBER OF ITERATIONS. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPLM1 C THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE. C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C DOUBLE PRECISION RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C DOUBLE PRECISION RVAR C THE RESIDUAL VARIANCE. C DOUBLE PRECISION SDBETA(NP) C THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS. C DOUBLE PRECISION WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C DOUBLE PRECISION WSSDEL C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C DOUBLE PRECISION WSSEPS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. * * C***FIRST EXECUTABLE STATEMENT DODPC3 * * D1 = INFO/10000 D2 = MOD(INFO,10000)/1000 D3 = MOD(INFO,1000)/100 D4 = MOD(INFO,100)/10 D5 = MOD(INFO,10) * C PRINT STOPPING CONDITIONS * WRITE (LUNRPT,1000) INFO IF (D1.EQ.5) THEN IF (D2.NE.0) THEN WRITE (LUNRPT,1110) ELSE IF (D3.NE.0) THEN WRITE (LUNRPT,1115) END IF ELSE IF (D5.EQ.1) THEN WRITE (LUNRPT,1120) ELSE IF (D5.EQ.2) THEN WRITE (LUNRPT,1130) ELSE IF (D5.EQ.3) THEN WRITE (LUNRPT,1140) ELSE IF (D5.EQ.4) THEN WRITE (LUNRPT,1150) ELSE WRITE (LUNRPT,1160) END IF * C PRINT WARNING DIAGNOSTICS * IF (D2.NE.0 .OR. D3.NE.0 .OR. D4.NE.0) THEN WRITE (LUNRPT,1210) IF (D2.NE.0) THEN IF (D3.NE.0 .OR. D4.NE.0) THEN WRITE (LUNRPT,1220) ', AND' ELSE WRITE (LUNRPT,1220) '. ' END IF END IF IF (D3.NE.0) THEN IF (D4.NE.0) THEN WRITE (LUNRPT,1230) ', AND' ELSE WRITE (LUNRPT,1230) '. ' END IF END IF IF (D4.EQ.1) THEN WRITE (LUNRPT,1240) END IF IF (D4.EQ.2) THEN WRITE (LUNRPT,1250) END IF END IF END IF * C PRINT MISC. STOPPING INFO * IF (ANAJAC) THEN WRITE (LUNRPT,1300) NITER,NFEV,NJEV,RCOND,IRANK ELSE WRITE (LUNRPT,1400) NITER,NFEV,RCOND,IRANK END IF * C PRINT FINAL SUM OF SQUARES * WRITE (LUNRPT,2000) WRITE (LUNRPT,2100) WSS IF (ISODR) THEN WRITE (LUNRPT,2200) WSSDEL WRITE (LUNRPT,2300) WSSEPS END IF IF (DIDVCV) THEN WRITE (LUNRPT,2400) RVAR WRITE (LUNRPT,2500) IDF END IF * NPLM1 = 3 * C PRINT ESTIMATED BETA'S, AND, C IF, FULL RANK, THEIR STANDARD ERRORS * WRITE (LUNRPT,3000) IF (DIDVCV) THEN WRITE (LUNRPT,7300) * DO 10 J=1,NP IF (NP.EQ.NPP) THEN WRITE (LUNRPT,8100) J,BETA(J),SDBETA(J) ELSE IF (IFIXB(J).EQ.0) THEN WRITE (LUNRPT,8400) J,BETA(J) ELSE WRITE (LUNRPT,8100) J,BETA(J),SDBETA(J) END IF END IF 10 CONTINUE ELSE IF (DOVCV) WRITE (LUNRPT,7400) IF (NP.EQ.1) THEN WRITE (LUNRPT,7100) ELSE WRITE (LUNRPT,7200) END IF * DO 20 J=1,NP,NPLM1+1 K = MIN(J+NPLM1,NP) IF (K.EQ.J) THEN WRITE (LUNRPT,8100) J,BETA(J) ELSE WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K) END IF 20 CONTINUE END IF * C PRINT ESTIMATED EPSILON'S AND DELTA'S * MAXLST = 32 IF (IPR.GE.2 .OR. N.LT.MAXLST) THEN LAST = N ELSE LAST = MAXLST END IF * C PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF C COLUMNS OF DATA IN DELTA IS LESS THAN OR EQUAL TO THREE. * IF (ISODR .AND. M.LE.3) THEN WRITE (LUNRPT,4100) WRITE (FMT1,9100) M WRITE (LUNRPT,FMT1) (J,J=1,M) DO 30 I=1,LAST WRITE (LUNRPT,4110) I,F(I),(DELTA(I,J),J=1,M) 30 CONTINUE IF (N.GT.LAST) THEN IF (N.LE.LAST+4) THEN DO 40 I=LAST+1,N WRITE (LUNRPT,4110) I,F(I),(DELTA(I,J),J=1,M) 40 CONTINUE ELSE WRITE (FMT1,9200) M+1 WRITE (LUNRPT,FMT1) WRITE (LUNRPT,FMT1) WRITE (LUNRPT,FMT1) WRITE (LUNRPT,4110) N,F(N),(DELTA(N,J),J=1,M) END IF END IF ELSE * C PRINT EPSILON'S AND DELTA'S SEPARATELY * C PRINT EPSILON'S * WRITE (LUNRPT,4200) IF (LAST.EQ.1) THEN WRITE (LUNRPT,7100) ELSE WRITE (LUNRPT,7200) END IF DO 50 I=1,LAST,NPLM1+1 K = MIN(I+NPLM1,LAST) IF (I.EQ.K) THEN WRITE (LUNRPT,8100) I,F(I) ELSE WRITE (LUNRPT,8200) I,K,(F(L),L=I,K) END IF 50 CONTINUE IF (N.GT.LAST) THEN IF (N.EQ.LAST+1) THEN WRITE (LUNRPT,8100) N,F(N) ELSE IF (N.GT.LAST+1) THEN WRITE (LUNRPT,8300) N,F(N) END IF END IF * C PRINT DELTA'S * IF (ISODR) THEN DO 70 J=1,M WRITE (LUNRPT,4300) J IF (LAST.EQ.1) THEN WRITE (LUNRPT,7100) ELSE WRITE (LUNRPT,7200) END IF DO 60 I=1,LAST,NPLM1+1 K = MIN(I+NPLM1,LAST) IF (I.EQ.K) THEN WRITE (LUNRPT,8100) I,DELTA(I,J) ELSE WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K) END IF 60 CONTINUE IF (N.EQ.LAST+1) THEN WRITE (LUNRPT,8100) N,DELTA(N,J) ELSE IF (N.GT.LAST+1) THEN WRITE (LUNRPT,8300) N,DELTA(N,J) END IF 70 CONTINUE END IF END IF * RETURN * C FORMAT STATEMENTS * 1000 FORMAT + (///' STOPPING CONDITION (INFO = ',I6,'):'/ + ' -----------------------------------'/) 1110 FORMAT + ( ' THE COMPUTATIONS WERE STOPPED BY THE USER DURING'/ + ' THE EVALUATION OF THE FUNCTION') 1115 FORMAT + ( ' THE COMPUTATIONS WERE STOPPED BY THE USER DURING'/ + ' THE EVALUATION OF THE JACOBIAN') 1120 FORMAT + ( ' THE RELATIVE CHANGE IN THE SUM OF THE SQUARED'/ + ' WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL') 1130 FORMAT + ( ' THE RELATIVE CHANGE IN THE NORM OF BETA AND DELTA'/ + ' IS LESS THAN PARTOL') 1140 FORMAT + ( ' THE RELATIVE CHANGE IN THE SUM OF THE SQUARED'/ + ' WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL'/ + ' AND'/ + ' THE RELATIVE CHANGE IN THE NORM OF BETA AND DELTA'/ + ' IS LESS THAN PARTOL') 1150 FORMAT + ( ' MAXIMUM NUMBER OF ITERATIONS REACHED') 1160 FORMAT + ( ' ERROR. PLEASE CHECK WITH AUTHORS.') 1210 FORMAT + (/ ' NOTE:'// + ' THE RESULTS FROM ODRPACK ARE QUESTIONABLE BECAUSE'/) 1220 FORMAT + ( ' THE ODRPACK JACOBIAN MATRIX CHECKING PROCEDURE HAS '/ + ' DETERMINED THAT THE CORRECTNESS OF THE USER-SUPPLIED'/ + ' JACOBIAN MATRICES IS QUESTIONABLE',A5/) 1230 FORMAT + ( ' THE MOST RECENTLY TRIED STEP WAS REJECTED BY THE '/ + ' USER AS INDICATED BY THE VALUE OF VARIABLE ISTOPF '/ + ' RETURNED FROM USER-SUPPLIED SUBROUTINE FUN',A5/) 1240 FORMAT + ( ' THE JACOBIAN OF THE MODEL FUNCTION WITH RESPECT TO '/ + ' THE FUNCTION PARAMETERS (BETA) IS NOT FULL RANK AT '/ + ' THE SOLUTION. ') 1250 FORMAT + ( ' THE RESULTS OF THE MODEL FUNCTION AND/OR ITS '/ + ' DERIVATIVES ARE UNAFFECTED BY CHANGES IN THE UNFIXED'/ + ' FUNCTION PARAMETERS (BETA), INDICATING A PROBABLE '/ + ' ERROR IN USER-SUPPLIED SUBROUTINES FUN AND/OR JAC.'/) 1300 FORMAT + (/' CONDITION', + ' '/ + ' NUMBER OF NUMBER OF NUMBER OF NUMBER', + ' RANK'/ + ' ITERATIONS FN EVALS JAC EVALS (INVERSE)', + ' DEFICIENCY'/ + 6X,I10,2I11,D11.4,6X,I6) 1400 FORMAT + (/' CONDITION '/ + ' NUMBER OF NUMBER OF NUMBER RANK'/ + ' ITERATIONS FN EVALS (INVERSE) DEFICIENCY'/ + 6X,I10,I11,D11.4,6X,I6) 2000 FORMAT + (///' FINAL SUMS OF SQUARES:'/ + ' ----------------------'/) 2100 FORMAT + ( ' SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS ', D17.8) 2200 FORMAT + ( ' SUM OF SQUARED WEIGHTED DELTAS ', D17.8) 2300 FORMAT + ( ' SUM OF SQUARED WEIGHTED EPSILONS ', D17.8) 2400 FORMAT + (/ ' ESTIMATED RESIDUAL VARIANCE ', D17.8) 2500 FORMAT + ( ' (',I5,' DEGREES OF FREEDOM)') 3000 FORMAT + (///' ESTIMATED BETA(J), J = 1, ..., NP:'/ + ' ----------------------------------') 4100 FORMAT + (///' ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:'/ + ' ---------------------------------------------------') 4110 FORMAT(1X,I5,5D16.8) 4200 FORMAT + (///' ESTIMATED EPSILON(I), I = 1, ..., N:'/ + ' ------------------------------------') 4300 FORMAT + (///' ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:'/ + ' --------------------------------------') 7100 FORMAT + (/' INDEX VALUE') 7200 FORMAT + (/' INDEX VALUE -------------->') 7300 FORMAT + (/' J BETA(J) STD. DEV. BETA(J)') 7400 FORMAT + (/' N.B. STANDARD ERRORS OF THE ESTIMATED BETAS WERE NOT'/ + ' COMPUTED BECAUSE EITHER THE JACOBIAN IS NOT FULL'/ + ' RANK AT THE SOLUTION, OR THE MOST RECENTLY TRIED'/ + ' VALUES OF BETA AND/OR X+DELTA WERE UNACCEPTABLE.') 8100 FORMAT + (9X,I5,1X,D16.8,6X,D16.8) 8200 FORMAT + (1X,I5,' TO',I5,1X,7D16.8) 8300 FORMAT + (1X,' ... TO',I5,1X,' ... ',D16.8) 8400 FORMAT + (9X,I5,1X,D16.8,17X,'FIXED') 9100 FORMAT + ('(/'' I EPSILON(I)'',',I1, + '('' DELTA(I,'',I1,'')''))') 9200 FORMAT('(5X,''.'',',I1,'(3X,''.'',12X))') END *DODPCR SUBROUTINE DODPCR + (HEAD,IFLAG,IPR,FSTITR,DIDVCV,LUNRPT, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT,Y,W, + BETA,IFIXB,SSF,SDBETA, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO) C***BEGIN PROLOGUE DODPCR C***REFER TO DODR,DODRC C***ROUTINES CALLED DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE GENERATE COMPUTATION REPORTS C***END PROLOGUE DODPCR * C...SCALAR ARGUMENTS DOUBLE PRECISION + ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR, + SSTOL,TAU,TAUFAC,WSS,WSSDEL,WSSEPS INTEGER + IDF,IFLAG,INFO,IPR,IRANK,JOB,LDIFX,LDTT,LDWD,LDX,LUNRPT,M, + MAXIT,N,NETA,NFEV,NITER,NJEV,NNZW,NP,NPP LOGICAL + ANAJAC,CHKJAC,DIDVCV,DOVCV,FSTITR,HEAD,INITD,ISODR,RESTRT * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),DELTA(N,M),F(N), + SDBETA(NP),SSF(NP),TT(LDTT,M),W(N),WD(LDWD,M),X(LDX,M), + Y(N) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NP+1),MSGX(M+1) * C...LOCAL SCALARS CHARACTER TYP*3 * C...EXTERNAL SUBROUTINES EXTERNAL + DFLAGS,DODPC1,DODPC2,DODPC3,DODPHD * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION ACTRED C THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C DOUBLE PRECISION DELTA(N,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DIDVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX WAS COMPUTED (DIDVCV=.TRUE.) C OR NOT (DIDVCV=.FALSE.). C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C DOUBLE PRECISION F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C LOGICAL FSTITR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THIS IS THE C FIRST ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). C LOGICAL HEAD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE C HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). C INTEGER IDF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFLAG C AN INDICATOR VARIABLE, USED HERE TO DESIGNATE WHICH PART OF C THE REPORT IS TO BE PRINTED. C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C INTEGER IPR C THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED. C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE NUMBER OF ITERATIONS. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NNZW C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C DOUBLE PRECISION PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION PNORM C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C DOUBLE PRECISION PRERED C THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C DOUBLE PRECISION RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C DOUBLE PRECISION RVAR C THE RESIDUAL VARIANCE. C DOUBLE PRECISION SDBETA(NP) C THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S. C DOUBLE PRECISION SSF(NP) C THE SCALE USED FOR THE BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TAU C THE TRUST REGION DIAMETER. C DOUBLE PRECISION TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C CHARACTER*3 TYP C THE CHARACTER STRING ODR OR OLS. C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C DOUBLE PRECISION WSSDEL C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C DOUBLE PRECISION WSSEPS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) * * C***FIRST EXECUTABLE STATEMENT DODPCR * * CALL DFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR,DOVCV) * IF (HEAD) THEN CALL DODPHD(HEAD,LUNRPT) ELSE IF (IFLAG.NE.2 .OR. FSTITR) THEN WRITE (LUNRPT,1000) END IF IF (ISODR) THEN TYP = 'ODR' ELSE TYP = 'OLS' END IF * C PRINT INITIAL SUMMARY * IF (IFLAG.EQ.1) THEN IF (RESTRT) THEN WRITE (LUNRPT,1100) TYP ELSE WRITE (LUNRPT,1200) TYP CALL DODPC1 + (IPR,LUNRPT, + ANAJAC,CHKJAC,INITD,RESTRT,ISODR,DOVCV, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT, + Y,W, + BETA,IFIXB,SSF, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS) END IF * C PRINT ITERATION REPORTS * ELSE IF (IFLAG.EQ.2) THEN * IF (FSTITR) THEN WRITE (LUNRPT,1300) TYP END IF CALL DODPC2 + (IPR,FSTITR,LUNRPT,NP, + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,BETA) * C PRINT FINAL SUMMARY * ELSE IF (IFLAG.EQ.3) THEN * WRITE (LUNRPT,1400) TYP CALL DODPC3 + (IPR,LUNRPT, + N,M,NP,NPP, + INFO,NITER,NFEV,NJEV,RCOND,IRANK, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + BETA,SDBETA,IFIXB,F,ISODR,DIDVCV,DOVCV,ANAJAC,DELTA) END IF * RETURN * C FORMAT STATEMENTS * 1000 FORMAT(//) 1100 FORMAT + (////' RESTART OF FIT BY METHOD OF ',A3/ + ' ===============================') 1200 FORMAT + (////' INITIAL SUMMARY FOR FIT BY METHOD OF ',A3/ + ' ========================================') 1300 FORMAT + (//' ITERATION REPORTS FOR FIT BY METHOD OF ',A3/ + ' ==========================================') 1400 FORMAT + (////' FINAL SUMMARY FOR FIT BY METHOD OF ',A3/ + ' ======================================') END *DODPE1 SUBROUTINE DODPE1 + (UNIT,D1,D2,D3,D4,D5, + N, + LDSCLD,LDWD, + LWKMN,LIWKMN) C***BEGIN PROLOGUE DODPE1 C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE PRINT ERROR REPORTS. C***END PROLOGUE DODPE1 * C...SCALAR ARGUMENTS INTEGER + D1,D2,D3,D4,D5,LDSCLD,LDWD,LIWKMN,LWKMN,N,UNIT * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER D1 C THE FIRST DIGIT OF INFO. C INTEGER D2 C THE SECOND DIGIT OF INFO. C INTEGER D3 C THE THIRD DIGIT OF INFO. C INTEGER D4 C THE FOURTH DIGIT OF INFO. C INTEGER D5 C THE FIFTH DIGIT OF INFO. C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER UNIT C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. * * C***FIRST EXECUTABLE STATEMENT DODPE1 * * C PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION C PARAMETERS * IF (D1.EQ.1) THEN IF (D2.NE.0) THEN WRITE(UNIT,1100) END IF IF (D3.NE.0) THEN WRITE(UNIT,1200) END IF IF (D4.NE.0) THEN WRITE(UNIT,1300) END IF * C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION C PARAMETERS * ELSE IF (D1.EQ.2) THEN IF (D2.NE.0) THEN WRITE(UNIT,2100) END IF IF (D3.NE.0) THEN IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN WRITE(UNIT,2210) END IF IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN WRITE(UNIT,2220) END IF IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN WRITE(UNIT,2230) END IF END IF IF (D4.NE.0) THEN WRITE(UNIT,2300) LWKMN END IF IF (D5.NE.0) THEN WRITE(UNIT,2400) LIWKMN END IF * ELSE IF (D1.EQ.3) THEN * C PRINT APPROPRIATE MESSAGES FOR ERRORS SCALE VALUES * IF (D2.NE.0) THEN IF (LDSCLD.GE.N) THEN WRITE(UNIT,3110) ELSE WRITE(UNIT,3120) END IF END IF IF (D3.NE.0) THEN WRITE(UNIT,3130) END IF * C PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS * IF (D4.NE.0) THEN IF (D4.EQ.1) THEN WRITE(UNIT,3210) ELSE WRITE(UNIT,3220) END IF END IF * C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS * IF (D5.NE.0) THEN IF (LDWD.GE.N) THEN WRITE(UNIT,3310) ELSE WRITE(UNIT,3320) END IF END IF * END IF * C FORMAT STATEMENTS * 1100 FORMAT + (/' ERROR : N IS LESS THAN ONE.') 1200 FORMAT + (/' ERROR : M IS LESS THAN ONE.') 1300 FORMAT + (/' ERROR : NP IS LESS THAN ONE'/ + ' OR NP IS GREATER THAN N.') 2100 FORMAT + (/' ERROR : LDX IS LESS THAN N.') 2210 FORMAT + (/' ERROR : LDIFX IS LESS THAN N'/ + ' AND LDIFX IS NOT EQUAL TO ONE.') 2220 FORMAT + (/' ERROR : LDSCLD IS LESS THAN N'/ + ' AND LDSCLD IS NOT EQUAL TO ONE.') 2230 FORMAT + (/' ERROR : LDWD IS LESS THAN N'/ + ' AND LDWD IS NOT EQUAL TO ONE.') 2300 FORMAT + (/' ERROR : LWORK IS LESS THAN ',I5, ','/ + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.') 2400 FORMAT + (/' ERROR : LIWORK IS LESS THAN ',I5, ','/ + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY', + ' IWORK.') 3110 FORMAT + (/' ERROR : SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + ' AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN'/ + ' EACH OF THE N BY M ELEMENTS OF'/ + ' SCLD MUST BE GREATER THAN ZERO.') 3120 FORMAT + (/' ERROR : SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME J = 1, ..., M.'// + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + ' AND LDSCLD IS EQUAL TO ONE THEN'/ + ' EACH OF THE 1 BY M ELEMENTS OF'/ + ' SCLD MUST BE GREATER THAN ZERO.') 3130 FORMAT + (/' ERROR : SCLB(K) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME K = 1, ..., NP.'// + ' ALL NP ELEMENTS OF', + ' SCLB MUST BE GREATER THAN ZERO.') 3210 FORMAT + (/' ERROR : W(I) IS LESS THAN ZERO FOR SOME I = 1, ..., N.'// + ' WHEN W(1) IS GREATER THAN OR EQUAL TO ZERO THEN'/ + ' ALL N ELEMENTS OF', + ' W MUST BE GREATER THAN OR EQUAL TO ZERO.') 3220 FORMAT + (/' ERROR : THE NUMBER OF NONZERO VALUES IN ARRAY W IS'/ + ' LESS THAN NP.') 3310 FORMAT + (/' ERROR : WD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + ' WHEN WD(1,1) IS GREATER THAN ZERO'/ + ' AND LDWD IS GREATER THAN OR EQUAL TO N THEN'/ + ' EACH OF THE N BY M ELEMENTS OF'/ + ' WD MUST BE GREATER THAN ZERO.') 3320 FORMAT + (/' ERROR : WD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME J = 1, ..., M.'// + ' WHEN WD(1,1) IS GREATER THAN ZERO'/ + ' AND LDWD IS EQUAL TO ONE THEN'/ + ' EACH OF THE 1 BY M ELEMENTS OF'/ + ' WD MUST BE GREATER THAN ZERO.') END *DODPE2 SUBROUTINE DODPE2 + (UNIT, + NP,M, + MSGB,ISODR,MSGX, + XPLUSD,LDXPD,NROW,NETA,NTOL) C***BEGIN PROLOGUE DODPE2 C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE GENERATE THE DERIVATIVE CHECKING REPORT C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKZRO) C***END PROLOGUE DODPE2 * C...SCALAR ARGUMENTS INTEGER + LDXPD,M,NETA,NP,NROW,NTOL,UNIT LOGICAL + ISODR * C...ARRAY ARGUMENTS DOUBLE PRECISION + XPLUSD(LDXPD,M) INTEGER + MSGB(NP+1),MSGX(M+1) * C...LOCAL SCALARS INTEGER + I,J,K CHARACTER TYP*3 * C...LOCAL ARRAYS LOGICAL + FTNOTE(6) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL FTNOTE(6) C THE ARRAY WHICH CONTROLS PRINTING OF FOOTNOTES. C INTEGER I C AN INDEX VARIABLE. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER J C AN INDEX VARIABLE. C INTEGER K C AN INDEX VARIABLE. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER NETA C THE NUMBER OF RELIABLE DIGITS IN THE MODEL. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTOL C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C FINITE DIFFERENCE AND THE USER-SUPPLIED DERIVATIVES. C CHARACTER*3 TYP C THE SOLUTION TYPE, ODR OR OLS. C INTEGER UNIT C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT DODPE2 * * C SET UP FOR FOOTNOTES * DO 10 I=1,6 FTNOTE(I) = .FALSE. 10 CONTINUE * IF (MSGB(1).GE.1) THEN DO 20 I=1,NP IF (MSGB(I+1).GE.2) THEN FTNOTE(1) = .TRUE. FTNOTE(MSGB(I+1)) = .TRUE. END IF 20 CONTINUE END IF * IF (MSGX(1).GE.1) THEN DO 30 I=1,M IF (MSGX(I+1).GE.2) THEN FTNOTE(1) = .TRUE. FTNOTE(MSGX(I+1)) = .TRUE. END IF 30 CONTINUE END IF * C PRINT REPORT * IF (ISODR) THEN TYP = 'ODR' ELSE TYP = 'OLS' END IF WRITE (UNIT,1000) TYP IF (FTNOTE(1)) WRITE (UNIT,2100) WRITE (UNIT,2200) * * DO 40 I=1,NP K = MSGB(I+1) - 1 IF (K.EQ.(-1)) WRITE (UNIT,3100) I IF (K.EQ.0) WRITE (UNIT,3200) I IF (K.GE.1) WRITE (UNIT,3300) I, K 40 CONTINUE IF (ISODR) THEN DO 50 I=1,M K = MSGX(I+1) - 1 IF (K.EQ.(-1)) WRITE (UNIT,4100) NROW,I IF (K.EQ.0) WRITE (UNIT,4200) NROW,I IF (K.GE.1) WRITE (UNIT,4300) NROW,I,K 50 CONTINUE END IF * C PRINT FOOTNOTES * IF (FTNOTE(1)) THEN * WRITE (UNIT,5100) IF (FTNOTE(2)) WRITE (UNIT,5200) IF (FTNOTE(3)) WRITE (UNIT,5300) IF (FTNOTE(4)) WRITE (UNIT,5400) IF (FTNOTE(5)) WRITE (UNIT,5500) IF (FTNOTE(6)) WRITE (UNIT,5600) END IF * WRITE (UNIT,6000) NETA WRITE (UNIT,7000) NTOL * C PRINT OUT ROW OF INDEPENDENT VARIABLE WHICH WAS CHECKED. * WRITE (UNIT,8100) NROW * DO 60 J=1,M WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J) 60 CONTINUE * RETURN * C FORMAT STATEMENTS * 1000 FORMAT + (//' DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3/ + ' ==================================================='/) 2100 FORMAT (' *') 2200 FORMAT (' DERIVATIVE '/ + ' DERIVATIVE WRT ASSESSMENT '/) 3100 FORMAT (' BETA(',I3,') OK ') 3200 FORMAT (' BETA(',I3,') INCORRECT ') 3300 FORMAT (' BETA(',I3,') QUESTIONABLE (',I1,')') 4100 FORMAT (' X(',I2,',',I2,') OK ') 4200 FORMAT (' X(',I2,',',I2,') INCORRECT ') 4300 FORMAT (' X(',I2,',',I2,') QUESTIONABLE (',I1,')') 5100 FORMAT + (/' *'/ + ' NUMBERS IN PARENTHESES REFER TO THE FOLLOWING NOTES.') 5200 FORMAT + (/' (1) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/ + ' AGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE BOTH'/ + ' ARE ZERO.') 5300 FORMAT + (/' (2) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/ + ' AGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE USER-'/ + ' SUPPLIED DERIVATIVE IS IDENTICALLY ZERO AND FINITE '/ + ' DIFFERENCE DERIVATIVE IS ONLY APPROXIMATELY ZERO.') 5400 FORMAT + (/' (3) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/ + ' DISAGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE'/ + ' USER-SUPPLIED DERIVATIVE IS IDENTICALLY ZERO.') 5500 FORMAT + (/' (4) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/ + ' DISAGREE, BUT FINITE DIFFERENCE DERIVATIVE IS'/ + ' QUESTIONABLE BECAUSE EITHER THE RATIO OF RELATIVE'/ + ' CURVATURE TO RELATIVE SLOPE IS TOO HIGH OR THE SCALE'/ + ' IS WRONG.') 5600 FORMAT + (/' (5) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/ + ' DISAGREE, BUT FINITE DIFFERENCE DERIVATIVE IS'/ + ' QUESTIONABLE BECAUSE THE RATIO OF RELATIVE CURVATURE'/ + ' TO RELATIVE SLOPE IS TOO HIGH.') 6000 FORMAT * (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ',I5) 7000 FORMAT + (/' NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN '/ + ' USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR '/ + ' USER-SUPPLIED DERIVATIVE TO BE CONSIDERED CORRECT ',I5) 8100 FORMAT + (/' ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED ',I5// + ' -VALUES OF THE INDEPENDENT VARIABLES AT THIS ROW'/) 8110 FORMAT + (6X,'X(',I2,',',I2,')',1X,3D16.8) END *DODPE3 SUBROUTINE DODPE3 + (UNIT,D2,D3) C***BEGIN PROLOGUE DODPE3 C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE PRINT ERROR REPORTS TO INDICATE THAT COMPUTATIONS WERE C STOPPED IN USER-SUPPLIED SUBROUTINES FUN AND/OR JAC. C***END PROLOGUE DODPE3 * C...SCALAR ARGUMENTS INTEGER + D2,D3,UNIT * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER D2 C THE SECOND DIGIT OF INFO. C INTEGER D3 C THE THIRD DIGIT OF INFO. C INTEGER UNIT C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. * * C***FIRST EXECUTABLE STATEMENT DODPE3 * * C PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE C STOPPED * IF (D2.EQ.2) THEN WRITE(UNIT,1100) ELSE IF (D2.EQ.3) THEN WRITE(UNIT,1200) ELSE IF (D2.EQ.4) THEN WRITE(UNIT,1300) END IF IF (D3.EQ.2) THEN WRITE(UNIT,1400) END IF * C FORMAT STATEMENTS * 1100 FORMAT + (//' VARIABLE ISTOPF HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER-SUPPLIED SUBROUTINE FUN WHEN INVOKED USING THE'/ + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ + ' PROPER EVALUATION OF SUBROUTINE FUN BEFORE THE '/ + ' REGRESSION PROCEDURE CAN CONTINUE.') 1200 FORMAT + (//' VARIABLE ISTOPF HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER-SUPPLIED SUBROUTINE FUN. THIS OCCURRED DURING'/ + ' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE '/ + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FUN, INDI-'/ + ' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),'/ + ' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION), '/ + ' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE'/ + ' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT '/ + ' SUBROUTINE FUN FROM BEING PROPERLY EVALUATED. THE '/ + ' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + ' EVALUATION OF SUBROUTINE FUN DURING THESE COMPUTATIONS '/ + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') 1300 FORMAT + (//' VARIABLE ISTOPF HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER-SUPPLIED SUBROUTINE FUN. THIS OCCURRED DURING'/ + ' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT '/ + ' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS '/ + ' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR '/ + ' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS '/ + ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA '/ + ' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN '/ + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FUN, '/ + ' PREVENT SUBROUTINE FUN FROM BEING PROPERLY EVALUATED. '/ + ' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + ' EVALUATION OF SUBROUTINE FUN DURING THESE COMPUTATIONS '/ + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') 1400 FORMAT + (//' VARIABLE ISTOPJ HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER-SUPPLIED SUBROUTINE JAC WHEN INVOKED USING THE'/ + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ + ' PROPER EVALUATION OF SUBROUTINE JAC BEFORE THE '/ + ' REGRESSION PROCEDURE CAN CONTINUE.') END *DODPER SUBROUTINE DODPER + (INFO,LUNERR,SHORT, + N,NP,M, + LDSCLD,LDWD, + LWKMN,LIWKMN, + SCLD,SCLB,W,WD, + MSGB,ISODR,MSGX, + XPLUSD,LDXPD,NROW,NETA,NTOL) C***BEGIN PROLOGUE DODPER C***REFER TO DODR,DODRC C***ROUTINES CALLED DODPE1,DODPE2,DODPE3,DODPHD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS. C***END PROLOGUE DODPER * C...SCALAR ARGUMENTS INTEGER + INFO,LDSCLD,LDWD,LDXPD,LIWKMN,LUNERR,LWKMN,M,N,NETA,NP, + NROW,NTOL LOGICAL + ISODR,SHORT * C...ARRAY ARGUMENTS DOUBLE PRECISION + SCLB(NP),SCLD(LDSCLD,M),W(N),WD(LDWD,M),XPLUSD(LDXPD,M) INTEGER + MSGB(NP+1),MSGX(M+1) * C...LOCAL SCALARS INTEGER + D1,D2,D3,D4,D5,UNIT LOGICAL + HEAD * C...EXTERNAL SUBROUTINES EXTERNAL + DODPE1,DODPE2,DODPE3,DODPHD * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER D1 C THE FIRST DIGIT OF INFO. C INTEGER D2 C THE SECOND DIGIT OF INFO. C INTEGER D3 C THE THIRD DIGIT OF INFO. C INTEGER D4 C THE FOURTH DIGIT OF INFO. C INTEGER D5 C THE FIFTH DIGIT OF INFO. C LOGICAL HEAD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE C HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF RELIABLE DIGITS IN THE MODEL. C DOUBLE PRECISION SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTOL C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C FINITE DIFFERENCE AND THE USER-SUPPLIED DERIVATIVES. C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS C INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG- C CALL (SHORT=.FALSE.). C INTEGER UNIT C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT DODPER * * C SET LOGICAL UNIT NUMBER FOR ERROR REPORT * IF (LUNERR.EQ.0) THEN RETURN ELSE IF (LUNERR.LT.0) THEN UNIT = 6 ELSE UNIT = LUNERR END IF * C PRINT HEADING * HEAD = .TRUE. CALL DODPHD(HEAD,UNIT) * C EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO * D1 = MOD(INFO,100000)/10000 D2 = MOD(INFO,10000)/1000 D3 = MOD(INFO,1000)/100 D4 = MOD(INFO,100)/10 D5 = MOD(INFO,10) * C PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP * IF (D1.GE.1 .AND. D1.LE.3) THEN * C PRINT APPROPRIATE MESSAGES FOR ERRORS IN C PROBLEM SPECIFICATION PARAMETERS C DIMENSION SPECIFICATION PARAMETERS C NUMBER OF GOOD DIGITS IN X C OBSERVATIONAL ERROR WEIGHTS C DELTA WEIGHTS * CALL DODPE1(UNIT,D1,D2,D3,D4,D5, + N, + LDSCLD,LDWD, + LWKMN,LIWKMN) * ELSE IF (D1.EQ.4) THEN * C PRINT APPROPRIATE MESSAGES FOR ERRORS DETECTED IN THE USER-SUPPLIED C JACOBIAN * CALL DODPE2(UNIT, + NP,M, + MSGB,ISODR,MSGX, + XPLUSD,LDXPD,NROW,NETA,NTOL) * ELSE IF (D1.EQ.5) THEN * C PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FUN OR JAC * CALL DODPE3(UNIT,D2,D3) * END IF * C PRINT CORRECT FORM OF CALL STATEMENT * IF ((D1.GE.1 .AND. D1.LE.3) .OR. + (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. + (D1.EQ.5)) THEN IF (SHORT) THEN WRITE (UNIT,1100) ELSE WRITE (UNIT,1200) END IF END IF * RETURN * C FORMAT STATEMENTS * 1100 FORMAT + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + ' CALL DODR'/ + ' + (FUN,JAC,'/ + ' + N,M,NP,'/ + ' + X,LDX,'/ + ' + Y,'/ + ' + BETA,'/ + ' + WD,LDWD,'/ + ' + JOB,'/ + ' + IPRINT,LUNERR,LUNRPT,'/ + ' + WORK,LWORK,IWORK,LIWORK,'/ + ' + INFO)') 1200 FORMAT + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + ' CALL DODRC'/ + ' + (FUN,JAC,'/ + ' + N,M,NP,'/ + ' + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,'/ + ' + Y,'/ + ' + BETA,IFIXB,SCLB,'/ + ' + WD,LDWD,W,'/ + ' + JOB,NDIGIT,TAUFAC,'/ + ' + SSTOL,PARTOL,MAXIT,'/ + ' + IPRINT,LUNERR,LUNRPT,'/ + ' + WORK,LWORK,IWORK,LIWORK,'/ + ' + INFO)') * END *DODPHD SUBROUTINE DODPHD + (HEAD,UNIT) C***BEGIN PROLOGUE DODPHD C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890727 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE PRINT ODRPACK HEADING C***END PROLOGUE DODPHD * C...SCALAR ARGUMENTS INTEGER + UNIT LOGICAL + HEAD * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL HEAD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE C HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). C INTEGER UNIT C THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN. * * C***FIRST EXECUTABLE STATEMENT DODPHD * * IF (HEAD) THEN WRITE(UNIT,1000) HEAD = .FALSE. END IF * RETURN * C FORMAT STATEMENTS * 1000 FORMAT (/// + ' ******************************************************* '/ + ' * ODRPACK VERSION 1.71 OF 07-27-89 (DOUBLE PRECISION) * '/ + ' ******************************************************* '/) END *DODR SUBROUTINE DODR + (FUN,JAC, + N,M,NP, + X,LDX, + Y, + BETA, + WD,LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) C***BEGIN PROLOGUE DODR C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE USER-CALLABLE DOUBLE PRECISION CONTROL ROUTINE FOR FINDING C THE WEIGHTED ORTHOGONAL DISTANCE REGRESSION (ODR) OR C ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) SOLUTION C (SHORT CALL STATEMENT) C***DESCRIPTION C REFERENCE FOR ONLINE DOCUMENTATION IS GIVEN BELOW. C THE ONLINE DOCUMENTATION CAN BE INSERTED HERE IF REQUIRED BY C YOUR DOCUMENTATION RETRIEVAL SYSTEM. ONLINE DOCUMENTATION DOES C NOT EXTEND BEYOND COLUMN 80, AND COLUMN 1 OF ONLINE C DOCUMENTATION CAN BE CHANGED TO 'C' WITHOUT LOSS OF INFORMATION. C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1987), C "ODRPACK -- SOFTWARE FOR WEIGHTED ORTHOGONAL C DISTANCE REGRESSION," C UNIVERSITY OF COLORADO DEPARTMENT OF COMPUTER SCIENCE C TECHNICAL REPORT NUMBER CU-CS-360-87. C (TO APPEAR IN ACM TRANS. MATH. SOFTWARE.) C BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1989), C "REFERENCE GUIDE FOR ODRPACK SOFTWARE FOR WEIGHTED C ORTHOGONAL DISTANCE REGRESSION," C ONLINE DOCUMENTATION AVAILABLE FROM AUTHORS C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR C ORTHOGONAL DISTANCE REGRESSION," C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. C***ROUTINES CALLED DODDRV C***END PROLOGUE DODR * C...SCALAR ARGUMENTS INTEGER + INFO,JOB,LDWD,LDX,LIWORK,LWORK,M,N,NDIGIT,NP * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),WD(LDWD,M),WORK(LWORK),X(LDX,M),Y(N) INTEGER + IWORK(LIWORK) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS DOUBLE PRECISION + NEGONE,PARTOL,SSTOL,TAUFAC INTEGER + IPRINT,LDIFX,LDSCLD,LUNERR,LUNRPT,MAXIT LOGICAL + SHORT * C...LOCAL ARRAYS DOUBLE PRECISION + SCLB(1),SCLD(1,1),W(1) INTEGER + IFIXB(1),IFIXX(1,1) * C...EXTERNAL SUBROUTINES EXTERNAL + DODDRV * C...DATA STATEMENTS DATA + NEGONE + /-1.0D0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE FUNCTION. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXB(1) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(1,1) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION NEGONE C THE VALUE -1.0D0. C INTEGER NDIGIT C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SCLB(1) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SCLD(1,1) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS C INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG- C CALL (SHORT=.FALSE.). C DOUBLE PRECISION SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION W(1) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WORK(LWORK) C THE DOUBLE PRECISION WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) * * C***FIRST EXECUTABLE STATEMENT DODR * * C INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES * IFIXX(1,1) = -1 LDIFX = 1 SCLD(1,1) = NEGONE LDSCLD = 1 IFIXB(1) = -1 SCLB(1) = NEGONE W(1) = NEGONE TAUFAC = NEGONE SSTOL = NEGONE PARTOL = NEGONE MAXIT = -1 NDIGIT = -1 * SHORT = .TRUE. * CALL DODDRV + (SHORT, + FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) * RETURN * END *DODRC SUBROUTINE DODRC + (FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) C***BEGIN PROLOGUE DODRC C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE USER-CALLABLE DOUBLE PRECISION CONTROL ROUTINE FOR FINDING C THE WEIGHTED ORTHOGONAL DISTANCE REGRESSION (ODR) OR C ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) SOLUTION C (LONG CALL STATEMENT) C***DESCRIPTION C REFERENCE FOR ONLINE DOCUMENTATION IS GIVEN BELOW. C THE ONLINE DOCUMENTATION CAN BE INSERTED HERE IF REQUIRED BY C YOUR DOCUMENTATION RETRIEVAL SYSTEM. ONLINE DOCUMENTATION DOES C NOT EXTEND BEYOND COLUMN 80, AND COLUMN 1 OF ONLINE C DOCUMENTATION CAN BE CHANGED TO 'C' WITHOUT LOSS OF INFORMATION. C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1987), C "ODRPACK -- SOFTWARE FOR WEIGHTED ORTHOGONAL C DISTANCE REGRESSION," C UNIVERSITY OF COLORADO DEPARTMENT OF COMPUTER SCIENCE C TECHNICAL REPORT NUMBER CU-CS-360-87. C (TO APPEAR IN ACM TRANS. MATH. SOFTWARE.) C BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1989), C "REFERENCE GUIDE FOR ODRPACK SOFTWARE FOR WEIGHTED C ORTHOGONAL DISTANCE REGRESSION," C ONLINE DOCUMENTATION AVAILABLE FROM AUTHORS C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR C ORTHOGONAL DISTANCE REGRESSION," C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. C***ROUTINES CALLED DODDRV C***END PROLOGUE DODRC * C...SCALAR ARGUMENTS DOUBLE PRECISION + PARTOL,SSTOL,TAUFAC INTEGER + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDWD,LDX,LIWORK,LUNERR, + LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),SCLB(NP),SCLD(LDSCLD,M), + W(N),WD(LDWD,M),WORK(LWORK),X(LDX,M),Y(N) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS LOGICAL + SHORT * C...EXTERNAL SUBROUTINES EXTERNAL + DODDRV * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE FUNCTION. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NDIGIT C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS C INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG- C CALL (SHORT=.FALSE.). C DOUBLE PRECISION SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WORK(LWORK) C THE DOUBLE PRECISION WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) * * C***FIRST EXECUTABLE STATEMENT DODRC * * SHORT = .FALSE. * CALL DODDRV + (SHORT, + FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) * RETURN * END *DODSTP SUBROUTINE DODSTP + (N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX, + W,WD,LDWD,SS,TT,LDTT,DDELT, + ALPHA,EPSMAC, + SSS,TFJACB,VDTD,OMEGA,YT,U,QRAUX,WRK2,JPVT, + S,T,PHI,IRANK, + RCOND) C***BEGIN PROLOGUE DODSTP C***REFER TO DODR,DODRC C***ROUTINES CALLED IDAMAX,DCHEX,DDIAGS,DDOT,DIDTS,DNRM2,DQRDC, C DQRSL,DROT,DROTG,DTRCO,DTRSL,DZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA) C***END PROLOGUE DODSTP * C...SCALAR ARGUMENTS DOUBLE PRECISION + ALPHA,EPSMAC,PHI,RCOND INTEGER + IRANK,LDFJB,LDFJX,LDTT,LDWD,M,N,NP,NPP * C...ARRAY ARGUMENTS DOUBLE PRECISION + DDELT(N,M),F(N),FJACB(LDFJB,NP),FJACX(LDFJX,M), + OMEGA(N),QRAUX(NP),S(NP),SS(NP), + SSS(N+N*M),T(N,M),TFJACB(N,NP),TT(LDTT,M),U(N), + VDTD(N,M),W(N),WD(LDWD,M),WRK2(NP),YT(N) INTEGER + JPVT(NP) * C...LOCAL SCALARS DOUBLE PRECISION + CO,ONE,SI,TEMP,ZERO INTEGER + I,IMAX,INF,IPVT,J,KP LOGICAL + ELIM * C...LOCAL ARRAYS DOUBLE PRECISION + DUM(1) * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT,DNRM2 INTEGER + IDAMAX EXTERNAL + DDOT,DNRM2,IDAMAX * C...EXTERNAL SUBROUTINES EXTERNAL + DCHEX,DDIAGS,DIDTS,DQRDC,DQRSL,DROT,DROTG,DTRCO,DTRSL, + DZERO * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SQRT * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0D0,1.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C DOUBLE PRECISION CO C THE COSINE FROM THE PLANE ROTATION. C DOUBLE PRECISION DDELT(N,M) C THE ARRAY (W*D)**2 * DELTA. C DOUBLE PRECISION DUM C AN DUMMY VARIABLE. C LOGICAL ELIM C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER COLUMNS OF THE C JACOBIAN WRT BETA HAVE BEEN ELIMINATED (ELIM=.TRUE.) OR NOT C (ELIM=.FALSE.). C DOUBLE PRECISION EPSMAC C THE VALUE OF MACHINE PRECISION. C DOUBLE PRECISION F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C DOUBLE PRECISION FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C DOUBLE PRECISION FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO X. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IMAX C THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE C VALUE. C INTEGER INF C THE RETURN CODE FROM DQRSL AND DTRSL. C INTEGER IPVT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER OR NOT C PIVOTING IS TO BE DONE. C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C INTEGER J C AN INDEXING VARIABLE. C INTEGER JPVT(NP) C THE PIVOT VECTOR. C INTEGER KP C THE RANK OF THE JACOBIAN WRT BETA. C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C DOUBLE PRECISION OMEGA(N) C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION PHI C THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP C AND THE TRUST REGION DIAMETER. C DOUBLE PRECISION QRAUX(NP) C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C DOUBLE PRECISION RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C DOUBLE PRECISION S(NP) C THE STEP FOR THE ESTIMATED BETA'S. C DOUBLE PRECISION SI C THE SINE FROM THE PLANE ROTATION. C DOUBLE PRECISION SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION SSS(N+N*M) C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C DOUBLE PRECISION T(N,M) C THE STEP FOR THE ESTIMATED DELTA'S. C DOUBLE PRECISION TEMP C A TEMPORARY STORAGE LOCATION. C DOUBLE PRECISION TFJACB(N,NP) C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C DOUBLE PRECISION TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION U(N) C THE APPROXIMATE NULL VECTOR FOR TFJACB. C DOUBLE PRECISION VDTD(N,M) C THE ARRAY DDELT*INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2. C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WRK2(NP) C A WRK2 ARRAY. C DOUBLE PRECISION YT(N) C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DODSTP * * C COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE * C SET UP JPVT IF ALPHA = 0 * IF (ALPHA.EQ.ZERO) THEN KP = NPP DO 10 I=1,NPP JPVT(I) = I 10 CONTINUE ELSE IF (NPP.GE.1) THEN KP = NPP-IRANK ELSE KP = NPP END IF END IF * C SET UP OMEGA AND TFJACB C (VDTD = FJACX * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2) * CALL DIDTS(N,M,W,WD,LDWD,ALPHA,TT,LDTT,FJACX,LDFJX,VDTD,N) DO 20 I=1,N OMEGA(I) = SQRT(ONE+DDOT(M,VDTD(I,1),N,FJACX(I,1),LDFJX)) 20 CONTINUE DO 40 J=1,KP DO 30 I=1,N TFJACB(I,J) = FJACB(I,JPVT(J))/OMEGA(I) 30 CONTINUE 40 CONTINUE * C SET UP VDTD AND YT C (VDTD = DDELT * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2) * CALL DIDTS(N,M,W,WD,LDWD,ALPHA,TT,LDTT,DDELT,N,VDTD,N) DO 50 I=1,N VDTD(I,1) = DDOT(M,FJACX(I,1),LDFJX,VDTD(I,1),N) YT(I) = -(F(I)-VDTD(I,1))/OMEGA(I) 50 CONTINUE * C COMPUTE S * C DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0) * IF (ALPHA.EQ.ZERO) THEN IPVT = 1 DO 60 I=1,NPP JPVT(I) = 0 60 CONTINUE ELSE IPVT = 0 END IF * CALL DQRDC(TFJACB,N,N,KP,QRAUX,JPVT,WRK2,IPVT) * C GET TR(Q)*YT * CALL DQRSL(TFJACB,N,N,KP,QRAUX,YT,DUM,YT,DUM,DUM,DUM,1000,INF) * C ELIMINATE ALPHA PART USING GIVENS ROTATIONS * IF (ALPHA.NE.ZERO) THEN CALL DZERO(NPP,1,S,NPP) DO 90 I=1,KP CALL DZERO(KP,1,WRK2,KP) IF (SS(1).GT.ZERO) THEN WRK2(I) = SQRT(ALPHA)*SS(JPVT(I)) ELSE WRK2(I) = SQRT(ALPHA)*ABS(SS(1)) END IF DO 80 J=I,KP CALL DROTG(TFJACB(J,J),WRK2(J),CO,SI) IF (KP-J.GE.1) THEN CALL DROT(KP-J,TFJACB(J,J+1),N,WRK2(J+1),1,CO,SI) END IF TEMP = CO*YT(J) + SI*S(JPVT(I)) S(JPVT(I)) = -SI*YT(J) + CO*S(JPVT(I)) YT(J) = TEMP 80 CONTINUE 90 CONTINUE END IF * C COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY * IF (NPP.GE.1) THEN IF (ALPHA.EQ.ZERO) THEN KP = NPP * C ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR * 100 CALL DTRCO(TFJACB,N,KP,RCOND,U,1) IF (RCOND.LE.EPSMAC) THEN ELIM = .TRUE. IMAX = IDAMAX(KP,U,1) * C IMAX IS THE COLUMN TO REMOVE - USE DCHEX AND FIX JPVT * IF (IMAX.NE.KP) THEN CALL DCHEX(TFJACB,N,KP,IMAX,KP,YT,N,1,QRAUX,WRK2,2) J = JPVT(IMAX) DO 110 I=IMAX,KP-1 JPVT(I) = JPVT(I+1) 110 CONTINUE JPVT(KP) = J END IF KP = KP-1 ELSE ELIM = .FALSE. END IF IF (ELIM .AND. KP.GE.1) THEN GO TO 100 ELSE IRANK = NPP-KP END IF END IF * C BACKSOLVE AND UNSCRAMBLE * DO 120 I=KP+1,NPP YT(I) = ZERO 120 CONTINUE IF (KP.GE.1) THEN CALL DTRSL(TFJACB,N,KP,YT,01,INF) END IF DO 130 I=1,NPP S(JPVT(I)) = YT(I) 130 CONTINUE END IF * C COMPUTE T * DO 140 I=1,N TEMP = F(I)+DDOT(NPP,FJACB(I,1),LDFJB,S,1) U(I) = (TEMP-VDTD(I,1))/(OMEGA(I)**2) 140 CONTINUE DO 160 J=1,M DO 150 I=1,N T(I,J) = -(FJACX(I,J)*U(I) + DDELT(I,J)) 150 CONTINUE 160 CONTINUE * C (T = T * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2) * CALL DIDTS(N,M,W,WD,LDWD,ALPHA,TT,LDTT,T,N,T,N) * C COMPUTE PHI(ALPHA) FROM SCALED S AND T * IF (NPP.GE.1) THEN CALL DDIAGS(NPP,1,SS,NPP,S,NPP,SSS,NPP) END IF CALL DDIAGS(N,M,TT,LDTT,T,N,SSS(NPP+1),N) PHI = DNRM2(NPP+N*M,SSS,1) * RETURN END *DPACK SUBROUTINE DPACK + (N2,N1,V1,V2,IFIX) C***BEGIN PROLOGUE DPACK C***REFER TO DODR,DODRC C***ROUTINES CALLED DCOPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1 C***END PROLOGUE DPACK * C...SCALAR ARGUMENTS INTEGER + N1,N2 * C...ARRAY ARGUMENTS DOUBLE PRECISION + V1(N2),V2(N2) INTEGER + IFIX(N2) * C...LOCAL SCALARS INTEGER + I * C...EXTERNAL SUBROUTINES EXTERNAL + DCOPY * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIX(N2) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF V2 ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE DISCUSSION OF IFIXB AND IFIXX IN PROLOGUE OF C SUBROUTINE DODR OR DODRC.) C INTEGER N1 C THE NUMBER OF ITEMS IN V1. C INTEGER N2 C THE NUMBER OF ITEMS IN V2. C DOUBLE PRECISION V1(N2) C THE VECTOR OF THE UNFIXED ITEMS FROM V2. C DOUBLE PRECISION V2(N2) C THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE C UNFIXED ELEMENTS ARE TO BE EXTRACTED. * * C***FIRST EXECUTABLE STATEMENT DPACK * * N1 = 0 IF (IFIX(1).GE.0) THEN DO 10 I=1,N2 IF (IFIX(I).NE.0) THEN N1 = N1+1 V1(N1) = V2(I) END IF 10 CONTINUE ELSE N1 = N2 CALL DCOPY(N2,V2,1,V1,1) END IF * RETURN END *DPVB DOUBLE PRECISION FUNCTION DPVB + (FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,NROW,J,STP,ISTOPF) C***BEGIN PROLOGUE DPVB C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP C***END PROLOGUE DPVB * C...SCALAR ARGUMENTS DOUBLE PRECISION + STP INTEGER + ISTOPF,J,LDXPD,M,N,NFEV,NP,NROW * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS DOUBLE PRECISION + TEMP * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C DOUBLE PRECISION PVTEMP(N) C THE VECTOR OF PREDICTED VALUE FROM THE MODEL. C DOUBLE PRECISION STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE. C DOUBLE PRECISION TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT DPVB * * C COMPUTE PREDICTED VALUES * TEMP = BETA(J) BETA(J) = BETA(J) + STP ISTOPF = 0 CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,ISTOPF) NFEV = NFEV + 1 BETA(J) = TEMP * DPVB = PVTEMP(NROW) * RETURN END *DPVD DOUBLE PRECISION FUNCTION DPVD + (FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,NROW,J,STP,ISTOPF) C***BEGIN PROLOGUE DPVD C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE NROW-TH FUNCTION VALUE USING C X(NROW,J) + DELTA(NROW,J) + STP C***END PROLOGUE DPVD * C...SCALAR ARGUMENTS DOUBLE PRECISION + STP INTEGER + ISTOPF,J,LDXPD,M,N,NFEV,NP,NROW * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS DOUBLE PRECISION + TEMP * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C DOUBLE PRECISION PVTEMP(N) C THE VECTOR OF PREDICTED VALUE FROM THE MODEL. C DOUBLE PRECISION STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE. C DOUBLE PRECISION TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE C (NROW,J)TH ELEMENT OF XPLUSD IS STORED. C DOUBLE PRECISION XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT DPVD * * C COMPUTE PREDICTED VALUES * TEMP = XPLUSD(NROW,J) XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP ISTOPF = 0 CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,ISTOPF) NFEV = NFEV + 1 XPLUSD(NROW,J) = TEMP * DPVD = PVTEMP(NROW) * RETURN END *DSCLB SUBROUTINE DSCLB + (NP,BETA,SSF) C***BEGIN PROLOGUE DSCLB C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE APPROPRIATE SCALE VALUES FOR BETA'S ACCORDING TO C THE ALGORITHM GIVEN IN THE PROLOGUES FOR DODR AND DODRC C***END PROLOGUE DSCLB * C...SCALAR ARGUMENTS INTEGER + NP * C...ARRAY ARGUMENTS DOUBLE PRECISION + BETA(NP),SSF(NP) * C...LOCAL SCALARS DOUBLE PRECISION + BMAX,BMIN,ONE,TEN,ZERO INTEGER + K LOGICAL + BIGDIF * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,LOG10,MAX,MIN,SQRT * C...DATA STATEMENTS DATA + ZERO,ONE,TEN + /0.0D0,1.0D0,10.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL BIGDIF C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THERE IS A C SIGNIFICANT DIFFERENCE IN THE MAGNITUDES OF THE NONZERO C BETA'S (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). C DOUBLE PRECISION BMAX C THE LARGEST NONZERO MAGNITUDE. C DOUBLE PRECISION BMIN C THE SMALLEST NONZERO MAGNITUDE. C INTEGER K C AN INDEXING VARIABLE. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION SSF(NP) C THE SCALE USED FOR THE BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION TEN C THE VALUE 10.0D0. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DSCLB * * BMAX = ABS(BETA(1)) DO 10 K=2,NP BMAX = MAX(BMAX,ABS(BETA(K))) 10 CONTINUE * IF (BMAX.EQ.ZERO) THEN * C ALL INPUT VALUES OF BETA ARE ZERO * DO 20 K=1,NP SSF(K) = ONE 20 CONTINUE * ELSE * C SOME OF THE INPUT VALUES ARE NONZERO * BMIN = BMAX DO 30 K=1,NP IF (BETA(K).NE.ZERO) THEN BMIN = MIN(BMIN,ABS(BETA(K))) END IF 30 CONTINUE BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE DO 40 K=1,NP IF (BETA(K).EQ.ZERO) THEN SSF(K) = TEN/BMIN ELSE IF (BIGDIF) THEN SSF(K) = ONE/ABS(BETA(K)) ELSE SSF(K) = ONE/BMAX END IF END IF 40 CONTINUE * END IF * RETURN END *DSCLD SUBROUTINE DSCLD + (N,M,X,LDX,TT,LDTT) C***BEGIN PROLOGUE DSCLD C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE APPROPRIATE SCALE VALUES FOR DELTA'S ACCORDING TO C THE ALGORITHM GIVEN IN THE PROLOGUES FOR DODR AND DODRC C***END PROLOGUE DSCLD * C...SCALAR ARGUMENTS INTEGER + LDTT,LDX,M,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + TT(LDTT,M),X(LDX,M) * C...LOCAL SCALARS DOUBLE PRECISION + ONE,TEN,XMAX,XMIN,ZERO INTEGER + I,J LOGICAL + BIGDIF * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,LOG10,MAX,MIN * C...DATA STATEMENTS DATA + ZERO,ONE,TEN + /0.0D0,1.0D0,10.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL BIGDIF C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THERE IS A C SIGNIFICANT DIFFERENCE IN THE MAGNITUDES OF THE NONZERO C BETA'S (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION ONE C THE VALUE 1.0D0. C DOUBLE PRECISION TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION XMAX C THE LARGEST NONZERO MAGNITUDE. C DOUBLE PRECISION XMIN C THE SMALLEST NONZERO MAGNITUDE. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DSCLD * * DO 50 J=1,M XMAX = ABS(X(1,J)) DO 10 I=2,N XMAX = MAX(XMAX,ABS(X(I,J))) 10 CONTINUE * IF (XMAX.EQ.ZERO) THEN * C ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO * DO 20 I=1,N TT(I,J) = ONE 20 CONTINUE * ELSE * C SOME OF THE INPUT VALUES ARE NONZERO * XMIN = XMAX DO 30 I=1,N IF (X(I,J).NE.ZERO) THEN XMIN = MIN(XMIN,ABS(X(I,J))) END IF 30 CONTINUE BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE DO 40 I=1,N IF (X(I,J).NE.ZERO) THEN IF (BIGDIF) THEN TT(I,J) = ONE/ABS(X(I,J)) ELSE TT(I,J) = ONE/XMAX END IF ELSE TT(I,J) = TEN/XMIN END IF 40 CONTINUE END IF 50 CONTINUE * RETURN END *DSETN SUBROUTINE DSETN + (N,M,X,LDX,NROW) C***BEGIN PROLOGUE DSETN C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED C***END PROLOGUE DSETN * C...SCALAR ARGUMENTS INTEGER + LDX,M,N,NROW * C...ARRAY ARGUMENTS DOUBLE PRECISION + X(LDX,M) * C...LOCAL SCALARS INTEGER + I,J * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEX VARIABLE. C INTEGER J C AN INDEX VARIABLE. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE USER-SUPPLIED NUMBER OF THE ROW OF THE INDEPENDENT C VARIABLE ARRAY AT WHICH THE DERIVATIVE IS TO BE CHECKED. C DOUBLE PRECISION X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) * * C***FIRST EXECUTABLE STATEMENT DSETN * * IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN * C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS C IF THERE IS ONE, OTHERWISE FIRST ROW IS USED. * DO 20 I = 1, N DO 10 J = 1, M IF (X(I,J).EQ.0.0) GO TO 20 10 CONTINUE NROW = I RETURN 20 CONTINUE * NROW = 1 * RETURN END *DUNPAC SUBROUTINE DUNPAC + (N2,V1,V2,IFIX) C***BEGIN PROLOGUE DUNPAC C***REFER TO DODR,DODRC C***ROUTINES CALLED DCOPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE C UNFIXED C***END PROLOGUE DUNPAC * C...SCALAR ARGUMENTS INTEGER + N2 * C...ARRAY ARGUMENTS DOUBLE PRECISION + V1(N2),V2(N2) INTEGER + IFIX(N2) * C...LOCAL SCALARS INTEGER + I,N1 * C...EXTERNAL SUBROUTINES EXTERNAL + DCOPY * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIX(N2) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF V2 ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE DISCUSSION OF IFIXB AND IFIXX IN PROLOGUE OF C SUBROUTINE DODR OR DODRC.) C INTEGER N1 C THE NUMBER OF ITEMS IN V1. C INTEGER N2 C THE NUMBER OF ITEMS IN V2. C DOUBLE PRECISION V1(N2) C THE VECTOR OF THE UNFIXED ITEMS. C DOUBLE PRECISION V2(N2) C THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE C ELEMENTS OF V1 ARE TO BE INSERTED. * * C***FIRST EXECUTABLE STATEMENT DUNPAC * * N1 = 0 IF (IFIX(1).GE.0) THEN DO 10 I = 1,N2 IF (IFIX(I).NE.0) THEN N1 = N1 + 1 V2(I) = V1(N1) END IF 10 CONTINUE ELSE N1 = N2 CALL DCOPY(N2,V1,1,V2,1) END IF * RETURN END *DWDS SUBROUTINE DWDS + (N,M,W,WD,LDWD,T,LDT,WDT,LDWDT) C***BEGIN PROLOGUE DWDS C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SCALE MATRIX T USING W*D, I.E., COMPUTE C WDT = W*D*T C WHERE W AND D ARE DEFINED BY EQ.2 OF THE PROLOGUES FOR C DODR AND DODRC C***END PROLOGUE DWDS * C...SCALAR ARGUMENTS INTEGER + LDT,LDWD,LDWDT,M,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + T(LDT,M),W(N),WD(LDWD,M),WDT(LDWDT,M) * C...LOCAL SCALARS DOUBLE PRECISION + TEMP,ZERO INTEGER + I,J * C...INTRINSIC FUNCTIONS INTRINSIC + ABS * C...DATA STATEMENTS DATA + ZERO + /0.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDT C THE LEADING DIMENSION OF ARRAY T. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWDT C THE LEADING DIMENSION OF ARRAY WDT. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION T(LDT,M) C THE ARRAY BEING SCALED BY W*D. C DOUBLE PRECISION TEMP C A TEMPORARY STORAGE LOCATION. C DOUBLE PRECISION W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C DOUBLE PRECISION WDT(LDWDT,M) C THE RESULTS OF SCALING ARRAY T BY W*D. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DWDS * * IF (N.EQ.0 .OR. M.EQ.0) RETURN * IF (W(1).GE.ZERO) THEN IF (WD(1,1).GT.ZERO) THEN IF (LDWD.GE.N) THEN DO 20 J=1,M DO 10 I=1,N WDT(I,J) = W(I)*WD(I,J)*T(I,J) 10 CONTINUE 20 CONTINUE ELSE DO 40 J=1,M DO 30 I=1,N WDT(I,J) = W(I)*WD(1,J)*T(I,J) 30 CONTINUE 40 CONTINUE END IF ELSE DO 60 J=1,M DO 50 I=1,N WDT(I,J) = W(I)*ABS(WD(1,1))*T(I,J) 50 CONTINUE 60 CONTINUE END IF ELSE IF (WD(1,1).GT.ZERO) THEN IF (LDWD.GE.N) THEN DO 80 J=1,M DO 70 I=1,N WDT(I,J) = WD(I,J)*T(I,J) 70 CONTINUE 80 CONTINUE ELSE DO 100 J=1,M TEMP = WD(1,J) DO 90 I=1,N WDT(I,J) = TEMP*T(I,J) 90 CONTINUE 100 CONTINUE END IF ELSE TEMP = ABS(WD(1,1)) DO 120 J=1,M DO 110 I=1,N WDT(I,J) = TEMP*T(I,J) 110 CONTINUE 120 CONTINUE END IF END IF * RETURN END *DWINF SUBROUTINE DWINF + (N,M,NP, + DELTAI,EPSI, + WSSI,WSSDEI,WSSEPI,RVARI, + PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI, + FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,DELTSI, + DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,TAUI, + ALPHAI,VCVI,OMEGAI,YTI,UI,QRAUXI,WRK1I,SEI,RCONDI, + ETAI,ACTRSI,PNORMI,PRERSI,RNORSI, + LWKMN) C***BEGIN PROLOGUE DWINF C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SET STORAGE LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE C***END PROLOGUE DWINF * C...SCALAR ARGUMENTS INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,DDELTI,DELTAI,DELTNI,DELTSI, + EPSI,EPSMAI,ETAI,FJACBI,FJACXI,FNI,FSI,LWKMN,M,N,NP,OLMAVI, + OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,RNORSI,RVARI,SEI,SI, + SSFI,SSI,SSSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI,WRK1I, + WSSI,WSSDEI,WSSEPI,XPLUSI,YTI * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER ACTRSI C THE LOCATION IN ARRAY WORK OF C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER ALPHAI C THE LOCATION IN ARRAY WORK OF C THE LEVENBERG-MARQUARDT PARAMETER. C INTEGER BETACI C THE STARTING LOCATION IN ARRAY WORK OF C THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETANI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETASI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER DDELTI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (W*D)**2 * DELTA. C INTEGER DELTAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER EPSI C THE STARTING LOCATION IN ARRAY WORK OF C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER EPSMAI C THE LOCATION IN ARRAY WORK OF C THE VALUE OF MACHINE PRECISION. C INTEGER ETAI C THE LOCATION IN ARRAY WORK OF C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C INTEGER FJACBI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO BETA. C INTEGER FJACXI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO X. C INTEGER FNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER OLMAVI C THE LOCATION IN ARRAY WORK OF C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OMEGAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C INTEGER PARTLI C THE LOCATION IN ARRAY WORK OF C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C INTEGER PNORMI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C INTEGER PRERSI C THE LOCATION IN ARRAY WORK OF C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER QRAUXI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C INTEGER RCONDI C THE LOCATION IN ARRAY WORK OF C THE APPROXIMATE RECIPROCAL CONDITION OF C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER RNORSI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C INTEGER RVARI C THE LOCATION IN ARRAY WORK OF C THE RESIDUAL VARIANCE. C INTEGER SEI C THE STARTING LOCATION IN ARRAY WORK OF C THE STANDARD ERRORS FOR THE PARAMETERS, ALSO USED AS A C WORK ARRAY. C INTEGER SI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED BETA'S. C INTEGER SSFI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE BETA'S. C INTEGER SSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE ESTIMATED BETA'S. C INTEGER SSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C INTEGER SSTOLI C THE LOCATION IN ARRAY WORK OF C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C INTEGER TAUFCI C THE LOCATION IN ARRAY WORK OF C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C INTEGER TAUI C THE LOCATION IN ARRAY WORK OF C THE TRUST REGION DIAMETER. C INTEGER TI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED DELTA'S. C INTEGER TTI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE DELTA'S. C INTEGER UI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER VCVI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE VARIANCE COVARIANCE MATRIX, ALSO USED C TO STORE THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER WRK1I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C INTEGER WSSDEI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C INTEGER WSSEPI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C INTEGER XPLUSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY X + DELTA. C INTEGER YTI C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). * * C***FIRST EXECUTABLE STATEMENT DWINF * * IF (N.GE.1 .AND. NP.GE.1 .AND. M.GE.1) THEN DELTAI = 1 EPSI = DELTAI + N*M WSSI = EPSI + N WSSDEI = WSSI + 1 WSSEPI = WSSDEI + 1 RVARI = WSSEPI + 1 PARTLI = RVARI + 1 SSTOLI = PARTLI + 1 TAUFCI = SSTOLI + 1 EPSMAI = TAUFCI + 1 OLMAVI = EPSMAI + 1 FJACBI = OLMAVI + 1 FJACXI = FJACBI + N*NP XPLUSI = FJACXI + N*M BETACI = XPLUSI + N*M BETASI = BETACI + NP BETANI = BETASI + NP DELTSI = BETANI + NP DELTNI = DELTSI + N*M DDELTI = DELTNI + N*M FSI = DDELTI + N*M FNI = FSI + N SI = FNI + N SSSI = SI + NP SSI = SSSI + N*M + N SSFI = SSI + NP TI = SSFI + NP TTI = TI + N*M TAUI = TTI + N*M ALPHAI = TAUI + 1 VCVI = ALPHAI + 1 OMEGAI = VCVI + N*NP YTI = OMEGAI + N UI = YTI + N QRAUXI = UI + N WRK1I = QRAUXI + NP SEI = WRK1I + N*M RCONDI = SEI + NP ETAI = RCONDI + 1 ACTRSI = ETAI + 1 PNORMI = ACTRSI + 1 PRERSI = PNORMI + 1 RNORSI = PRERSI + 1 LWKMN = RNORSI ELSE DELTAI = 1 EPSI = 1 WSSI = 1 WSSDEI = 1 WSSEPI = 1 RVARI = 1 PARTLI = 1 SSTOLI = 1 TAUFCI = 1 EPSMAI = 1 OLMAVI = 1 FJACBI = 1 FJACXI = 1 XPLUSI = 1 BETACI = 1 BETASI = 1 BETANI = 1 DELTSI = 1 DELTNI = 1 DDELTI = 1 FSI = 1 FNI = 1 SI = 1 SSSI = 1 SSI = 1 SSFI = 1 TI = 1 TTI = 1 TAUI = 1 ALPHAI = 1 VCVI = 1 OMEGAI = 1 YTI = 1 UI = 1 QRAUXI = 1 WRK1I = 1 SEI = 1 RCONDI = 1 ETAI = 1 ACTRSI = 1 PNORMI = 1 PRERSI = 1 RNORSI = 1 LWKMN = 1 END IF * RETURN END *DXPY SUBROUTINE DXPY + (N,M,X,LDX,Y,LDY,XPY,LDXPY) C***BEGIN PROLOGUE DXPY C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE XPY = X + Y C***END PROLOGUE DXPY * C...SCALAR ARGUMENTS INTEGER + LDX,LDXPY,LDY,M,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + X(LDX,M),XPY(LDXPY,M),Y(LDY,M) * C...LOCAL SCALARS INTEGER + I,J * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C INTEGER LDXPY C THE LEADING DIMENSION OF ARRAY XPY. C INTEGER LDY C THE LEADING DIMENSION OF ARRAY Y. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y TO BE ADDED C TOGETHER. C INTEGER N C THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y TO BE ADDED C TOGETHER. C DOUBLE PRECISION X(LDX,M) C THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER. C DOUBLE PRECISION XPY(LDXPY,M) C THE SUM OF THE TWO ARRAYS TO BE ADDED TOGETHER. C DOUBLE PRECISION Y(LDY,M) C THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER. * * C***FIRST EXECUTABLE STATEMENT DXPY * * DO 20 J=1,M DO 10 I=1,N XPY(I,J) = X(I,J) + Y(I,J) 10 CONTINUE 20 CONTINUE * RETURN END *DZERO SUBROUTINE DZERO + (N,M,A,LDA) C***BEGIN PROLOGUE DZERO C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SET A = ZERO C***END PROLOGUE DZERO * C...SCALAR ARGUMENTS INTEGER + LDA,M,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + A(LDA,M) * C...LOCAL SCALARS DOUBLE PRECISION + ZERO INTEGER + I,J * C...DATA STATEMENTS DATA + ZERO + /0.0D0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C DOUBLE PRECISION A(LDA,M) C THE ARRAY TO BE SET TO ZERO. C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDA C THE LEADING DIMENSION OF ARRAY A. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN ARRAY A TO BE SET TO ZERO. C INTEGER N C THE NUMBER OF ROWS OF DATA IN ARRAY A TO BE SET TO ZERO. C DOUBLE PRECISION ZERO C THE VALUE 0.0D0. * * C***FIRST EXECUTABLE STATEMENT DZERO * * DO 20 J=1,M DO 10 I=1,N A(I,J) = ZERO 10 CONTINUE 20 CONTINUE * RETURN END *JAC SUBROUTINE JAC(N,NP,M,BETA,XPLUSD,LDXPD, + FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOP) C***BEGIN PROLOGUE JAC C***REFER TO ?CODR,?CODRC C***ROUTINES CALLED NONE C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE DUMMY ROUTINE PROVIDED TO PREVENT OCCURANCE OF C UNSATISFIED EXTERNAL WHEN THE USER DOES NOT PROVIDE C SUBROUTINE JAC. C***END PROLOGUE JAC * C...SCALAR ARGUMENTS C INTEGER C + ISTOP,LDFJB,LDFJX,LDXPD,M,N,NP C LOGICAL C + ISODR * C...ARRAY ARGUMENTS C FLOATING POINT C + BETA(NP),FJACB(LDFJB,NP),FJACX(LDFJX,M),XPLUSD(LDXPD,M) * C...INTRINSIC FUNCTIONS C INTRINSIC C + EXP * * C***FIRST EXECUTABLE STATEMENT JAC * * PRINT *, ' **** ERROR ****' PRINT *, ' USER IS ATTEMPTING TO ACCESS A SUBROUTINE JAC', + ' WHEN NONE HAS BEEN PROVIDED' * ISTOP = -1 * RETURN END *DASUM DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) C***BEGIN PROLOGUE DASUM C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A3A C***KEYWORDS ADD,BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAGNITUDE,SUM, C VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE SUM OF MAGNITUDES OF D.P. VECTOR COMPONENTS C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX C --OUTPUT-- C DASUM DOUBLE PRECISION RESULT (ZERO IF N .LE. 0) C RETURNS SUM OF MAGNITUDES OF DOUBLE PRECISION DX. C DASUM = SUM FROM 0 TO N-1 OF DABS(DX(1+I*INCX)) C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE DASUM * C...SCALAR ARGUMENTS INTEGER + INCX,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + DX(*) * C...LOCAL SCALARS INTEGER + I,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + DABS,MOD * * C***FIRST EXECUTABLE STATEMENT DASUM * * DASUM = 0.D0 IF(N.LE.0)RETURN IF(INCX.EQ.1)GOTO 20 * C CODE FOR INCREMENTS NOT EQUAL TO 1. * NS = N*INCX DO 10 I=1,NS,INCX DASUM = DASUM + DABS(DX(I)) 10 CONTINUE RETURN * C CODE FOR INCREMENTS EQUAL TO 1. * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. * 20 M = MOD(N,6) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DASUM = DASUM + DABS(DX(I)) 30 CONTINUE IF( N .LT. 6 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,6 DASUM = DASUM + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) 1 + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5)) 50 CONTINUE RETURN END *DAXPY SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) C***BEGIN PROLOGUE DAXPY C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A7 C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,TRIAD,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE D.P COMPUTATION Y = A*X + Y C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C DA DOUBLE PRECISION SCALAR MULTIPLIER C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY C --OUTPUT-- C DY DOUBLE PRECISION RESULT (UNCHANGED IF N .LE. 0) C OVERWRITE DOUBLE PRECISION DY WITH DOUBLE PRECISION DA*DX + DY. C FOR I = 0 TO N-1, REPLACE DY(LY+I*INCY) WITH DA*DX(LX+I*INCX) + C DY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N C AND LY IS DEFINED IN A SIMILAR WAY USING INCY. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE DAXPY * C...SCALAR ARGUMENTS DOUBLE PRECISION + DA INTEGER + INCX,INCY,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + DX(*),DY(*) * C...LOCAL SCALARS INTEGER + I,IX,IY,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT DAXPY * * IF(N.LE.0.OR.DA.EQ.0.D0) RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE * C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. * IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * C CODE FOR BOTH INCREMENTS EQUAL TO 1 * * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. * 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DY(I) + DA*DX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 DY(I) = DY(I) + DA*DX(I) DY(I + 1) = DY(I + 1) + DA*DX(I + 1) DY(I + 2) = DY(I + 2) + DA*DX(I + 2) DY(I + 3) = DY(I + 3) + DA*DX(I + 3) 50 CONTINUE RETURN * C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. * 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX DY(I) = DA*DX(I) + DY(I) 70 CONTINUE RETURN END *DCHEX SUBROUTINE DCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB) C***BEGIN PROLOGUE DCHEX C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D7B C***KEYWORDS CHOLESKY DECOMPOSITION,DOUBLE PRECISION,EXCHANGE, C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE UPDATES THE CHOLESKY FACTORIZATION A=TRANS(R)*R OF A C POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL C PERMUTATIONS OF THE FORM TRANS(E)*A*E WHERE E IS A C PERMUTATION MATRIX. C***DESCRIPTION C DCHEX UPDATES THE CHOLESKY FACTORIZATION C A = TRANS(R)*R C OF A POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL C PERMUTATIONS OF THE FORM C TRANS(E)*A*E C WHERE E IS A PERMUTATION MATRIX. SPECIFICALLY, GIVEN C AN UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX C E (WHICH IS SPECIFIED BY K, L, AND JOB), DCHEX DETERMINES C AN ORTHOGONAL MATRIX U SUCH THAT C U*R*E = RR, C WHERE RR IS UPPER TRIANGULAR. AT THE USERS OPTION, THE C TRANSFORMATION U WILL BE MULTIPLIED INTO THE ARRAY Z. C IF A = TRANS(X)*X, SO THAT R IS THE TRIANGULAR PART OF THE C QR FACTORIZATION OF X, THEN RR IS THE TRIANGULAR PART OF THE C QR FACTORIZATION OF X*E, I.E. X WITH ITS COLUMNS PERMUTED. C FOR A LESS TERSE DESCRIPTION OF WHAT DCHEX DOES AND HOW C IT MAY BE APPLIED, SEE THE LINPACK GUIDE. C THE MATRIX Q IS DETERMINED AS THE PRODUCT U(L-K)*...*U(1) C OF PLANE ROTATIONS OF THE FORM C ( C(I) S(I) ) C ( ) , C ( -S(I) C(I) ) C WHERE C(I) IS DOUBLE PRECISION. THE ROWS THESE ROTATIONS OPERATE C ON ARE DESCRIBED BELOW. C THERE ARE TWO TYPES OF PERMUTATIONS, WHICH ARE DETERMINED C BY THE VALUE OF JOB. C 1. RIGHT CIRCULAR SHIFT (JOB = 1). C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER. C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) C ACTS IN THE (L-I,L-I+1)-PLANE. C 2. LEFT CIRCULAR SHIFT (JOB = 2). C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) C ACTS IN THE (K+I-1,K+I)-PLANE. C ON ENTRY C R DOUBLE PRECISION(LDR,P), WHERE LDR .GE. P. C R CONTAINS THE UPPER TRIANGULAR FACTOR C THAT IS TO BE UPDATED. ELEMENTS OF R C BELOW THE DIAGONAL ARE NOT REFERENCED. C LDR INTEGER. C LDR IS THE LEADING DIMENSION OF THE ARRAY R. C P INTEGER. C P IS THE ORDER OF THE MATRIX R. C K INTEGER. C K IS THE FIRST COLUMN TO BE PERMUTED. C L INTEGER. C L IS THE LAST COLUMN TO BE PERMUTED. C L MUST BE STRICTLY GREATER THAN K. C Z DOUBLE PRECISION(LDZ,N)Z), WHERE LDZ .GE. P. C Z IS AN ARRAY OF NZ P-VECTORS INTO WHICH THE C TRANSFORMATION U IS MULTIPLIED. Z IS C NOT REFERENCED IF NZ = 0. C LDZ INTEGER. C LDZ IS THE LEADING DIMENSION OF THE ARRAY Z. C NZ INTEGER. C NZ IS THE NUMBER OF COLUMNS OF THE MATRIX Z. C JOB INTEGER. C JOB DETERMINES THE TYPE OF PERMUTATION. C JOB = 1 RIGHT CIRCULAR SHIFT. C JOB = 2 LEFT CIRCULAR SHIFT. C ON RETURN C R CONTAINS THE UPDATED FACTOR. C Z CONTAINS THE UPDATED MATRIX Z. C C DOUBLE PRECISION(P). C C CONTAINS THE COSINES OF THE TRANSFORMING ROTATIONS. C S DOUBLE PRECISION(P). C S CONTAINS THE SINES OF THE TRANSFORMING ROTATIONS. C LINPACK. THIS VERSION DATED 08/14/78 . C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED DROTG C***END PROLOGUE DCHEX * C...SCALAR ARGUMENTS INTEGER + JOB,K,L,LDR,LDZ,NZ,P * C...ARRAY ARGUMENTS DOUBLE PRECISION + C(*),R(LDR,*),S(*),Z(LDZ,*) * C...LOCAL SCALARS DOUBLE PRECISION + T,T1 INTEGER + I,II,IL,IU,J,JJ,KM1,KP1,LM1,LMK * C...EXTERNAL SUBROUTINES EXTERNAL + DROTG * C...INTRINSIC FUNCTIONS INTRINSIC + MAX0,MIN0 * * C***FIRST EXECUTABLE STATEMENT DCHEX * * KM1 = K - 1 KP1 = K + 1 LMK = L - K LM1 = L - 1 * C PERFORM THE APPROPRIATE TASK. * GO TO (10,130), JOB * C RIGHT CIRCULAR SHIFT. * 10 CONTINUE * C REORDER THE COLUMNS. * DO 20 I = 1, L II = L - I + 1 S(I) = R(II,L) 20 CONTINUE DO 40 JJ = K, LM1 J = LM1 - JJ + K DO 30 I = 1, J R(I,J+1) = R(I,J) 30 CONTINUE R(J+1,J+1) = 0.0D0 40 CONTINUE IF (K .EQ. 1) GO TO 60 DO 50 I = 1, KM1 II = L - I + 1 R(I,K) = S(II) 50 CONTINUE 60 CONTINUE * C CALCULATE THE ROTATIONS. * T = S(1) DO 70 I = 1, LMK T1 = S(I) CALL DROTG(S(I+1),T,C(I),T1) S(I) = T1 T = S(I+1) 70 CONTINUE R(K,K) = T DO 90 J = KP1, P IL = MAX0(1,L-J+1) DO 80 II = IL, LMK I = L - II T = C(II)*R(I,J) + S(II)*R(I+1,J) R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) R(I,J) = T 80 CONTINUE 90 CONTINUE * C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. * IF (NZ .LT. 1) GO TO 120 DO 110 J = 1, NZ DO 100 II = 1, LMK I = L - II T = C(II)*Z(I,J) + S(II)*Z(I+1,J) Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) Z(I,J) = T 100 CONTINUE 110 CONTINUE 120 CONTINUE GO TO 260 * C LEFT CIRCULAR SHIFT * 130 CONTINUE * C REORDER THE COLUMNS * DO 140 I = 1, K II = LMK + I S(II) = R(I,K) 140 CONTINUE DO 160 J = K, LM1 DO 150 I = 1, J R(I,J) = R(I,J+1) 150 CONTINUE JJ = J - KM1 S(JJ) = R(J+1,J+1) 160 CONTINUE DO 170 I = 1, K II = LMK + I R(I,L) = S(II) 170 CONTINUE DO 180 I = KP1, L R(I,L) = 0.0D0 180 CONTINUE * C REDUCTION LOOP. * DO 220 J = K, P IF (J .EQ. K) GO TO 200 * C APPLY THE ROTATIONS. * IU = MIN0(J-1,L-1) DO 190 I = K, IU II = I - K + 1 T = C(II)*R(I,J) + S(II)*R(I+1,J) R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) R(I,J) = T 190 CONTINUE 200 CONTINUE IF (J .GE. L) GO TO 210 JJ = J - K + 1 T = S(JJ) CALL DROTG(R(J,J),T,C(JJ),S(JJ)) 210 CONTINUE 220 CONTINUE * C APPLY THE ROTATIONS TO Z. * IF (NZ .LT. 1) GO TO 250 DO 240 J = 1, NZ DO 230 I = K, LM1 II = I - KM1 T = C(II)*Z(I,J) + S(II)*Z(I+1,J) Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) Z(I,J) = T 230 CONTINUE 240 CONTINUE 250 CONTINUE 260 CONTINUE RETURN END *DCOPY SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) C***BEGIN PROLOGUE DCOPY C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A5 C***KEYWORDS BLAS,COPY,DOUBLE PRECISION,LINEAR ALGEBRA,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE D.P. VECTOR COPY Y = X C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY C --OUTPUT-- C DY COPY OF VECTOR DX (UNCHANGED IF N .LE. 0) C COPY DOUBLE PRECISION DX TO DOUBLE PRECISION DY. C FOR I = 0 TO N-1, COPY DX(LX+I*INCX) TO DY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE DCOPY * C...SCALAR ARGUMENTS INTEGER + INCX,INCY,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + DX(*),DY(*) * C...LOCAL SCALARS INTEGER + I,IX,IY,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT DCOPY * * IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE * C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. * IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * C CODE FOR BOTH INCREMENTS EQUAL TO 1 * * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. * 20 M = MOD(N,7) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DX(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 DY(I) = DX(I) DY(I + 1) = DX(I + 1) DY(I + 2) = DX(I + 2) DY(I + 3) = DX(I + 3) DY(I + 4) = DX(I + 4) DY(I + 5) = DX(I + 5) DY(I + 6) = DX(I + 6) 50 CONTINUE RETURN * C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. * 60 CONTINUE NS=N*INCX DO 70 I=1,NS,INCX DY(I) = DX(I) 70 CONTINUE RETURN END *DDOT DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) C***BEGIN PROLOGUE DDOT C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A4 C***KEYWORDS BLAS,DOUBLE PRECISION,INNER PRODUCT,LINEAR ALGEBRA,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE D.P. INNER PRODUCT OF D.P. VECTORS C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY C --OUTPUT-- C DDOT DOUBLE PRECISION DOT PRODUCT (ZERO IF N .LE. 0) C RETURNS THE DOT PRODUCT OF DOUBLE PRECISION DX AND DY. C DDOT = SUM FOR I = 0 TO N-1 OF DX(LX+I*INCX) * DY(LY+I*INCY) C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE DDOT * C...SCALAR ARGUMENTS INTEGER + INCX,INCY,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + DX(*),DY(*) * C...LOCAL SCALARS INTEGER + I,IX,IY,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT DDOT * * DDOT = 0.D0 IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE * C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. * IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DDOT = DDOT + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * C CODE FOR BOTH INCREMENTS EQUAL TO 1. * * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. * 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DDOT = DDOT + DX(I)*DY(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DDOT = DDOT + DX(I)*DY(I) + DX(I+1)*DY(I+1) + 1 DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) 50 CONTINUE RETURN * C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. * 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX DDOT = DDOT + DX(I)*DY(I) 70 CONTINUE RETURN END *DNRM2 DOUBLE PRECISION FUNCTION DNRM2(N,DX,INCX) C***BEGIN PROLOGUE DNRM2 C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A3B C***KEYWORDS BLAS,DOUBLE PRECISION,EUCLIDEAN,L2,LENGTH,LINEAR ALGEBRA, C NORM,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE EUCLIDEAN LENGTH (L2 NORM) OF D.P. VECTOR C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX C --OUTPUT-- C DNRM2 DOUBLE PRECISION RESULT (ZERO IF N .LE. 0) C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE C INCREMENT INCX . C IF N .LE. 0 RETURN WITH RESULT = 0. C IF N .GE. 1 THEN INCX MUST BE .GE. 1 C C.L. LAWSON, 1978 JAN 08 C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE C HOPEFULLY APPLICABLE TO ALL MACHINES. C CUTLO = MAXIMUM OF DSQRT(U/EPS) OVER ALL KNOWN MACHINES. C CUTHI = MINIMUM OF DSQRT(V) OVER ALL KNOWN MACHINES. C WHERE C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) C V = LARGEST NO. (OVERFLOW LIMIT) C BRIEF OUTLINE OF ALGORITHM.. C PHASE 1 SCANS ZERO COMPONENTS. C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. * C VALUES FOR CUTLO AND CUTHI.. C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE C UNIVAC AND DEC AT 2**(-103) C THUS CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. C THUS CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. C THUS CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE DNRM2 * C...SCALAR ARGUMENTS INTEGER + INCX,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + DX(*) * C...LOCAL SCALARS DOUBLE PRECISION + CUTHI,CUTLO,HITEST,ONE,SUM,XMAX,ZERO INTEGER + I,J,NEXT,NN * C...INTRINSIC FUNCTIONS INTRINSIC + DABS,DSQRT,FLOAT * C...DATA STATEMENTS DATA + ZERO,ONE/0.0D0,1.0D0/ DATA + CUTLO,CUTHI/8.232D-11,1.304D19/ * * C***FIRST EXECUTABLE STATEMENT DNRM2 * * XMAX = ZERO IF(N .GT. 0) GO TO 10 DNRM2 = ZERO GO TO 300 * 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP I = 1 C 20 GO TO NEXT,(30, 50, 70, 110) 20 GO TO NEXT 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO * C PHASE 1. SUM IS ZERO * 50 IF( DX(I) .EQ. ZERO) GO TO 200 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 * C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 * C PREPARE FOR PHASE 4. * 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / DX(I)) / DX(I) 105 XMAX = DABS(DX(I)) GO TO 115 * C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. * 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 * C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. * 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / DX(I))**2 XMAX = DABS(DX(I)) GO TO 200 * 115 SUM = SUM + (DX(I)/XMAX)**2 GO TO 200 * * C PREPARE FOR PHASE 3. * 75 SUM = (SUM * XMAX) * XMAX * * C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) * 85 HITEST = CUTHI/FLOAT( N ) * C PHASE 3. SUM IS MID-RANGE. NO SCALING. * DO 95 J =I,NN,INCX IF(DABS(DX(J)) .GE. HITEST) GO TO 100 95 SUM = SUM + DX(J)**2 DNRM2 = DSQRT( SUM ) GO TO 300 * 200 CONTINUE I = I + INCX IF ( I .LE. NN ) GO TO 20 * C END OF MAIN LOOP. * C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. * DNRM2 = XMAX * DSQRT(SUM) 300 CONTINUE RETURN END *DPODI SUBROUTINE DPODI(A,LDA,N,DET,JOB) C***BEGIN PROLOGUE DPODI C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2B1B,D3B1B C***KEYWORDS DETERMINANT,DOUBLE PRECISION,FACTOR,INVERSE, C LINEAR ALGEBRA,LINPACK,MATRIX,POSITIVE DEFINITE C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN DOUBLE C PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE ABSTRACT) C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. C***DESCRIPTION C DPODI COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN C DOUBLE PRECISION SYMMETRIC POSITIVE DEFINITE MATRIX (SEE BELOW) C USING THE FACTORS COMPUTED BY DPOCO, DPOFA OR DQRDC. C ON ENTRY C A DOUBLE PRECISION(LDA, N) C THE OUTPUT A FROM DPOCO OR DPOFA C OR THE OUTPUT X FROM DQRDC. C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C N INTEGER C THE ORDER OF THE MATRIX A . C JOB INTEGER C = 11 BOTH DETERMINANT AND INVERSE. C = 01 INVERSE ONLY. C = 10 DETERMINANT ONLY. C ON RETURN C A IF DPOCO OR DPOFA WAS USED TO FACTOR A , THEN C DPODI PRODUCES THE UPPER HALF OF INVERSE(A) . C IF DQRDC WAS USED TO DECOMPOSE X , THEN C DPODI PRODUCES THE UPPER HALF OF INVERSE(TRANS(X)*X) C WHERE TRANS(X) IS THE TRANSPOSE. C ELEMENTS OF A BELOW THE DIAGONAL ARE UNCHANGED. C IF THE UNITS DIGIT OF JOB IS ZERO, A IS UNCHANGED. C DET DOUBLE PRECISION(2) C DETERMINANT OF A OR OF TRANS(X)*X IF REQUESTED. C OTHERWISE NOT REFERENCED. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. DET(1) .LT. 10.0 C OR DET(1) .EQ. 0.0 . C ERROR CONDITION C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY C AND IF DPOCO OR DPOFA HAS SET INFO .EQ. 0 . C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED DAXPY,DSCAL C***END PROLOGUE DPODI * C...SCALAR ARGUMENTS INTEGER JOB,LDA,N * C...ARRAY ARGUMENTS DOUBLE PRECISION A(LDA,*),DET(*) * C...LOCAL SCALARS DOUBLE PRECISION S,T INTEGER I,J,JM1,K,KP1 * C...EXTERNAL SUBROUTINES EXTERNAL DAXPY,DSCAL * C...INTRINSIC FUNCTIONS INTRINSIC MOD * * C***FIRST EXECUTABLE STATEMENT DPODI * * IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0D0 DET(2) = 0.0D0 S = 10.0D0 DO 50 I = 1, N DET(1) = A(I,I)**2*DET(1) C ...EXIT IF (DET(1) .EQ. 0.0D0) GO TO 60 10 IF (DET(1) .GE. 1.0D0) GO TO 20 DET(1) = S*DET(1) DET(2) = DET(2) - 1.0D0 GO TO 10 20 CONTINUE 30 IF (DET(1) .LT. S) GO TO 40 DET(1) = DET(1)/S DET(2) = DET(2) + 1.0D0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE * C COMPUTE INVERSE(R) * IF (MOD(JOB,10) .EQ. 0) GO TO 140 DO 100 K = 1, N A(K,K) = 1.0D0/A(K,K) T = -A(K,K) CALL DSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0D0 CALL DAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE * C FORM INVERSE(R) * TRANS(INVERSE(R)) * DO 130 J = 1, N JM1 = J - 1 IF (JM1 .LT. 1) GO TO 120 DO 110 K = 1, JM1 T = A(K,J) CALL DAXPY(K,T,A(1,J),1,A(1,K),1) 110 CONTINUE 120 CONTINUE T = A(J,J) CALL DSCAL(J,T,A(1,J),1) 130 CONTINUE 140 CONTINUE RETURN END *DQRDC SUBROUTINE DQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB) C***BEGIN PROLOGUE DQRDC C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D5 C***KEYWORDS DECOMPOSITION,DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK, C MATRIX,ORTHOGONAL TRIANGULAR C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR FACTORI- C ZATION OF N BY P MATRIX X. COLUMN PIVOTING IS OPTIONAL. C***DESCRIPTION C DQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING C BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE C PERFORMED AT THE USER'S OPTION. C ON ENTRY C X DOUBLE PRECISION(LDX,P), WHERE LDX .GE. N. C X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE C COMPUTED. C LDX INTEGER. C LDX IS THE LEADING DIMENSION OF THE ARRAY X. C N INTEGER. C N IS THE NUMBER OF ROWS OF THE MATRIX X. C P INTEGER. C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. C JPVT INTEGER(P). C JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION C OF THE PIVOT COLUMNS. THE K-TH COLUMN X(K) OF X C IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE C VALUE OF JPVT(K). C IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL C COLUMN. C IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN. C IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN. C BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS C ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL C COLUMNS TO THE END. BOTH INITIAL AND FINAL COLUMNS C ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY C FREE COLUMNS ARE MOVED. AT THE K-TH STAGE OF THE C REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN C IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST C REDUCED NORM. JPVT IS NOT REFERENCED IF C JOB .EQ. 0. C WORK DOUBLE PRECISION(P). C WORK IS A WORK ARRAY. WORK IS NOT REFERENCED IF C JOB .EQ. 0. C JOB INTEGER. C JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING. C IF JOB .EQ. 0, NO PIVOTING IS DONE. C IF JOB .NE. 0, PIVOTING IS DONE. C ON RETURN C X X CONTAINS IN ITS UPPER TRIANGLE THE UPPER C TRIANGULAR MATRIX R OF THE QR FACTORIZATION. C BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM C WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION C CAN BE RECOVERED. NOTE THAT IF PIVOTING HAS C BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT C OF THE ORIGINAL MATRIX X BUT THAT OF X C WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT. C QRAUX DOUBLE PRECISION(P). C QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER C THE ORTHOGONAL PART OF THE DECOMPOSITION. C JPVT JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE C ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO C THE K-TH COLUMN, IF PIVOTING WAS REQUESTED. C LINPACK. THIS VERSION DATED 08/14/78 . C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED DAXPY,DDOT,DNRM2,DSCAL,DSWAP C***END PROLOGUE DQRDC * C...SCALAR ARGUMENTS INTEGER + JOB,LDX,N,P * C...ARRAY ARGUMENTS DOUBLE PRECISION + QRAUX(*),WORK(*),X(LDX,*) INTEGER + JPVT(*) * C...LOCAL SCALARS DOUBLE PRECISION + MAXNRM,NRMXL,T,TT INTEGER + J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU LOGICAL + NEGJ,SWAPJ * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT,DNRM2 EXTERNAL + DDOT,DNRM2 * C...EXTERNAL SUBROUTINES EXTERNAL + DAXPY,DSCAL,DSWAP * C...INTRINSIC FUNCTIONS INTRINSIC + DABS,DMAX1,DSIGN,DSQRT,MIN0 * * C***FIRST EXECUTABLE STATEMENT DQRDC * * PL = 1 PU = 0 IF (JOB .EQ. 0) GO TO 60 * C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS C ACCORDING TO JPVT. * DO 20 J = 1, P SWAPJ = JPVT(J) .GT. 0 NEGJ = JPVT(J) .LT. 0 JPVT(J) = J IF (NEGJ) JPVT(J) = -J IF (.NOT.SWAPJ) GO TO 10 IF (J .NE. PL) CALL DSWAP(N,X(1,PL),1,X(1,J),1) JPVT(J) = JPVT(PL) JPVT(PL) = J PL = PL + 1 10 CONTINUE 20 CONTINUE PU = P DO 50 JJ = 1, P J = P - JJ + 1 IF (JPVT(J) .GE. 0) GO TO 40 JPVT(J) = -JPVT(J) IF (J .EQ. PU) GO TO 30 CALL DSWAP(N,X(1,PU),1,X(1,J),1) JP = JPVT(PU) JPVT(PU) = JPVT(J) JPVT(J) = JP 30 CONTINUE PU = PU - 1 40 CONTINUE 50 CONTINUE 60 CONTINUE * C COMPUTE THE NORMS OF THE FREE COLUMNS. * IF (PU .LT. PL) GO TO 80 DO 70 J = PL, PU QRAUX(J) = DNRM2(N,X(1,J),1) WORK(J) = QRAUX(J) 70 CONTINUE 80 CONTINUE * C PERFORM THE HOUSEHOLDER REDUCTION OF X. * LUP = MIN0(N,P) DO 200 L = 1, LUP IF (L .LT. PL .OR. L .GE. PU) GO TO 120 * C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT C INTO THE PIVOT POSITION. * MAXNRM = 0.0D0 MAXJ = L DO 100 J = L, PU IF (QRAUX(J) .LE. MAXNRM) GO TO 90 MAXNRM = QRAUX(J) MAXJ = J 90 CONTINUE 100 CONTINUE IF (MAXJ .EQ. L) GO TO 110 CALL DSWAP(N,X(1,L),1,X(1,MAXJ),1) QRAUX(MAXJ) = QRAUX(L) WORK(MAXJ) = WORK(L) JP = JPVT(MAXJ) JPVT(MAXJ) = JPVT(L) JPVT(L) = JP 110 CONTINUE 120 CONTINUE QRAUX(L) = 0.0D0 IF (L .EQ. N) GO TO 190 * C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. * NRMXL = DNRM2(N-L+1,X(L,L),1) IF (NRMXL .EQ. 0.0D0) GO TO 180 IF (X(L,L) .NE. 0.0D0) NRMXL = DSIGN(NRMXL,X(L,L)) CALL DSCAL(N-L+1,1.0D0/NRMXL,X(L,L),1) X(L,L) = 1.0D0 + X(L,L) * C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, C UPDATING THE NORMS. * LP1 = L + 1 IF (P .LT. LP1) GO TO 170 DO 160 J = LP1, P T = -DDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) CALL DAXPY(N-L+1,T,X(L,L),1,X(L,J),1) IF (J .LT. PL .OR. J .GT. PU) GO TO 150 IF (QRAUX(J) .EQ. 0.0D0) GO TO 150 TT = 1.0D0 - (DABS(X(L,J))/QRAUX(J))**2 TT = DMAX1(TT,0.0D0) T = TT TT = 1.0D0 + 0.05D0*TT*(QRAUX(J)/WORK(J))**2 IF (TT .EQ. 1.0D0) GO TO 130 QRAUX(J) = QRAUX(J)*DSQRT(T) GO TO 140 130 CONTINUE QRAUX(J) = DNRM2(N-L,X(L+1,J),1) WORK(J) = QRAUX(J) 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE * C SAVE THE TRANSFORMATION. * QRAUX(L) = X(L,L) X(L,L) = -NRMXL 180 CONTINUE 190 CONTINUE 200 CONTINUE RETURN END *DQRSL SUBROUTINE DQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) C***BEGIN PROLOGUE DQRSL C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D9,D2A1 C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX, C ORTHOGONAL TRIANGULAR,SOLVE C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. C***DESCRIPTION C DQRSL APPLIES THE OUTPUT OF DQRDC TO COMPUTE COORDINATE C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. C FOR K .LE. MIN(N,P), LET XK BE THE MATRIX C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) C FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL C N X P MATRIX X THAT WAS INPUT TO DQRDC (IF NO PIVOTING WAS C DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR C ORIGINAL ORDER). DQRDC PRODUCES A FACTORED ORTHOGONAL MATRIX Q C AND AN UPPER TRIANGULAR MATRIX R SUCH THAT C XK = Q * (R) C (0) C THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS C X AND QRAUX. C ON ENTRY C X DOUBLE PRECISION(LDX,P). C X CONTAINS THE OUTPUT OF DQRDC. C LDX INTEGER. C LDX IS THE LEADING DIMENSION OF THE ARRAY X. C N INTEGER. C N IS THE NUMBER OF ROWS OF THE MATRIX XK. IT MUST C HAVE THE SAME VALUE AS N IN DQRDC. C K INTEGER. C K IS THE NUMBER OF COLUMNS OF THE MATRIX XK. K C MUST NOT BE GREATER THAN MIN(N,P), WHERE P IS THE C SAME AS IN THE CALLING SEQUENCE TO DQRDC. C QRAUX DOUBLE PRECISION(P). C QRAUX CONTAINS THE AUXILIARY OUTPUT FROM DQRDC. C Y DOUBLE PRECISION(N) C Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED C BY DQRSL. C JOB INTEGER. C JOB SPECIFIES WHAT IS TO BE COMPUTED. JOB HAS C THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING C MEANING. C IF A .NE. 0, COMPUTE QY. C IF B,C,D, OR E .NE. 0, COMPUTE QTY. C IF C .NE. 0, COMPUTE B. C IF D .NE. 0, COMPUTE RSD. C IF E .NE. 0, COMPUTE XB. C NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB C AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR C WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING C SEQUENCE. C ON RETURN C QY DOUBLE PRECISION(N). C QY CONTAINS Q*Y, IF ITS COMPUTATION HAS BEEN C REQUESTED. C QTY DOUBLE PRECISION(N). C QTY CONTAINS TRANS(Q)*Y, IF ITS COMPUTATION HAS C BEEN REQUESTED. HERE TRANS(Q) IS THE C TRANSPOSE OF THE MATRIX Q. C B DOUBLE PRECISION(K) C B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM C MINIMIZE NORM2(Y - XK*B), C IF ITS COMPUTATION HAS BEEN REQUESTED. (NOTE THAT C IF PIVOTING WAS REQUESTED IN DQRDC, THE J-TH C COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J) C OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO DQRDC.) C RSD DOUBLE PRECISION(N). C RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B, C IF ITS COMPUTATION HAS BEEN REQUESTED. RSD IS C ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE C ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK. C XB DOUBLE PRECISION(N). C XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B, C IF ITS COMPUTATION HAS BEEN REQUESTED. XB IS ALSO C THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE C OF X. C INFO INTEGER. C INFO IS ZERO UNLESS THE COMPUTATION OF B HAS C BEEN REQUESTED AND R IS EXACTLY SINGULAR. IN C THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO C DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED. C THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED C IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE C CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM. C TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME C ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE. A C FREQUENTLY OCCURING EXAMPLE IS WHEN ONE WISHES TO COMPUTE C ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY. IN THIS C CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE C PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE C COMPUTED. THUS THE CALLING SEQUENCE C CALL DQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) C WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD C OVERWRITING Y. MORE GENERALLY, EACH ITEM IN THE FOLLOWING C LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR C A SINGLE CALLING SEQUENCE. C 1. (Y,QTY,B) (RSD) (XB) (QY) C 2. (Y,QTY,RSD) (B) (XB) (QY) C 3. (Y,QTY,XB) (B) (RSD) (QY) C 4. (Y,QY) (QTY,B) (RSD) (XB) C 5. (Y,QY) (QTY,RSD) (B) (XB) C 6. (Y,QY) (QTY,XB) (B) (RSD) C IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO C THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP. C LINPACK. THIS VERSION DATED 08/14/78 . C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED DAXPY,DCOPY,DDOT C***END PROLOGUE DQRSL * C...SCALAR ARGUMENTS INTEGER + INFO,JOB,K,LDX,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + B(*),QRAUX(*),QTY(*),QY(*),RSD(*),X(LDX,*),XB(*), + Y(*) * C...LOCAL SCALARS DOUBLE PRECISION + T,TEMP INTEGER + I,J,JJ,JU,KP1 LOGICAL + CB,CQTY,CQY,CR,CXB * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT EXTERNAL + DDOT * C...EXTERNAL SUBROUTINES EXTERNAL + DAXPY,DCOPY * C...INTRINSIC FUNCTIONS INTRINSIC + MIN0,MOD * * C***FIRST EXECUTABLE STATEMENT DQRSL * * INFO = 0 * C DETERMINE WHAT IS TO BE COMPUTED. * CQY = JOB/10000 .NE. 0 CQTY = MOD(JOB,10000) .NE. 0 CB = MOD(JOB,1000)/100 .NE. 0 CR = MOD(JOB,100)/10 .NE. 0 CXB = MOD(JOB,10) .NE. 0 JU = MIN0(K,N-1) * C SPECIAL ACTION WHEN N=1. * IF (JU .NE. 0) GO TO 40 IF (CQY) QY(1) = Y(1) IF (CQTY) QTY(1) = Y(1) IF (CXB) XB(1) = Y(1) IF (.NOT.CB) GO TO 30 IF (X(1,1) .NE. 0.0D0) GO TO 10 INFO = 1 GO TO 20 10 CONTINUE B(1) = Y(1)/X(1,1) 20 CONTINUE 30 CONTINUE IF (CR) RSD(1) = 0.0D0 GO TO 250 40 CONTINUE * C SET UP TO COMPUTE QY OR QTY. * IF (CQY) CALL DCOPY(N,Y,1,QY,1) IF (CQTY) CALL DCOPY(N,Y,1,QTY,1) IF (.NOT.CQY) GO TO 70 * C COMPUTE QY. * DO 60 JJ = 1, JU J = JU - JJ + 1 IF (QRAUX(J) .EQ. 0.0D0) GO TO 50 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -DDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) CALL DAXPY(N-J+1,T,X(J,J),1,QY(J),1) X(J,J) = TEMP 50 CONTINUE 60 CONTINUE 70 CONTINUE IF (.NOT.CQTY) GO TO 100 * C COMPUTE TRANS(Q)*Y. * DO 90 J = 1, JU IF (QRAUX(J) .EQ. 0.0D0) GO TO 80 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -DDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) CALL DAXPY(N-J+1,T,X(J,J),1,QTY(J),1) X(J,J) = TEMP 80 CONTINUE 90 CONTINUE 100 CONTINUE * C SET UP TO COMPUTE B, RSD, OR XB. * IF (CB) CALL DCOPY(K,QTY,1,B,1) KP1 = K + 1 IF (CXB) CALL DCOPY(K,QTY,1,XB,1) IF (CR .AND. K .LT. N) CALL DCOPY(N-K,QTY(KP1),1,RSD(KP1),1) IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 DO 110 I = KP1, N XB(I) = 0.0D0 110 CONTINUE 120 CONTINUE IF (.NOT.CR) GO TO 140 DO 130 I = 1, K RSD(I) = 0.0D0 130 CONTINUE 140 CONTINUE IF (.NOT.CB) GO TO 190 * C COMPUTE B. * DO 170 JJ = 1, K J = K - JJ + 1 IF (X(J,J) .NE. 0.0D0) GO TO 150 INFO = J C ......EXIT GO TO 180 150 CONTINUE B(J) = B(J)/X(J,J) IF (J .EQ. 1) GO TO 160 T = -B(J) CALL DAXPY(J-1,T,X(1,J),1,B,1) 160 CONTINUE 170 CONTINUE 180 CONTINUE 190 CONTINUE IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 * C COMPUTE RSD OR XB AS REQUIRED. * DO 230 JJ = 1, JU J = JU - JJ + 1 IF (QRAUX(J) .EQ. 0.0D0) GO TO 220 TEMP = X(J,J) X(J,J) = QRAUX(J) IF (.NOT.CR) GO TO 200 T = -DDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) CALL DAXPY(N-J+1,T,X(J,J),1,RSD(J),1) 200 CONTINUE IF (.NOT.CXB) GO TO 210 T = -DDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) CALL DAXPY(N-J+1,T,X(J,J),1,XB(J),1) 210 CONTINUE X(J,J) = TEMP 220 CONTINUE 230 CONTINUE 240 CONTINUE 250 CONTINUE RETURN END *DROT SUBROUTINE DROT(N,DX,INCX,DY,INCY,DC,DS) C***BEGIN PROLOGUE DROT C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A8 C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE APPLY D.P. GIVENS ROTATION C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY C DC D.P. ELEMENT OF ROTATION MATRIX C DS D.P. ELEMENT OF ROTATION MATRIX C --OUTPUT-- C DX ROTATED VECTOR (UNCHANGED IF N .LE. 0) C DY ROTATED VECTOR (UNCHANGED IF N .LE. 0) C MULTIPLY THE 2 X 2 MATRIX ( DC DS) TIMES THE 2 X N MATRIX (DX**T) C (-DS DC) (DY**T) C WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE C LX = (-INCX)*N, AND SIMILARLY FOR DY USING LY AND INCY. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE DROT * C...SCALAR ARGUMENTS DOUBLE PRECISION + DC,DS INTEGER + INCX,INCY,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + DX(*),DY(*) * C...LOCAL SCALARS DOUBLE PRECISION + ONE,W,Z,ZERO INTEGER + I,KX,KY,NSTEPS * C...DATA STATEMENTS DATA + ZERO,ONE/0.D0,1.D0/ * * C***FIRST EXECUTABLE STATEMENT DROT * * IF(N .LE. 0 .OR. (DS .EQ. ZERO .AND. DC .EQ. ONE)) GO TO 40 IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 * NSTEPS=INCX*N DO 10 I=1,NSTEPS,INCX W=DX(I) Z=DY(I) DX(I)=DC*W+DS*Z DY(I)=-DS*W+DC*Z 10 CONTINUE GO TO 40 * 20 CONTINUE KX=1 KY=1 * IF(INCX .LT. 0) KX=1-(N-1)*INCX IF(INCY .LT. 0) KY=1-(N-1)*INCY * DO 30 I=1,N W=DX(KX) Z=DY(KY) DX(KX)=DC*W+DS*Z DY(KY)=-DS*W+DC*Z KX=KX+INCX KY=KY+INCY 30 CONTINUE 40 CONTINUE * RETURN END *DROTG SUBROUTINE DROTG(DA,DB,DC,DS) C***BEGIN PROLOGUE DROTG C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1B10 C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE CONSTRUCT D.P. PLANE GIVENS ROTATION C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C DA DOUBLE PRECISION SCALAR C DB DOUBLE PRECISION SCALAR C --OUTPUT-- C DA DOUBLE PRECISION RESULT R C DB DOUBLE PRECISION RESULT Z C DC DOUBLE PRECISION RESULT C DS DOUBLE PRECISION RESULT C DESIGNED BY C. L. LAWSON, JPL, 1977 SEPT 08 C CONSTRUCT THE GIVENS TRANSFORMATION C ( DC DS ) C G = ( ) , DC**2 + DS**2 = 1 , C (-DS DC ) C WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (DA,DB)**T . C THE QUANTITY R = (+/-)DSQRT(DA**2 + DB**2) OVERWRITES DA IN C STORAGE. THE VALUE OF DB IS OVERWRITTEN BY A VALUE Z WHICH C ALLOWS DC AND DS TO BE RECOVERED BY THE FOLLOWING ALGORITHM. C IF Z=1 SET DC=0.D0 AND DS=1.D0 C IF DABS(Z) .LT. 1 SET DC=DSQRT(1-Z**2) AND DS=Z C IF DABS(Z) .GT. 1 SET DC=1/Z AND DS=DSQRT(1-DC**2) C NORMALLY, THE SUBPROGRAM DROT(N,DX,INCX,DY,INCY,DC,DS) WILL C NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE DROTG * C...SCALAR ARGUMENTS DOUBLE PRECISION + DA,DB,DC,DS * C...LOCAL SCALARS DOUBLE PRECISION + R,U,V * C...INTRINSIC FUNCTIONS INTRINSIC + DABS,DSQRT * * C***FIRST EXECUTABLE STATEMENT DROTG * * IF (DABS(DA) .LE. DABS(DB)) GO TO 10 * C *** HERE DABS(DA) .GT. DABS(DB) *** * U = DA + DA V = DB / U * C NOTE THAT U AND R HAVE THE SIGN OF DA * R = DSQRT(.25D0 + V**2) * U * C NOTE THAT DC IS POSITIVE * DC = DA / R DS = V * (DC + DC) DB = DS DA = R RETURN * C *** HERE DABS(DA) .LE. DABS(DB) *** * 10 IF (DB .EQ. 0.D0) GO TO 20 U = DB + DB V = DA / U * C NOTE THAT U AND R HAVE THE SIGN OF DB C (R IS IMMEDIATELY STORED IN DA) * DA = DSQRT(.25D0 + V**2) * U * C NOTE THAT DS IS POSITIVE * DS = DB / DA DC = V * (DS + DS) IF (DC .EQ. 0.D0) GO TO 15 DB = 1.D0 / DC RETURN 15 DB = 1.D0 RETURN * C *** HERE DA = DB = 0.D0 *** * 20 DC = 1.D0 DS = 0.D0 RETURN * END *DSCAL SUBROUTINE DSCAL(N,DA,DX,INCX) C***BEGIN PROLOGUE DSCAL C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A6 C***KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE D.P. VECTOR SCALE X = A*X C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C DA DOUBLE PRECISION SCALE FACTOR C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX C --OUTPUT-- C DX DOUBLE PRECISION RESULT (UNCHANGED IF N.LE.0) C REPLACE DOUBLE PRECISION DX BY DOUBLE PRECISION DA*DX. C FOR I = 0 TO N-1, REPLACE DX(1+I*INCX) WITH DA * DX(1+I*INCX) C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE DSCAL * C...SCALAR ARGUMENTS DOUBLE PRECISION + DA INTEGER + INCX,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + DX(*) * C...LOCAL SCALARS INTEGER + I,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT DSCAL * * IF(N.LE.0)RETURN IF(INCX.EQ.1)GOTO 20 * C CODE FOR INCREMENTS NOT EQUAL TO 1. * NS = N*INCX DO 10 I = 1,NS,INCX DX(I) = DA*DX(I) 10 CONTINUE RETURN * C CODE FOR INCREMENTS EQUAL TO 1. * * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. * 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DX(I) = DA*DX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DX(I) = DA*DX(I) DX(I + 1) = DA*DX(I + 1) DX(I + 2) = DA*DX(I + 2) DX(I + 3) = DA*DX(I + 3) DX(I + 4) = DA*DX(I + 4) 50 CONTINUE RETURN END *DSWAP SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) C***BEGIN PROLOGUE DSWAP C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A5 C***KEYWORDS BLAS,DOUBLE PRECISION,INTERCHANGE,LINEAR ALGEBRA,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE INTERCHANGE D.P. VECTORS C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX C DY DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF DY C --OUTPUT-- C DX INPUT VECTOR DY (UNCHANGED IF N .LE. 0) C DY INPUT VECTOR DX (UNCHANGED IF N .LE. 0) C INTERCHANGE DOUBLE PRECISION DX AND DOUBLE PRECISION DY. C FOR I = 0 TO N-1, INTERCHANGE DX(LX+I*INCX) AND DY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE DSWAP * C...SCALAR ARGUMENTS INTEGER + INCX,INCY,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + DX(*),DY(*) * C...LOCAL SCALARS DOUBLE PRECISION + DTEMP1,DTEMP2,DTEMP3 INTEGER + I,IX,IY,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT DSWAP * * IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE * C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. * IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP1 = DX(IX) DX(IX) = DY(IY) DY(IY) = DTEMP1 IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * C CODE FOR BOTH INCREMENTS EQUAL TO 1 * * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. * 20 M = MOD(N,3) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP1 = DX(I) DX(I) = DY(I) DY(I) = DTEMP1 30 CONTINUE IF( N .LT. 3 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 DTEMP1 = DX(I) DTEMP2 = DX(I+1) DTEMP3 = DX(I+2) DX(I) = DY(I) DX(I+1) = DY(I+1) DX(I+2) = DY(I+2) DY(I) = DTEMP1 DY(I+1) = DTEMP2 DY(I+2) = DTEMP3 50 CONTINUE RETURN 60 CONTINUE * C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. * NS = N*INCX DO 70 I=1,NS,INCX DTEMP1 = DX(I) DX(I) = DY(I) DY(I) = DTEMP1 70 CONTINUE RETURN END *DTRCO SUBROUTINE DTRCO(T,LDT,N,RCOND,Z,JOB) C***BEGIN PROLOGUE DTRCO C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A3 C***KEYWORDS CONDITION,DOUBLE PRECISION,FACTOR,LINEAR ALGEBRA,LINPACK, C MATRIX,TRIANGULAR C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR C MATRIX. C***DESCRIPTION C DTRCO ESTIMATES THE CONDITION OF A DOUBLE PRECISION TRIANGULAR C MATRIX. C ON ENTRY C T DOUBLE PRECISION(LDT,N) C T CONTAINS THE TRIANGULAR MATRIX. THE ZERO C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE C USED TO STORE OTHER INFORMATION. C LDT INTEGER C LDT IS THE LEADING DIMENSION OF THE ARRAY T. C N INTEGER C N IS THE ORDER OF THE SYSTEM. C JOB INTEGER C = 0 T IS LOWER TRIANGULAR. C = NONZERO T IS UPPER TRIANGULAR. C ON RETURN C RCOND DOUBLE PRECISION C AN ESTIMATE OF THE RECIPROCAL CONDITION OF T . C FOR THE SYSTEM T*X = B , RELATIVE PERTURBATIONS C IN T AND B OF SIZE EPSILON MAY CAUSE C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION C 1.0 + RCOND .EQ. 1.0 C IS TRUE, THEN T MAY BE SINGULAR TO WORKING C PRECISION. IN PARTICULAR, RCOND IS ZERO IF C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE C UNDERFLOWS. C Z DOUBLE PRECISION(N) C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. C IF T IS CLOSE TO A SINGULAR MATRIX, THEN Z IS C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED DASUM,DAXPY,DSCAL C***END PROLOGUE DTRCO * C...SCALAR ARGUMENTS DOUBLE PRECISION + RCOND INTEGER + JOB,LDT,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + T(LDT,*),Z(*) * C...LOCAL SCALARS DOUBLE PRECISION + EK,S,SM,TNORM,W,WK,WKM,YNORM INTEGER + I1,J,J1,J2,K,KK,L LOGICAL + LOWER * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DASUM EXTERNAL + DASUM * C...EXTERNAL SUBROUTINES EXTERNAL + DAXPY,DSCAL * C...INTRINSIC FUNCTIONS INTRINSIC + DABS,DMAX1,DSIGN * * C***FIRST EXECUTABLE STATEMENT DTRCO * * LOWER = JOB .EQ. 0 * C COMPUTE 1-NORM OF T * TNORM = 0.0D0 DO 10 J = 1, N L = J IF (LOWER) L = N + 1 - J I1 = 1 IF (LOWER) I1 = J TNORM = DMAX1(TNORM,DASUM(L,T(I1,J),1)) 10 CONTINUE * C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . C TRANS(T) IS THE TRANSPOSE OF T . C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL C GROWTH IN THE ELEMENTS OF Y . C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. * C SOLVE TRANS(T)*Y = E * EK = 1.0D0 DO 20 J = 1, N Z(J) = 0.0D0 20 CONTINUE DO 100 KK = 1, N K = KK IF (LOWER) K = N + 1 - KK IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K)) IF (DABS(EK-Z(K)) .LE. DABS(T(K,K))) GO TO 30 S = DABS(T(K,K))/DABS(EK-Z(K)) CALL DSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = DABS(WK) SM = DABS(WKM) IF (T(K,K) .EQ. 0.0D0) GO TO 40 WK = WK/T(K,K) WKM = WKM/T(K,K) GO TO 50 40 CONTINUE WK = 1.0D0 WKM = 1.0D0 50 CONTINUE IF (KK .EQ. N) GO TO 90 J1 = K + 1 IF (LOWER) J1 = 1 J2 = N IF (LOWER) J2 = K - 1 DO 60 J = J1, J2 SM = SM + DABS(Z(J)+WKM*T(K,J)) Z(J) = Z(J) + WK*T(K,J) S = S + DABS(Z(J)) 60 CONTINUE IF (S .GE. SM) GO TO 80 W = WKM - WK WK = WKM DO 70 J = J1, J2 Z(J) = Z(J) + W*T(K,J) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) * YNORM = 1.0D0 * C SOLVE T*Z = Y * DO 130 KK = 1, N K = N + 1 - KK IF (LOWER) K = KK IF (DABS(Z(K)) .LE. DABS(T(K,K))) GO TO 110 S = DABS(T(K,K))/DABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 110 CONTINUE IF (T(K,K) .NE. 0.0D0) Z(K) = Z(K)/T(K,K) IF (T(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 I1 = 1 IF (LOWER) I1 = K + 1 IF (KK .GE. N) GO TO 120 W = -Z(K) CALL DAXPY(N-KK,W,T(I1,K),1,Z(I1),1) 120 CONTINUE 130 CONTINUE C MAKE ZNORM = 1.0 S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM * IF (TNORM .NE. 0.0D0) RCOND = YNORM/TNORM IF (TNORM .EQ. 0.0D0) RCOND = 0.0D0 RETURN END *DTRSL SUBROUTINE DTRSL(T,LDT,N,B,JOB,INFO) C***BEGIN PROLOGUE DTRSL C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A3 C***KEYWORDS DOUBLE PRECISION,LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE, C TRIANGULAR C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE SOLVES SYSTEMS OF THE FORM T*X=B OR TRANS(T)*X=B WHERE T C IS A TRIANGULAR MATRIX OF ORDER N. C***DESCRIPTION C DTRSL SOLVES SYSTEMS OF THE FORM C T * X = B C OR C TRANS(T) * X = B C WHERE T IS A TRIANGULAR MATRIX OF ORDER N. HERE TRANS(T) C DENOTES THE TRANSPOSE OF THE MATRIX T. C ON ENTRY C T DOUBLE PRECISION(LDT,N) C T CONTAINS THE MATRIX OF THE SYSTEM. THE ZERO C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE C USED TO STORE OTHER INFORMATION. C LDT INTEGER C LDT IS THE LEADING DIMENSION OF THE ARRAY T. C N INTEGER C N IS THE ORDER OF THE SYSTEM. C B DOUBLE PRECISION(N). C B CONTAINS THE RIGHT HAND SIDE OF THE SYSTEM. C JOB INTEGER C JOB SPECIFIES WHAT KIND OF SYSTEM IS TO BE SOLVED. C IF JOB IS C 00 SOLVE T*X=B, T LOWER TRIANGULAR, C 01 SOLVE T*X=B, T UPPER TRIANGULAR, C 10 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, C 11 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. C ON RETURN C B B CONTAINS THE SOLUTION, IF INFO .EQ. 0. C OTHERWISE B IS UNALTERED. C INFO INTEGER C INFO CONTAINS ZERO IF THE SYSTEM IS NONSINGULAR. C OTHERWISE INFO CONTAINS THE INDEX OF C THE FIRST ZERO DIAGONAL ELEMENT OF T. C LINPACK. THIS VERSION DATED 08/14/78 . C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED DAXPY,DDOT C***END PROLOGUE DTRSL * C...SCALAR ARGUMENTS INTEGER + INFO,JOB,LDT,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + B(*),T(LDT,*) * C...LOCAL SCALARS DOUBLE PRECISION + TEMP INTEGER + CASE,J,JJ * C...EXTERNAL FUNCTIONS DOUBLE PRECISION + DDOT EXTERNAL + DDOT * C...EXTERNAL SUBROUTINES EXTERNAL + DAXPY * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT DTRSL * * C BEGIN BLOCK PERMITTING ...EXITS TO 150 * C CHECK FOR ZERO DIAGONAL ELEMENTS. * DO 10 INFO = 1, N C ......EXIT IF (T(INFO,INFO) .EQ. 0.0D0) GO TO 150 10 CONTINUE INFO = 0 * C DETERMINE THE TASK AND GO TO IT. * CASE = 1 IF (MOD(JOB,10) .NE. 0) CASE = 2 IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 GO TO (20,50,80,110), CASE * C SOLVE T*X=B FOR T LOWER TRIANGULAR * 20 CONTINUE B(1) = B(1)/T(1,1) IF (N .LT. 2) GO TO 40 DO 30 J = 2, N TEMP = -B(J-1) CALL DAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) B(J) = B(J)/T(J,J) 30 CONTINUE 40 CONTINUE GO TO 140 * C SOLVE T*X=B FOR T UPPER TRIANGULAR. * 50 CONTINUE B(N) = B(N)/T(N,N) IF (N .LT. 2) GO TO 70 DO 60 JJ = 2, N J = N - JJ + 1 TEMP = -B(J+1) CALL DAXPY(J,TEMP,T(1,J+1),1,B(1),1) B(J) = B(J)/T(J,J) 60 CONTINUE 70 CONTINUE GO TO 140 * C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. * 80 CONTINUE B(N) = B(N)/T(N,N) IF (N .LT. 2) GO TO 100 DO 90 JJ = 2, N J = N - JJ + 1 B(J) = B(J) - DDOT(JJ-1,T(J+1,J),1,B(J+1),1) B(J) = B(J)/T(J,J) 90 CONTINUE 100 CONTINUE GO TO 140 * C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. * 110 CONTINUE B(1) = B(1)/T(1,1) IF (N .LT. 2) GO TO 130 DO 120 J = 2, N B(J) = B(J) - DDOT(J-1,T(1,J),1,B(1),1) B(J) = B(J)/T(J,J) 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END *IDAMAX INTEGER FUNCTION IDAMAX(N,DX,INCX) C***BEGIN PROLOGUE IDAMAX C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A2 C***KEYWORDS BLAS,DOUBLE PRECISION,LINEAR ALGEBRA,MAXIMUM COMPONENT, C VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE FIND LARGEST COMPONENT OF D.P. VECTOR C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C DX DOUBLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF DX C --OUTPUT-- C IDAMAX SMALLEST INDEX (ZERO IF N .LE. 0) C FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF DOUBLE PRECISION DX. C IDAMAX = FIRST I, I = 1 TO N, TO MINIMIZE ABS(DX(1-INCX+I*INCX) C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE IDAMAX * C...SCALAR ARGUMENTS INTEGER + INCX,N * C...ARRAY ARGUMENTS DOUBLE PRECISION + DX(*) * C...LOCAL SCALARS DOUBLE PRECISION + DMAX,XMAG INTEGER + I,II,NS * C...INTRINSIC FUNCTIONS INTRINSIC + DABS * * C***FIRST EXECUTABLE STATEMENT IDAMAX * * IDAMAX = 0 IF(N.LE.0) RETURN IDAMAX = 1 IF(N.LE.1)RETURN IF(INCX.EQ.1)GOTO 20 * C CODE FOR INCREMENTS NOT EQUAL TO 1. * DMAX = DABS(DX(1)) NS = N*INCX II = 1 DO 10 I = 1,NS,INCX XMAG = DABS(DX(I)) IF(XMAG.LE.DMAX) GO TO 5 IDAMAX = II DMAX = XMAG 5 II = II + 1 10 CONTINUE RETURN * C CODE FOR INCREMENTS EQUAL TO 1. * 20 DMAX = DABS(DX(1)) DO 30 I = 2,N XMAG = DABS(DX(I)) IF(XMAG.LE.DMAX) GO TO 30 IDAMAX = I DMAX = XMAG 30 CONTINUE RETURN END *DMPREC DOUBLE PRECISION FUNCTION DMPREC() C***BEGIN PROLOGUE DPREC C***REFER TO DODR,DODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE DETERMINE MACHINE PRECISION FOR TARGET MACHINE AND COMPILER C ASSUMING FLOATING-POINT NUMBERS ARE REPRESENTED IN THE C T-DIGIT, BASE-B FORM C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, AND C 0 .LT. X(1). C TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE, C EITHER C ACTIVATE THE DESIRED SET OF DATA STATEMENTS BY C REMOVING THE C FROM COLUMN 1 C OR C SET B, TD AND TS USING I1MACH BY ACTIVATING C THE DECLARATION STATEMENTS FOR I1MACH C AND THE STATEMENTS PRECEEDING THE FIRST C EXECUTABLE STATEMENT BELOW. C***END PROLOGUE DPREC * C...LOCAL SCALARS DOUBLE PRECISION + B INTEGER + TD,TS * C...EXTERNAL FUNCTIONS C INTEGER C + I1MACH C EXTERNAL C + I1MACH * C...VARIABLE DEFINITIONS (ALPHABETICALLY) * C DOUBLE PRECISION B C THE BASE OF THE TARGET MACHINE. C (MAY BE DEFINED USING I1MACH(10).) C INTEGER TD C THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION. C (MAY BE DEFINED USING I1MACH(14).) C INTEGER TS C THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION. C (MAY BE DEFINED USING I1MACH(11).) * * C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C DATA B / 2 / C DATA TS / 24 / C DATA TD / 60 / * C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM C THE BURROUGHS 6700/7700 SYSTEMS C DATA B / 8 / C DATA TS / 13 / C DATA TD / 26 / * C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN5 COMPILER) C THE CYBER 170/180 SERIES UNDER NOS C DATA B / 2 / C DATA TS / 48 / C DATA TD / 96 / * C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN COMPILER) C THE CYBER 170/180 SERIES UNDER NOS/VE C THE CYBER 200 SERIES C DATA B / 2 / C DATA TS / 47 / C DATA TD / 94 / * C MACHINE CONSTANTS FOR THE CRAY 1 C DATA B / 2 / C DATA TS / 47 / C DATA TD / 94 / * C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * C MACHINE CONSTANTS FOR THE HARRIS COMPUTER C DATA B / 2 / C DATA TS / 23 / C DATA TD / 38 / * C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 C THE HONEYWELL 600/6000 SERIES C DATA B / 2 / C DATA TS / 27 / C DATA TD / 63 / * C MACHINE CONSTANTS FOR THE HP 2100 C (3 WORD DOUBLE PRECISION OPTION WITH FTN4) C DATA B / 2 / C DATA TS / 23 / C DATA TD / 39 / * C MACHINE CONSTANTS FOR THE HP 2100 C (4 WORD DOUBLE PRECISION OPTION WITH FTN4) C DATA B / 2 / C DATA TS / 23 / C DATA TD / 55 / * C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * C MACHINE CONSTANTS FOR THE IBM PC C DATA B / 2 / C DATA TS / 24 / C DATA TD / 53 / * C MACHINE CONSTANTS FOR THE INTERDATA (PERKIN ELMER) 7/32 C INTERDATA (PERKIN ELMER) 8/32 C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). C DATA B / 2 / C DATA TS / 27 / C DATA TD / 54 / * C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). C DATA B / 2 / C DATA TS / 27 / C DATA TD / 62 / * C MACHINE CONSTANTS FOR THE PDP-11 SYSTEM C DATA B / 2 / C DATA TS / 24 / C DATA TD / 56 / * C MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230 C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * C MACHINE CONSTANTS FOR THE PRIME 850 AND PRIME 4050 C DATA B / 2 / C DATA TS / 23 / C DATA TD / 47 / * C MACHINE CONSTANTS FOR THE SEL SYSTEMS 85/86 C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * C MACHINE CONSTANTS FOR SUN 3 C DATA B / 2 / C DATA TS / 24 / C DATA TD / 53 / * C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C DATA B / 2 / C DATA TS / 27 / C DATA TD / 60 / * C MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS COMPILER C DATA B / 2 / C DATA TS / 24 / C DATA TD / 56 / * C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITHOUT G_FLOATING C DATA B / 2 / C DATA TS / 24 / C DATA TD / 56 / * C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITH G_FLOATING C DATA B / 2 / C DATA TS / 24 / C DATA TD / 53 / * C MACHINE CONSTANTS FOR THE XEROX SIGMA 5/7/9 C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * * C***FIRST EXECUTABLE STATEMENT DMPREC * * C B = I1MACH(10) C TS = I1MACH(11) C TD = I1MACH(14) * DMPREC = B ** (1-TD) * RETURN * END *JAC SUBROUTINE JAC(N,NP,M,BETA,XPLUSD,LDXPD, + FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOP) C***BEGIN PROLOGUE JAC C***REFER TO ?CODR,?CODRC C***ROUTINES CALLED NONE C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE DUMMY ROUTINE PROVIDED TO PREVENT OCCURANCE OF C UNSATISFIED EXTERNAL WHEN THE USER DOES NOT PROVIDE C SUBROUTINE JAC. C***END PROLOGUE JAC * C...SCALAR ARGUMENTS C INTEGER C + ISTOP,LDFJB,LDFJX,LDXPD,M,N,NP C LOGICAL C + ISODR * C...ARRAY ARGUMENTS C FLOATING POINT C + BETA(NP),FJACB(LDFJB,NP),FJACX(LDFJX,M),XPLUSD(LDXPD,M) * C...INTRINSIC FUNCTIONS C INTRINSIC C + EXP * * C***FIRST EXECUTABLE STATEMENT JAC * * PRINT *, ' **** ERROR ****' PRINT *, ' USER IS ATTEMPTING TO ACCESS A SUBROUTINE JAC', + ' WHEN NONE HAS BEEN PROVIDED' * ISTOP = -1 * RETURN END *SACCES SUBROUTINE SACCES + (N,M,NP,WORK,LWORK,IWORK,LIWORK, + ACCESS, + JPVT,WRK1,TFJACB,OMEGA,YT,U,QRAUX,WRK2, + NNZW,NPP, + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,EPSMAC,NETA, + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS) C***BEGIN PROLOGUE SACCES C***REFER TO SODR,SODRC C***ROUTINES CALLED SIWINF,SWINF C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE ACCESS OR STORE VALUES IN THE WORK ARRAYS C***END PROLOGUE SACESS * C...SCALAR ARGUMENTS REAL + ACTRS,ALPHA,EPSMAC,OLMAVG,PARTOL,PNORM,PRERS,RCOND, + RNORMS,RVAR,SSTOL,TAU,TAUFAC,WSS,WSSDEL,WSSEPS INTEGER + IDF,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,JOB,JPVT,LIWORK,LUNRPT, + LWORK,M,MAXIT,N,NETA,NFEV,NITER,NJEV,NNZW,NP,NPP,OMEGA, + QRAUX,TFJACB,U,WRK1,WRK2,YT LOGICAL + ACCESS * C...ARRAY ARGUMENTS REAL + WORK(LWORK) INTEGER + IWORK(LIWORK) * C...LOCAL SCALARS INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,DDELTI,DELTAI,DELTNI,DELTSI, + EPSMAI,ETAI,FI,FJACBI,FJACXI,FNI,FSI,IDFI,INT2I,IPRINI,IPRINT, + IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI,LUNRPI,LWKMN,MAXITI, + MSGB,MSGX,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NPPI,NROWI,NTOLI, + OLMAVI,OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,RNORSI,RVARI, + SI,SSFI,SSI,SSSI,SSTOLI,TAUFCI,TAUI,TFJACI,TI,TTI,UI,WRK1I, + WRK2I,WSSI,WSSDEI,WSSEPI,XPLUSI,YTI * C...EXTERNAL SUBROUTINES EXTERNAL + SIWINF,SWINF * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL ACTRS C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER ACTRSI C THE LOCATION IN ARRAY WORK OF C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C REAL ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C INTEGER ALPHAI C THE LOCATION IN ARRAY WORK OF C THE LEVENBERG-MARQUARDT PARAMETER. C INTEGER BETACI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETANI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETASI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER DDELTI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (W*D)**2 * DELTA. C INTEGER DELTAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C REAL EPSMAC C THE VALUE OF MACHINE PRECISION. C INTEGER EPSMAI C THE LOCATION IN ARRAY WORK OF C THE VALUE OF MACHINE PRECISION. C INTEGER ETAI C THE LOCATION IN ARRAY WORK OF C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C INTEGER FI C THE STARTING LOCATION IN ARRAY WORK OF C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FJACBI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO BETA. C INTEGER FJACXI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO X. C INTEGER FNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER IDF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IDFI C THE STARTING LOCATION IN ARRAY IWORK OF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER INT2 C THE NUMBER OF INTERNAL DOUBLING STEPS. C INTEGER INT2I C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF INTERNAL DOUBLING STEPS. C INTEGER IPR1 C THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE INITIAL SUMMARY REPORT. C INTEGER IPR2 C THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE ITERATION REPORTS. C INTEGER IPR2F C THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. C INTEGER IPR3 C THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FINAL SUMMARY REPORT. C INTEGER IPRINI C THE LOCATION IN ARRAY IWORK OF C THE PRINT CONTROL VARIABLE. C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C INTEGER IRANKI C THE LOCATION IN ARRAY IWORK OF C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOBI C THE LOCATION IN ARRAY IWORK OF C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C INTEGER JPVT C THE STARTING LOCATION IN ARRAY IWORK OF C THE PIVOT VECTOR. C INTEGER JPVTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE PIVOT VECTOR. C INTEGER LDTTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNERI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXITI C THE LOCATION IN ARRAY IWORK OF C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MSGB C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NETAI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NFEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NITERI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NJEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NNZW C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NNZWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C INTEGER NPPI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C INTEGER NROWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTOLI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C TO BE SET BY SJCK. C REAL OLMAVG C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OLMAVI C THE LOCATION IN ARRAY WORK OF C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OMEGA C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C INTEGER OMEGAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C INTEGER PARTLI C THE LOCATION IN ARRAY WORK OF C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C REAL PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL PNORM C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C INTEGER PNORMI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C REAL PRERS C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER PRERSI C THE LOCATION IN ARRAY WORK OF C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER QRAUX C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C INTEGER QRAUXI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C REAL RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C INTEGER RCONDI C THE LOCATION IN ARRAY WORK OF C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C REAL RNORMS C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C INTEGER RNORSI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C REAL RVAR C THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. C INTEGER RVARI C THE LOCATION IN ARRAY WORK OF C THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. C REAL SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS C INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG- C CALL (SHORT=.FALSE.). C INTEGER SI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED BETA'S. C INTEGER SSFI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE BETA'S. C INTEGER SSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE ESTIMATED BETA'S. C INTEGER SSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C REAL SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SSTOLI C THE LOCATION IN ARRAY WORK OF C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C REAL TAU C THE TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER TAUFCI C THE LOCATION IN ARRAY WORK OF C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C INTEGER TAUI C THE LOCATION IN ARRAY WORK OF C THE TRUST REGION DIAMETER. C INTEGER TFJACB C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER TFJACI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER TI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED DELTA'S. C INTEGER TTI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE DELTA'S. C INTEGER U C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR TFJACB. C INTEGER UI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR TFJACB. C REAL WORK(LWORK) C THE REAL WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER WRK1 C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WRK1I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WRK2 C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WRK2I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C REAL WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C INTEGER WSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C INTEGER WSSDEI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C REAL WSSDEL C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C INTEGER WSSEPI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C REAL WSSEPS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C INTEGER XPLUSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY X + DELTA. C INTEGER YT C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C INTEGER YTI C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). * * C***FIRST EXECUTABLE STATEMENT SACCES * * C FIND STARTING LOCATIONS WITHIN INTEGER WORKSPACE * CALL SIWINF(M,NP, + MSGB,MSGX,JPVTI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) * C FIND STARTING LOCATIONS WITHIN REAL WORK SPACE * CALL SWINF(N,M,NP, + DELTAI,FI, + WSSI,WSSDEI,WSSEPI,RVARI, + PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI, + FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,DELTSI, + DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,TAUI, + ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,RCONDI, + ETAI,ACTRSI,PNORMI,PRERSI,RNORSI, + LWKMN) * IF (ACCESS) THEN * C SET STARTING LOCATIONS FOR WORK VECTORS * JPVT = JPVTI WRK1 = WRK1I TFJACB = TFJACI OMEGA = OMEGAI YT = YTI U = UI QRAUX = QRAUXI WRK2 = WRK2I * C ACCESS VALUES FROM THE WORK VECTORS * ACTRS = WORK(ACTRSI) ALPHA = WORK(ALPHAI) EPSMAC = WORK(EPSMAI) OLMAVG = WORK(OLMAVI) PARTOL = WORK(PARTLI) PNORM = WORK(PNORMI) PRERS = WORK(PRERSI) RCOND = WORK(RCONDI) WSS = WORK(WSSI) WSSDEL = WORK(WSSDEI) WSSEPS = WORK(WSSEPI) RVAR = WORK(RVARI) RNORMS = WORK(RNORSI) SSTOL = WORK(SSTOLI) TAU = WORK(TAUI) TAUFAC = WORK(TAUFCI) * NETA = IWORK(NETAI) IRANK = IWORK(IRANKI) JOB = IWORK(JOBI) LUNRPT = IWORK(LUNRPI) MAXIT = IWORK(MAXITI) NFEV = IWORK(NFEVI) NITER = IWORK(NITERI) NJEV = IWORK(NJEVI) NNZW = IWORK(NNZWI) NPP = IWORK(NPPI) IDF = IWORK(IDFI) INT2 = IWORK(INT2I) * C SET UP PRINT CONTROL VARIABLES * IPRINT = IWORK(IPRINI) * IPR1 = MOD(IPRINT,10000)/1000 IPR2 = MOD(IPRINT,1000)/100 IPR2F = MOD(IPRINT,100)/10 IPR3 = MOD(IPRINT,10) * ELSE * C STORE VALUES INTO THE WORK VECTORS * WORK(ACTRSI) = ACTRS WORK(ALPHAI) = ALPHA WORK(OLMAVI) = OLMAVG WORK(PARTLI) = PARTOL WORK(PNORMI) = PNORM WORK(PRERSI) = PRERS WORK(RCONDI) = RCOND WORK(WSSI) = WSS WORK(WSSDEI) = WSSDEL WORK(WSSEPI) = WSSEPS WORK(RVARI) = RVAR WORK(RNORSI) = RNORMS WORK(SSTOLI) = SSTOL WORK(TAUI) = TAU * IWORK(IRANKI) = IRANK IWORK(NFEVI) = NFEV IWORK(NITERI) = NITER IWORK(NJEVI) = NJEV IWORK(IDFI) = IDF IWORK(INT2I) = INT2 END IF * RETURN END *SDIAGI SUBROUTINE SDIAGI + (N,M,S,LDS,V,LDV,SV,LDSV) C***BEGIN PROLOGUE SDIAGI C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SCALE THE VECTOR V BY THE INVERSE OF THE DIAGONAL MATRIX S C AND RETURN THE RESULT IN VECTOR SV C***END PROLOGUE SDIAGI * C...SCALAR ARGUMENTS INTEGER + LDS,LDSV,LDV,M,N * C...ARRAY ARGUMENTS REAL + S(LDS,M),SV(LDSV,M),V(LDV,M) * C...LOCAL SCALARS REAL + ZERO INTEGER + I,J * C...INTRINSIC FUNCTIONS INTRINSIC + ABS * C...DATA STATEMENTS DATA + ZERO + /0.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDS C THE LEADING DIMENSION OF ARRAY S. C INTEGER LDSV C THE LEADING DIMENSION OF ARRAY SV. C INTEGER LDV C THE LEADING DIMENSION OF ARRAY V. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL S(LDS,M) C THE SCALING ARRAY. C REAL SV(LDSV,M) C THE INVERSE SCALED ARRAY. C REAL V(LDV,M) C THE ARRAY BEING SCALED. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SDIAGI * * IF (N.EQ.0 .OR. M.EQ.0) RETURN * IF (S(1,1).LT.ZERO) THEN DO 20 J=1,M DO 10 I = 1,N SV(I,J) = V(I,J)/ABS(S(1,1)) 10 CONTINUE 20 CONTINUE ELSE IF (LDS.EQ.1) THEN DO 40 J=1,M DO 30 I=1,N SV(I,J) = V(I,J)/S(1,J) 30 CONTINUE 40 CONTINUE ELSE DO 60 J=1,M DO 50 I=1,N SV(I,J) = V(I,J)/S(I,J) 50 CONTINUE 60 CONTINUE END IF END IF * RETURN END *SDIAGS SUBROUTINE SDIAGS + (N,M,S,LDS,V,LDV,SV,LDSV) C***BEGIN PROLOGUE SDIAGS C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SCALE THE VECTOR V BY THE DIAGONAL MATRIX S C AND RETURN THE RESULT IN VECTOR SV. C***END PROLOGUE SDIAGS * C...SCALAR ARGUMENTS INTEGER + LDS,LDSV,LDV,M,N * C...ARRAY ARGUMENTS REAL + S(LDS,M),SV(LDSV,M),V(LDV,M) * C...LOCAL SCALARS REAL + ZERO INTEGER + I,J * C...INTRINSIC FUNCTIONS INTRINSIC + ABS * C...DATA STATEMENTS DATA + ZERO + /0.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDS C THE LEADING DIMENSION OF ARRAY S. C INTEGER LDSV C THE LEADING DIMENSION OF ARRAY SV. C INTEGER LDV C THE LEADING DIMENSION OF ARRAY V. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL S(LDS,M) C THE SCALING ARRAY. C REAL SV(LDSV,M) C THE SCALED ARRAY. C REAL V(LDV,M) C THE ARRAY BEING SCALED. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SDIAGS * * IF (N.EQ.0 .OR. M.EQ.0) RETURN * IF (S(1,1).LT.ZERO) THEN DO 20 J=1,M DO 10 I=1,N SV(I,J) = ABS(S(1,1))*V(I,J) 10 CONTINUE 20 CONTINUE ELSE IF (LDS.EQ.1) THEN DO 40 J=1,M DO 30 I=1,N SV(I,J) = S(1,J)*V(I,J) 30 CONTINUE 40 CONTINUE ELSE DO 60 J=1,M DO 50 I=1,N SV(I,J) = S(I,J)*V(I,J) 50 CONTINUE 60 CONTINUE END IF END IF * RETURN END *SDIAGW SUBROUTINE SDIAGW + (N,M,W,V,LDV,WV,LDWV) C***BEGIN PROLOGUE SDIAGW C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SCALE THE N BY M ARRAY V BY THE DIAGONAL OBSERVATIONAL C ERROR WEIGHT MATRIX W AND RETURN THE RESULT IN VECTOR WV. C N.B. IF THE FIRST ELEMENT OF W IS NEGATIVE, THE DEFAULT C WEIGHTING OF ONE FOR ALL ELEMENTS WILL BE INVOKED, I.E., C THE RESULTS WILL BE "UNWEIGHTED." C***END PROLOGUE SDIAGW * C...SCALAR ARGUMENTS INTEGER + LDV,LDWV,M,N * C...ARRAY ARGUMENTS REAL + V(LDV,M),W(N),WV(LDWV,M) * C...LOCAL SCALARS REAL + ZERO INTEGER + I,J * C...DATA STATEMENTS DATA + ZERO + /0.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDV C THE LEADING DIMENSION OF ARRAY V. C INTEGER LDWV C THE LEADING DIMENSION OF ARRAY WV. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL V(LDV,M) C THE ARRAY BEING WEIGHTED. C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C REAL WV(LDWV,M) C THE WEIGHTED ARRAY. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SDIAGW * * IF (N.EQ.0 .OR. M.EQ.0) RETURN * IF (W(1).LT.ZERO) THEN DO 20 J=1,M DO 10 I=1,N WV(I,J) = V(I,J) 10 CONTINUE 20 CONTINUE ELSE DO 40 J=1,M DO 30 I=1,N WV(I,J) = W(I)*V(I,J) 30 CONTINUE 40 CONTINUE END IF * RETURN END *SETAF SUBROUTINE SETAF + (FUN,NFEV,N,NP,M,XPLUSD,LDXPD,BETA,ETA,NETA,EPSMAC, + NROW,PARTMP,PVTEMP,ISTOP) C***BEGIN PROLOGUE SETAF C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE NOISE AND NUMBER OF GOOD DIGITS IN FUNCTION RESULTS C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE ETAFUN) C***END PROLOGUE SETAF * C...SCALAR ARGUMENTS REAL + EPSMAC,ETA INTEGER + ISTOP,LDXPD,M,N,NETA,NFEV,NP,NROW * C...ARRAY ARGUMENTS REAL + BETA(NP),PARTMP(NP),PVTEMP(N),XPLUSD(LDXPD,M) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS REAL + A,B,FAC,J,ONE,P1,P2,RSSSM,RSSSMJ,SQRTMP,ZERO INTEGER + I,K * C...LOCAL ARRAYS REAL + RSS(5) * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,INT,LOG10,MAX,SQRT * C...DATA STATEMENTS DATA + ZERO,P1,P2,ONE + /0.0E0,0.1E0,0.2E0,1.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL A C PARAMETERS OF THE FIT. C REAL B C PARAMETERS OF THE FIT. C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL EPSMAC C THE VALUE OF MACHINE PRECISION. C REAL ETA C THE NOISE IN THE MODEL RESULTS. C REAL FAC C A FACTOR USED IN THE COMPUTATIONS. C INTEGER I C AN INDEXING VARIABLE. C INTEGER ISTOP C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE C USER WISHES THE COMPUTATIONS STOPPED. C REAL J C THE VALUE FLOAT(I-3). C INTEGER K C AN INDEX VARIABLE. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE MODEL RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL ONE C THE VALUE 1.0E0. C REAL P1 C THE VALUE 0.1E0. C REAL P2 C THE VALUE 0.2E0. C REAL PARTMP(NP) C MODIFIED MODEL PARAMETERS C REAL PVTEMP(N) C PREDICTED VALUES C REAL RSS(5) C THE RESIDUAL SUM OF SQUARES FOR EACH VALUE OF J. C REAL RSSSM C THE SUM OF THE RESIDUAL SUM OF SQUARES FOR EACH SET OF C PARAMETER VALUES. C REAL RSSSMJ C THE SUM OF THE RESIDUAL SUM OF SQUARES TIMES J FOR EACH C SET OF PARAMETER VALUES. C REAL SQRTMP C THE SQUARE ROOT OF MACHINE PRECISION (EPSMAC). C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SETAF * * SQRTMP = SQRT(EPSMAC) RSSSM = ZERO RSSSMJ = ZERO DO 20 I=1,5 J = I-3 DO 10 K=1,NP PARTMP(K) = BETA(K)*(ONE+J*SQRTMP) 10 CONTINUE ISTOP = 0 CALL FUN(N,NP,M,PARTMP,XPLUSD,LDXPD,PVTEMP,ISTOP) NFEV = NFEV + 1 IF (ISTOP.NE.0) THEN RETURN END IF * RSS(I) = PVTEMP(NROW) * RSSSM = RSSSM + RSS(I) RSSSMJ = RSSSMJ + J*RSS(I) 20 CONTINUE A = P2*RSSSM B = P1*RSSSMJ IF (RSS(3).NE.ZERO) THEN FAC = ONE/ABS(RSS(3)) ELSE FAC = ONE END IF DO 30 I=1,5 J = I-3 RSS(I) = ABS((RSS(I)-(A+J*B))*FAC) 30 CONTINUE ETA = MAX(RSS(1),RSS(2),RSS(3),RSS(4),RSS(5),EPSMAC) NETA = INT(-LOG10(ETA)) * RETURN END *SEVFUN SUBROUTINE SEVFUN + (N,NP,M,BETAC,BETA,IFIXB,FUN, + X,LDX,Y,DELTA,LDDELT,XPLUSD,LDXPD, + W,F,NFEV,ISTOP) C***BEGIN PROLOGUE SEVFUN C***REFER TO SODR,SODRC C***ROUTINES CALLED SAXPY,SDIAGW,SUNPAC,SXPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE THE WEIGHTED EPSILON'S FOR THE CURRENT POINT C***END PROLOGUE SEVFUN * C...SCALAR ARGUMENTS INTEGER + ISTOP,LDDELT,LDX,LDXPD,M,N,NFEV,NP * C...ARRAY ARGUMENTS REAL + BETA(NP),BETAC(NP),DELTA(LDDELT,M),F(N),W(N), + X(LDX,M),XPLUSD(LDXPD,M),Y(N) INTEGER + IFIXB(NP) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS REAL + NEGONE * C...EXTERNAL SUBROUTINES EXTERNAL + SAXPY,SDIAGW,SUNPAC,SXPY * C...DATA STATEMENTS DATA + NEGONE + /-1.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL BETAC(NP) C THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. C REAL DELTA(LDDELT,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C REAL F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER ISTOP C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE C USER WISHES THE COMPUTATIONS STOPPED. C INTEGER LDDELT C THE LEADING DIMENSION OF ARRAY DELTA. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL NEGONE C THE VALUE -1.0E0. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C REAL Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) * * C***FIRST EXECUTABLE STATEMENT SEVFUN * * C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA * CALL SUNPAC(NP,BETAC,BETA,IFIXB) * C COMPUTE XPLUSD = X + DELTA * CALL SXPY(N,M,X,LDX,DELTA,LDDELT,XPLUSD,LDXPD) * C EVALUATE THE PREDICTED VALUES OF THE FUNCTION FOR THE CURRENT POINT * ISTOP = 1 CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,F,ISTOP) IF (ISTOP.LT.0) THEN RETURN END IF * C INCREMENT COUNT OF NUMBER OF FUNCTION EVALUATIONS * NFEV = NFEV + 1 * C COMPUTE WEIGHTED EPSILONS FOR CURRENT POINT AND STORE IN F * CALL SAXPY(N,NEGONE,Y,1,F,1) CALL SDIAGW(N,1,W,F,N,F,N) * RETURN END *SEVJAC SUBROUTINE SEVJAC + (FUN,JAC,ANAJAC, + N,NP,NPP,M,BETAC,BETA,IFIXB,IFIXX,LDIFX, + X,LDX,DELTA,LDDELT,XPLUSD,LDXPD, + SS,TT,LDTT,NETA,PV,STP, + FJACB,LDFJB,ISODR,FJACX,LDFJX,W,NJEV,NFEV,ISTOP) C***BEGIN PROLOGUE SEVJAC C***REFER TO SODR,SODRC C***ROUTINES CALLED SDIAGW,SJACFD,SUNPAC,SXPY,SZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE THE WEIGHTED JACOBIANS WRT BETA AND DELTA C***END PROLOGUE SEVJAC * C...SCALAR ARGUMENTS INTEGER + ISTOP,LDDELT,LDFJB,LDFJX,LDIFX,LDTT,LDX,LDXPD,M,N,NETA,NFEV, + NJEV,NP,NPP LOGICAL + ANAJAC,ISODR * C...ARRAY ARGUMENTS REAL + BETA(NP),BETAC(NP),DELTA(LDDELT,M), + FJACB(LDFJB,NP),FJACX(LDFJX,M),PV(N),SS(NP), + STP(N),TT(LDTT,M),W(N),X(LDX,M),XPLUSD(LDXPD,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS REAL + ZERO INTEGER + I,J,JFX * C...EXTERNAL SUBROUTINES EXTERNAL + SDIAGW,SJACFD,SUNPAC,SXPY,SZERO * C...DATA STATEMENTS DATA + ZERO + /0.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE FUNCTION. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL BETAC(NP) C THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. C REAL DELTA(LDDELT,M) C THE ESTIMATED VALUES OF DELTA. C REAL FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C REAL FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO X. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER ISTOP C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE C USER WISHES THE COMPUTATIONS STOPPED. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER J C AN INDEXING VARIABLE. C INTEGER JFX C AN INDEXING VARIABLE. C INTEGER LDDELT C THE LEADING DIMENSION OF ARRAY DELTA. C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C REAL PV(N) C THE PREDICTED VALUES OF THE FUNCTION AT THE CURRENT C POINT. C REAL SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL STP(N) C THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES. C REAL TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SEVJAC * * C INSERT CURRENT UNFIXED BETA ESTIMATES INTO BETA * CALL SUNPAC(NP,BETAC,BETA,IFIXB) * C COMPUTE XPLUSD = X + DELTA * CALL SXPY(N,M,X,LDX,DELTA,LDDELT,XPLUSD,LDXPD) * C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS (FJACB) AND C THE JACOBIAN WRT DELTA (FJACX) * ISTOP = 1 IF (ANAJAC) THEN CALL JAC(N,NP,M,BETA,XPLUSD,LDXPD, + FJACB,LDFJB,ISODR,FJACX,LDFJX,ISTOP) NJEV = NJEV+1 ELSE CALL SJACFD(N,NP,M,BETA, + X,LDX,DELTA,XPLUSD,LDXPD,FUN, + SS,TT,LDTT,NETA,PV,STP, + IFIXB,FJACB,LDFJB,ISODR, + IFIXX,LDIFX,FJACX,LDFJX,NFEV,ISTOP) END IF IF (ISTOP.LT.0) THEN RETURN END IF * C WEIGHT THE JACOBIAN WRT THE ESTIMATED BETAS * IF (ANAJAC) THEN JFX = 0 IF (IFIXB(1).GE.0) THEN DO 10 J=1,NP IF (IFIXB(J).NE.0) THEN JFX = JFX + 1 CALL SDIAGW(N,1,W,FJACB(1,J),LDFJB, + FJACB(1,JFX),LDFJB) END IF 10 CONTINUE ELSE DO 20 J=1,NP CALL SDIAGW(N,1,W,FJACB(1,J),LDFJB, + FJACB(1,J),LDFJB) 20 CONTINUE END IF ELSE DO 30 J=1,NPP CALL SDIAGW(N,1,W,FJACB(1,J),LDFJB, + FJACB(1,J),LDFJB) 30 CONTINUE END IF * C WEIGHT OR ZERO THE JACOBIAN'S WRT X AS APPROPRIATE * IF (ISODR) THEN IF (IFIXX(1,1).GE.0) THEN * C CHECK FOR POSSIBLY FIXED COLUMNS OR ELEMENTS OF X * IF (LDIFX.EQ.1) THEN DO 40 J=1,M IF (IFIXX(1,J).EQ.0) THEN * C ZERO JACOBIAN WRT X(I,J) FOR I=1,N * CALL SZERO(N,1,FJACX(1,J),LDFJX) ELSE * C WEIGHT JACOBIAN WRT X(I,J) FOR I=1,N * CALL SDIAGW(N,1,W,FJACX(1,J),LDFJX, + FJACX(1,J),LDFJX) END IF 40 CONTINUE ELSE * C WEIGHT JACOBIAN WRT X(I,J) FOR I=1,N AND C THEN ZERO APPROPRIATE ELEMENTS * DO 60 J=1,M CALL SDIAGW(N,1,W,FJACX(1,J),LDFJX, + FJACX(1,J),LDFJX) DO 50 I=1,N IF (IFIXX(I,J).EQ.0) THEN FJACX(I,J) = ZERO END IF 50 CONTINUE 60 CONTINUE END IF ELSE * C WEIGHT JACOBIAN WRT X(I,J) FOR I=1,N AND J=1,M * DO 70 J=1,M CALL SDIAGW(N,1,W,FJACX(1,J),LDFJX, + FJACX(1,J),LDFJX) 70 CONTINUE END IF ELSE * C ZERO ALL ELEMENTS OF FJACX FOR OLS FIT * CALL SZERO(N,M,FJACX,LDFJX) END IF * RETURN END *SFLAGS SUBROUTINE SFLAGS + (JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR,DOVCV) C***BEGIN PROLOGUE SFLAGS C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SET FLAGS INDICATING CONDITIONS SPECIFIED BY JOB C***END PROLOGUE SFLAGS * C...SCALAR ARGUMENTS INTEGER + JOB LOGICAL + ANAJAC,CHKJAC,DOVCV,INITD,ISODR,RESTRT * C...LOCAL SCALARS INTEGER + J * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER J C THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF JOB. C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). * * C***FIRST EXECUTABLE STATEMENT SFLAGS * * IF (JOB.GE.0) THEN RESTRT= JOB.GE.10000 INITD = MOD(JOB,10000)/1000.EQ.0 DOVCV = MOD(JOB,1000)/100.EQ.0 J = MOD(JOB,100)/10 IF (J.EQ.0) THEN ANAJAC = .FALSE. CHKJAC = .FALSE. ELSE IF (J.EQ.1) THEN ANAJAC = .TRUE. CHKJAC = .TRUE. ELSE ANAJAC = .TRUE. CHKJAC = .FALSE. END IF ISODR = MOD(JOB,10).EQ.0 ELSE RESTRT = .FALSE. INITD = .TRUE. DOVCV = .TRUE. ANAJAC = .FALSE. CHKJAC = .FALSE. ISODR = .TRUE. END IF * RETURN END *SIDTS SUBROUTINE SIDTS + (N,M,W,WD,LDWD,ALPHA,TT,LDTT,T,LDT,DTT,LDDTT) C***BEGIN PROLOGUE SIDTS C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SCALE MATRIX TT BY THE INVERSE OF DT, I.E., COMPUTE C DTT = T * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2, C W AND D ARE DEFINED BY EQ.2 OF THE PROLOGUE OF SODR C AND SODRC, AND TT IS THE SCALING MATRIX FOR THE DELTA'S, C ALSO DEFINED IN THE PROLOGUE OF SODR AND SODRC. C***END PROLOGUE SIDTS * C...SCALAR ARGUMENTS REAL + ALPHA INTEGER + LDDTT,LDT,LDTT,LDWD,M,N * C...ARRAY ARGUMENTS REAL + DTT(LDDTT,M),T(LDT,M),TT(LDTT,M),W(N),WD(LDWD,M) * C...LOCAL SCALARS REAL + DT,ONE,TERM1,TERM2,ZERO INTEGER + I,J * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0E0,1.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C N.B. THE LOCATIONS OF W, WD AND TT ACCESSED DEPEND ON THE VALUE C OF THE FIRST ELEMENT OF EACH ARRAY AND THE LEADING DIMENSION C OF THE DOUBLY SUBSCRIPTED ARRAYS. C REAL ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C REAL DT C THE VALUE OF THE FACTOR DT = INV((W*D)**2+ALPHA*TT**2) C REAL DTT(LDDTT,M) C THE ARRAY DTT = T * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2. C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDDTT C THE LEADING DIMENSION OF ARRAY DTT. C INTEGER LDT C THE LEADING DIMENSION OF ARRAY T. C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ONE C THE VALUE 1.0E0. C REAL T(LDT,M) C THE STEP FOR THE ESTIMATED DELTA'S. C REAL TERM1 C THE VALUE OF THE TERM (W(I)*WD(I,J))**2 C REAL TERM2 C THE VALUE OF THE TERM ALPHA*TT(I,J)**2 C REAL TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SIDTS * * IF (N.EQ.0 .OR. M.EQ.0) RETURN * IF (W(1).GE.ZERO) THEN IF (WD(1,1).GT.ZERO) THEN IF (LDWD.GE.N) THEN IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 1120 J=1,M DO 1110 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/ + ((W(I)*WD(I,J))**2 + + ALPHA*TT(I,J)**2) ELSE DTT(I,J) = ZERO END IF 1110 CONTINUE 1120 CONTINUE ELSE DO 1140 J=1,M TERM2 = ALPHA*TT(1,J)**2 DO 1130 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/ + ((W(I)*WD(I,J))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1130 CONTINUE 1140 CONTINUE END IF ELSE TERM2 = ALPHA*TT(1,1)**2 DO 1160 J=1,M DO 1150 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/((W(I)*WD(I,J))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1150 CONTINUE 1160 CONTINUE END IF ELSE IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 1220 J=1,M DO 1210 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/ + ((W(I)*WD(1,J))**2 + + ALPHA*TT(I,J)**2) ELSE DTT(I,J) = ZERO END IF 1210 CONTINUE 1220 CONTINUE ELSE DO 1240 J=1,M TERM2 = ALPHA*TT(1,J)**2 DO 1230 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/ + ((W(I)*WD(1,J))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1230 CONTINUE 1240 CONTINUE END IF ELSE TERM2 = ALPHA*TT(1,1)**2 DO 1260 J=1,M DO 1250 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/((W(I)*WD(1,J))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1250 CONTINUE 1260 CONTINUE END IF END IF ELSE IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 1320 J=1,M DO 1310 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/ + ((W(I)*WD(1,1))**2 + + ALPHA*TT(I,J)**2) ELSE DTT(I,J) = ZERO END IF 1310 CONTINUE 1320 CONTINUE ELSE DO 1340 J=1,M TERM2 = ALPHA*TT(1,J)**2 DO 1330 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/((W(I)*WD(1,1))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1330 CONTINUE 1340 CONTINUE END IF ELSE TERM2 = ALPHA*TT(1,1)**2 DO 1360 J=1,M DO 1350 I=1,N IF (W(I).NE.ZERO .OR. ALPHA.NE.ZERO) THEN DTT(I,J) = T(I,J)/((W(I)*WD(1,1))**2+TERM2) ELSE DTT(I,J) = ZERO END IF 1350 CONTINUE 1360 CONTINUE END IF END IF ELSE IF (WD(1,1).GT.ZERO) THEN IF (LDWD.GE.N) THEN IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 2120 J=1,M DO 2110 I=1,N DTT(I,J) = T(I,J)/ + (WD(I,J)**2 + ALPHA*TT(I,J)**2) 2110 CONTINUE 2120 CONTINUE ELSE DO 2140 J=1,M TERM2 = ALPHA*TT(1,J)**2 DO 2130 I=1,N DTT(I,J) = T(I,J)/(WD(I,J)**2+TERM2) 2130 CONTINUE 2140 CONTINUE END IF ELSE TERM2 = ALPHA*TT(1,1)**2 DO 2160 J=1,M DO 2150 I=1,N DTT(I,J) = T(I,J)/(WD(I,J)**2+TERM2) 2150 CONTINUE 2160 CONTINUE END IF ELSE IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN DO 2220 J=1,M TERM1 = WD(1,J)**2 DO 2210 I=1,N DTT(I,J) = T(I,J)/(TERM1+ALPHA*TT(I,J)**2) 2210 CONTINUE 2220 CONTINUE ELSE DO 2240 J=1,M DT = ONE/(WD(1,J)**2+ALPHA*TT(1,J)**2) DO 2230 I=1,N DTT(I,J) = T(I,J)*DT 2230 CONTINUE 2240 CONTINUE END IF ELSE TERM2 = ALPHA*TT(1,1)**2 DO 2260 J=1,M TERM1 = WD(1,J)**2 DT = ONE/(TERM1+TERM2) DO 2250 I=1,N DTT(I,J) = T(I,J)*DT 2250 CONTINUE 2260 CONTINUE END IF END IF ELSE IF (TT(1,1).GT.ZERO) THEN IF (LDTT.GE.N) THEN TERM1 = WD(1,1)**2 DO 2320 J=1,M DO 2310 I=1,N DTT(I,J) = T(I,J)/(TERM1 + ALPHA*TT(I,J)**2) 2310 CONTINUE 2320 CONTINUE ELSE TERM1 = WD(1,1)**2 DO 2340 J=1,M TERM2 = ALPHA*TT(1,J)**2 DT = ONE/(TERM1+TERM2) DO 2330 I=1,N DTT(I,J) = T(I,J)*DT 2330 CONTINUE 2340 CONTINUE END IF ELSE DT = ONE/(WD(1,1)**2+ALPHA*TT(1,1)**2) DO 2360 J=1,M DO 2350 I=1,N DTT(I,J) = T(I,J)*DT 2350 CONTINUE 2360 CONTINUE END IF END IF END IF * RETURN END *SINIWK SUBROUTINE SINIWK + (N,M,NP,WORK,LWORK,IWORK,LIWORK, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + BETA,SCLB, + SSTOL,PARTOL,MAXIT,TAUFAC, + JOB,IPRINT,LUNERR,LUNRPT, + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + JOBI,IPRINI,LUNERI,LUNRPI, + SSFI,TTI,LDTTI,DELTAI) C***BEGIN PROLOGUE SINIWK C***REFER TO SODR,SODRC C***ROUTINES CALLED SFLAGS,SMPREC,SSCLB,SSCLD,SZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE INITIALIZE WORK VECTORS AS NECESSARY C***END PROLOGUE SINIWK * C...SCALAR ARGUMENTS REAL + PARTOL,SSTOL,TAUFAC INTEGER + DELTAI,EPSMAI,IPRINI,IPRINT,JOB,JOBI,LDIFX, + LDSCLD,LDTTI,LDX,LIWORK,LUNERI,LUNERR,LUNRPI,LUNRPT,LWORK,M, + MAXIT,MAXITI,N,NP,PARTLI,SSFI,SSTOLI,TAUFCI,TTI * C...ARRAY ARGUMENTS REAL + BETA(NP),SCLB(NP),SCLD(LDSCLD,M),WORK(LWORK),X(LDX,M) INTEGER + IFIXX(LDIFX,M),IWORK(LIWORK) * C...LOCAL SCALARS REAL + ONE,THREE,TWO,ZERO INTEGER + I,J LOGICAL + ANAJAC,CHKJAC,DOVCV,INITD,ISODR,RESTRT * C...EXTERNAL FUNCTIONS REAL + SMPREC EXTERNAL + SMPREC * C...EXTERNAL SUBROUTINES EXTERNAL + SCOPY,SFLAGS,SSCLB,SSCLD,SZERO * C...INTRINSIC FUNCTIONS INTRINSIC + SQRT * C...DATA STATEMENTS DATA + ZERO,ONE,TWO,THREE + /0.0E0,1.0E0,2.0E0,3.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C INTEGER DELTAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C INTEGER EPSMAI C THE STARTING LOCATION IN ARRAY WORK OF C THE VALUE OF MACHINE PRECISION. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C INTEGER IPRINI C THE LOCATION IN ARRAY IWORK OF C THE PRINT CONTROL VARIABLE. C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER J C AN INDEXING VARIABLE. C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOBI C THE STARTING LOCATION IN ARRAY IWORK OF C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTTI C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNERI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXITI C THE LOCATION IN ARRAY IWORK OF C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ONE C THE VALUE 1.0E0. C INTEGER PARTLI C THE LOCATION IN ARRAY WORK OF C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C REAL PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C REAL SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SSFI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE BETA'S. C REAL SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SSTOLI C THE LOCATION IN ARRAY WORK OF C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C REAL TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER TAUFCI C THE LOCATION IN ARRAY WORK OF C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C REAL THREE C THE VALUE 3.0E0. C INTEGER TTI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE DELTA'S. C REAL TWO C THE VALUE 2.0E0. C REAL WORK(LWORK) C THE REAL WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SINIWK * * CALL SFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR,DOVCV) * C STORE VALUE OF MACHINE PRECISION IN WORK VECTOR * WORK(EPSMAI) = SMPREC() * C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE C PARAMETERS * IF (PARTOL.LT.WORK(EPSMAI) .OR. PARTOL.GE.ONE) THEN WORK(PARTLI) = WORK(EPSMAI)**(TWO/THREE) ELSE WORK(PARTLI) = PARTOL END IF * C SET TOLERANCE FOR STOPPING CRITERIA BASED ON THE CHANGE IN THE C SUM OF SQUARES OF THE WEIGHTED OBSERVATIONAL ERRORS * IF (SSTOL.LT.WORK(EPSMAI) .OR. SSTOL.GE.ONE) THEN WORK(SSTOLI) = SQRT(WORK(EPSMAI)) ELSE WORK(SSTOLI) = SSTOL END IF * C SET FACTOR FOR COMPUTING TRUST REGION DIAMETER AT FIRST ITERATION * IF (TAUFAC.LE.ZERO) THEN WORK(TAUFCI) = ONE ELSE WORK(TAUFCI) = TAUFAC END IF * C SET MAXIMUM NUMBER OF ITERATIONS * IF (MAXIT.LE.0) THEN IWORK(MAXITI) = 50 ELSE IWORK(MAXITI) = MAXIT END IF * C STORE PROBLEM INITIALIZATION AND COMPUTATIONAL METHOD CONTROL C VARIABLE * IF (JOB.LE.0) THEN IWORK(JOBI) = 0 ELSE IWORK(JOBI) = JOB END IF * C SET PRINT CONTROL * IF (IPRINT.LT.0) THEN IWORK(IPRINI) = 2001 ELSE IWORK(IPRINI) = IPRINT END IF * C SET LOGICAL UNIT NUMBER FOR ERROR MESSAGES * IF (LUNERR.LT.0) THEN IWORK(LUNERI) = 6 ELSE IWORK(LUNERI) = LUNERR END IF * C SET LOGICAL UNIT NUMBER FOR COMPUTATION REPORTS * IF (LUNRPT.LT.0) THEN IWORK(LUNRPI) = 6 ELSE IWORK(LUNRPI) = LUNRPT END IF * C COMPUTE SCALING FOR BETA'S AND DELTA'S * IF (SCLB(1).LE.ZERO) THEN CALL SSCLB(NP,BETA,WORK(SSFI)) ELSE CALL SCOPY(NP,SCLB,1,WORK(SSFI),1) END IF IF (SCLD(1,1).LE.ZERO) THEN IWORK(LDTTI) = N CALL SSCLD(N,M,X,LDX,WORK(TTI),IWORK(LDTTI)) ELSE IF (LDSCLD.EQ.1) THEN IWORK(LDTTI) = 1 CALL SCOPY(N,SCLD(1,1),1,WORK(TTI),1) ELSE IWORK(LDTTI) = N DO 10 J=1,M CALL SCOPY(N,SCLD(1,J),1,WORK(TTI+(J-1)*IWORK(LDTTI)),1) 10 CONTINUE END IF END IF * C INITIALIZE DELTA'S AS NECESSARY * IF (ISODR) THEN IF (INITD) THEN CALL SZERO(N,M,WORK(DELTAI),N) ELSE IF (IFIXX(1,1).GE.0) THEN IF (LDIFX.EQ.1) THEN DO 20 J=1,M IF (IFIXX(1,J).EQ.0) THEN CALL SZERO(N,1,WORK(DELTAI+(J-1)*N),N) END IF 20 CONTINUE ELSE DO 40 J=1,M DO 30 I=1,N IF (IFIXX(I,J).EQ.0) THEN WORK(DELTAI-1+I+(J-1)*N) = ZERO END IF 30 CONTINUE 40 CONTINUE END IF END IF END IF ELSE CALL SZERO(N,M,WORK(DELTAI),N) END IF * RETURN END *SIWINF SUBROUTINE SIWINF + (M,NP, + MSGB,MSGX,JPVTI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) C***BEGIN PROLOGUE SIWINF C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SET STORAGE LOCATIONS WITHIN INTEGER WORK SPACE C***END PROLOGUE SIWINF * C...SCALAR ARGUMENTS INTEGER + IDFI,INT2I,IPRINI,IRANKI,JOBI,JPVTI,LDTTI,LIWKMN,LUNERI, + LUNRPI,M,MAXITI,MSGB,MSGX,NETAI,NFEVI,NITERI,NJEVI,NNZWI,NP, + NPPI,NROWI,NTOLI * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER IDFI C THE STARTING LOCATION IN ARRAY IWORK OF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER INT2I C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF INTERNAL DOUBLING STEPS. C INTEGER IPRINI C THE LOCATION IN ARRAY IWORK OF C THE PRINT CONTROL VARIABLE. C INTEGER IRANKI C THE LOCATION IN ARRAY IWORK OF C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C INTEGER JOBI C THE LOCATION IN ARRAY IWORK OF C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C INTEGER JPVTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE PIVOT VECTOR. C INTEGER LDTTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LUNERI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C INTEGER LUNRPI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXITI C THE LOCATION IN ARRAY IWORK OF C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MSGB C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER NETAI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITERI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NJEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NNZWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPPI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C INTEGER NROWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTOLI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C TO BE SET BY SJCK. * * C***FIRST EXECUTABLE STATEMENT SIWINF * * IF (NP.GE.1 .AND. M.GE.1) THEN MSGB = 1 MSGX = MSGB + NP+1 JPVTI = MSGX + M+1 NNZWI = JPVTI + NP NPPI = NNZWI + 1 IDFI = NPPI + 1 JOBI = IDFI + 1 IPRINI = JOBI + 1 LUNERI = IPRINI + 1 LUNRPI = LUNERI + 1 NROWI = LUNRPI + 1 NTOLI = NROWI + 1 NETAI = NTOLI + 1 MAXITI = NETAI + 1 NITERI = MAXITI + 1 NFEVI = NITERI + 1 NJEVI = NFEVI + 1 INT2I = NJEVI + 1 IRANKI = INT2I + 1 LDTTI = IRANKI + 1 LIWKMN = LDTTI ELSE MSGB = 1 MSGX = 1 JPVTI = 1 NNZWI = 1 NPPI = 1 IDFI = 1 JOBI = 1 IPRINI = 1 LUNERI = 1 LUNRPI = 1 NROWI = 1 NTOLI = 1 NETAI = 1 MAXITI = 1 NITERI = 1 NFEVI = 1 NJEVI = 1 INT2I = 1 IRANKI = 1 LDTTI = 1 LIWKMN = 1 END IF * RETURN END *SJACFD SUBROUTINE SJACFD + (N,NP,M,BETA, + X,LDX,DELTA,XPLUSD,LDXPD,FUN, + SS,TT,LDTT,NETA,PV,STP, + IFIXB,FJACB,LDFJB,ISODR, + IFIXX,LDIFX,FJACX,LDFJX,NFEV,ISTOP) C***BEGIN PROLOGUE SJACFD C***REFER TO SODR,SODRC C***ROUTINES CALLED SZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890727 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE FINITE DIFFERENCE APPROXIMATIONS TO THE C JACOBIAN WRT THE ESTIMATED BETAS AND WRT THE DELTAS C***END PROLOGUE SJACFD * C...SCALAR ARGUMENTS INTEGER + ISTOP,LDFJB,LDFJX,LDIFX,LDTT,LDX,LDXPD,M,N,NETA,NFEV,NP LOGICAL + ISODR * C...ARRAY ARGUMENTS REAL + BETA(NP),DELTA(N,M),FJACB(LDFJB,NP), + FJACX(LDFJX,M),PV(N),SS(NP),STP(N),TT(LDTT,M), + X(LDX,M),XPLUSD(LDXPD,M) INTEGER + IFIXB(NP),IFIXX(LDIFX,M) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS REAL + BETAJ,ONE,SQREPS,TEN,TWO,TYPJ,ZERO INTEGER + I,J,JFX LOGICAL + DOIT * C...EXTERNAL SUBROUTINES EXTERNAL + SZERO * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MAX,SIGN,SQRT * C...DATA STATEMENTS DATA + ZERO,ONE,TWO,TEN + /0.0E0,1.0E0,2.0E0,10.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C REAL BETAJ C THE J-TH FUNCTION PARAMETER. C REAL DELTA(N,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DOIT C THE INDICATOR VARIABLE USED TO SPECIFY WHETHER THE DERIVATIVE C WRT A GIVEN BETA OR X NEEDS TO BE COMPUTED (DOIT=TRUE) OR NOT C (DOIT=FALSE). C REAL FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C REAL FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO X. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER ISTOP C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE THAT THE C USER WISHES THE COMPUTATIONS STOPPED. C INTEGER J C AN INDEXING VARIABLE. C INTEGER JFX C AN INDEXING VARIABLE. C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF GOOD DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ONE C THE VALUE 1.0E0. C REAL PV(N) C THE PREDICTED VALUES OF THE MODEL FUNCTION AT THE CURRENT C POINT. C REAL SQREPS C THE SQUARE ROOT OF MACHINE PRECISION. C REAL SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL STP(N) C THE STEP USED TO COMPUTE FINITE DIFFERENCE DERIVATIVES. C REAL TEN C THE VALUE 10.0E0. C REAL TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TWO C THE VALUE 2.0E0. C REAL TYPJ C THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SJACFD * * C SET THE RELATIVE STEP SIZE FOR COMPUTING THE JACOBIANS * SQREPS = TEN**(-NETA/TWO) * C COMPUTE THE PREDICTED VALUES OF THE FUNCTION AT THE GIVEN POINT * CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PV,ISTOP) NFEV = NFEV + 1 IF (ISTOP.LT.0) THEN RETURN END IF * C COMPUTE THE JACOBIAN WRT THE ESTIMATED BETAS * JFX = 0 DO 20 J=1,NP IF (IFIXB(1).GE.0) THEN IF (IFIXB(J).EQ.0) THEN DOIT = .FALSE. ELSE DOIT = .TRUE. END IF ELSE DOIT = .TRUE. END IF IF (DOIT) THEN JFX = JFX + 1 BETAJ = BETA(J) TYPJ = ONE/SS(JFX) STP(J) = BETAJ + SQREPS*SIGN(ONE,BETAJ)*MAX(ABS(BETAJ),TYPJ) STP(J) = STP(J) - BETAJ BETA(J) = BETAJ + STP(J) CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,FJACB(1,JFX),ISTOP) NFEV = NFEV + 1 IF (ISTOP.LT.0) THEN RETURN END IF DO 10 I=1,N FJACB(I,JFX) = (FJACB(I,JFX)-PV(I))/STP(J) 10 CONTINUE BETA(J) = BETAJ END IF 20 CONTINUE * C COMPUTE THE JACOBIAN WRT THE X'S * IF (ISODR) THEN DO 70 J=1,M IF (IFIXX(1,1).LT.0) THEN DOIT = .TRUE. ELSE IF (LDIFX.EQ.1) THEN IF (IFIXX(1,J).EQ.0) THEN DOIT = .FALSE. ELSE DOIT = .TRUE. END IF ELSE DO 30 I=1,N IF (IFIXX(I,J).NE.0) THEN DOIT = .TRUE. GO TO 40 END IF 30 CONTINUE DOIT = .FALSE. 40 CONTINUE END IF IF (.NOT.DOIT) THEN CALL SZERO(N,1,FJACX(1,J),N) ELSE DO 50 I=1,N IF (TT(1,1).GT.ZERO) THEN IF (LDTT.EQ.1) THEN TYPJ = ONE/TT(1,J) ELSE TYPJ = ONE/TT(I,J) END IF ELSE TYPJ = ABS(ONE/TT(1,1)) END IF STP(I) = XPLUSD(I,J) + SQREPS*SIGN(ONE,XPLUSD(I,J))* + MAX(ABS(XPLUSD(I,J)),TYPJ) STP(I) = STP(I) - XPLUSD(I,J) XPLUSD(I,J) = XPLUSD(I,J) + STP(I) 50 CONTINUE CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,FJACX(1,J),ISTOP) NFEV = NFEV + 1 IF (ISTOP.LT.0) THEN RETURN END IF DO 60 I=1,N FJACX(I,J) = (FJACX(I,J)-PV(I))/STP(I) XPLUSD(I,J) = X(I,J) + DELTA(I,J) 60 CONTINUE END IF 70 CONTINUE END IF * RETURN END *SJCK SUBROUTINE SJCK + (FUN,JAC,NFEV,NJEV, + N,NP,M,BETA,XPLUSD,LDXPD, + ETA,NETA,NTOL,SS,TT,LDTT,NROW,ISODR,EPSMAC, + PVTEMP,FJACB,LDFJB,FJACX,LDFJX, + MSGB,MSGX,ISTOPF,ISTOPJ) C***BEGIN PROLOGUE SJCK C***REFER TO SODR,SODRC C***ROUTINES CALLED SJCKM C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE DRIVER ROUTINE FOR THE DERIVATIVE CHECKING PROCESS C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKCNT) C***END PROLOGUE SJCK * C...SCALAR ARGUMENTS REAL + EPSMAC,ETA INTEGER + ISTOPF,ISTOPJ,LDFJB,LDFJX,LDTT,LDXPD,M,N,NETA,NFEV, + NJEV,NP,NROW,NTOL LOGICAL + ISODR * C...ARRAY ARGUMENTS REAL + BETA(NP),FJACB(LDFJB,NP), + FJACX(LDFJX,M),PVTEMP(N),SS(NP), + TT(LDTT,M),XPLUSD(LDXPD,M) INTEGER + MSGB(NP+1),MSGX(M+1) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS REAL + ONE,PV,TEN,TOL,TYPJ,ZERO INTEGER + J LOGICAL + ISWRTB * C...EXTERNAL SUBROUTINES EXTERNAL + SJCKM * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,INT,LOG10 * C...DATA STATEMENTS DATA + ZERO,ONE,TEN + /0.0E0,1.0E0,10.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL EPSMAC C THE VALUE OF MACHINE PRECISION. C REAL ETA C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C REAL FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C REAL FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO X. C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER ISTOPJ C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE JACOBIAN GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C LOGICAL ISWRTB C THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT C BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. C INTEGER J C AN INDEX VARIABLE. C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF RELIABLE DIGITS IN THE MODEL RESULTS, EITHER C SET BY THE USER OR COMPUTED BY SETAF. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY C AT WHICH THE DERIVATIVE IS CHECKED. C INTEGER NTOL C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C EITHER SET BY THE USER OR COMPUTED FROM NETA. C REAL ONE C THE VALUE 1.0E0. C REAL PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C REAL PVTEMP(N) C THE PREDICTED VALUE BASED ON THE CURRENT PARAMETER ESTIMATES C REAL SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TEN C THE VALUE 10.0E0. C REAL TOL C THE AGREEMENT TOLERANCE. C REAL TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TYPJ C THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SJCK * * C SET TOLERANCE FOR CHECKING DERIVATIVES * IF ((NTOL.LT.1) .OR. (NTOL.GT.(NETA+1)/2)) THEN NTOL = (NETA+3)/4 END IF * TOL = TEN**(-NTOL) * C COMPUTE PREDICTED VALUE OF MODEL USING CURRENT PARAMETER C ESTIMATES, AND COMPUTE USER-SUPPLIED DERIVATIVE VALUES * ISTOPF = 0 CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,ISTOPF) NFEV = NFEV + 1 IF (ISTOPF.NE.0) THEN RETURN END IF PV = PVTEMP(NROW) * ISTOPJ = 0 CALL JAC(N,NP,M,BETA,XPLUSD,LDXPD,FJACB,LDFJB, + ISODR,FJACX,LDFJX,ISTOPJ) NJEV = NJEV + 1 IF (ISTOPJ.NE.0) THEN RETURN END IF * C CHECK DERIVATIVES WRT BETA * ISWRTB = .TRUE. MSGB(1) = 0 * DO 10 J=1,NP * IF (SS(1).GT.ZERO) THEN TYPJ = ONE/SS(J) ELSE TYPJ = ONE/ABS(SS(1)) END IF * C CHECK DERIVATIVE WRT THE J-TH PARAMETER AT THE NROW-TH ROW * CALL SJCKM(FUN,NFEV, + N,NP,M,XPLUSD,LDXPD,BETA,TYPJ, + ETA,TOL,EPSMAC, + J,NROW,PV,FJACB(NROW,J),PVTEMP, + ISWRTB,MSGB,NP+1,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF * 10 CONTINUE * C CHECK DERIVATIVES WRT X * MSGX(1) = 0 * IF (ISODR) THEN ISWRTB = .FALSE. DO 20 J=1,M * IF (TT(1,1).GT.ZERO) THEN IF (LDTT.EQ.1) THEN TYPJ = ONE/TT(1,J) ELSE TYPJ = ONE/TT(NROW,J) END IF ELSE TYPJ = ABS(ONE/TT(1,1)) END IF * C CHECK DERIVATIVE WRT THE J-TH COLUMN OF X AT ROW NROW * CALL SJCKM(FUN,NFEV, + N,NP,M,XPLUSD,LDXPD,BETA,TYPJ, + ETA,TOL,EPSMAC, + J,NROW,PV,FJACX(NROW,J),PVTEMP, + ISWRTB,MSGX,M+1,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF * 20 CONTINUE END IF * C PRINT RESULTS IF THEY ARE DESIRED * RETURN * END *SJCKC SUBROUTINE SJCKC + (FUN,NFEV,N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL,EPSMAC, + J,NROW,PV,D,FD,PARMX,PVPSTP,STP, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) C***BEGIN PROLOGUE SJCKC C***REFER TO SODR,SODRC C***ROUTINES CALLED SJCKF,SPVB,SPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE CHECK WHETHER HIGH CURVATURE COULD BE THE CAUSE OF THE C DISAGREEMENT BETWEEN THE NUMERICAL AND ANALYTIC DERVIATIVES C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKCRV) C***END PROLOGUE SJCKC * C...SCALAR ARGUMENTS REAL + D,EPSMAC,ETA,FD,PARMX,PV,PVPSTP,STP,TOL INTEGER + ISTOPF,J,LDXPD,LMSG,M,N,NFEV,NP,NROW LOGICAL + ISWRTB * C...ARRAY ARGUMENTS REAL + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) INTEGER + MSG(LMSG) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS REAL + CURVE,FIVE,ONE,PVMCRV,PVPCRV,STPCRV,THIRD,THREE,TWO * C...EXTERNAL FUNCTIONS REAL + SPVB,SPVD EXTERNAL + SPVB,SPVD * C...EXTERNAL SUBROUTINES EXTERNAL + SJCKF * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SIGN * C...DATA STATEMENTS DATA + ONE,TWO,THREE,FIVE + /1.0E0,2.0E0,3.0E0,5.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL CURVE C A MEASURE OF THE CURVATURE IN THE MODEL. C REAL D C THE SCALAR IN WHICH ROW NROW OF THE DERIVATIVE C MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER C IS STORED. C REAL EPSMAC C THE VALUE OF MACHINE PRECISION. C REAL ETA C THE RELATIVE NOISE IN THE MODEL. C REAL FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER. C REAL FIVE C THE VALUE 5.0E0. C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C LOGICAL ISWRTB C THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT C BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSG(LMSG) C THE ERROR CHECKING RESULTS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL ONE C THE VALUE 1.0E0. C REAL PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE. C REAL PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C REAL PVMCRV C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J)-STPCRV. C REAL PVPCRV C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J)+STPCRV. C REAL PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP. C REAL PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C REAL STPCRV C THE STEP SIZE SELECTED TO CHECK FOR CURVATURE IN THE MODEL. C REAL THIRD C THE VALUE 1.0E0/3.0E0. C REAL THREE C THE VALUE 3.0E0. C REAL TOL C THE AGREEMENT TOLERANCE. C REAL TWO C THE VALUE 2.0E0. C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT SJCKC * * THIRD = ONE/THREE * IF (ISWRTB) THEN * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA * STPCRV = (ETA**THIRD*PARMX*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) PVPCRV = SPVB(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STPCRV,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF PVMCRV = SPVB(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,-STPCRV,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF ELSE * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA * STPCRV = (ETA**THIRD*PARMX*SIGN(ONE,XPLUSD(NROW,J))+ + XPLUSD(NROW,J)) - XPLUSD(NROW,J) PVPCRV = SPVD(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STPCRV,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF PVMCRV = SPVD(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,-STPCRV,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF END IF * C ESTIMATE CURVATURE BY SECOND DERIVATIVE OF MODEL * CURVE = ((PVPCRV-PV)+(PVMCRV-PV)) / (STPCRV*STPCRV) CURVE = CURVE + (ETA ** THIRD) * (ABS(PVPCRV) + + ABS(PVMCRV) + TWO * ABS(PV)) / (PARMX * PARMX) * C COMPARE NUMERICAL AND ANALYTICAL DERIVATIVES USING A FUDGE C FACTOR OF TEN. * IF (ABS(CURVE*STP)*FIVE.LT.ABS(FD-D)) THEN * C CURVATURE CANNOT ACCOUNT FOR DISCREPANCY. * C CHECK IF FINITE PRECISION ARITHMETIC COULD BE THE CULPRIT. * CALL SJCKF(FUN,NFEV,N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL, + J,NROW,PV,D,FD,PARMX,PVPSTP,STP,CURVE, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF * ELSE * C HIGH CURVATURE COULD BE THE PROBLEM. TRY A SMALLER STEP SIZE. * C COMPUTE DERIVATIVE WITH SMALLER STEP SIZE C IF SMALLER STEP SIZE IS TOO SMALL SET MSG(J+1)=1 ELSE COMPUTE C PREDICTED VALUE WITH NEW STEP. * IF (ISWRTB) THEN * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA * STP = (TWO*TOL*ABS(D)*SIGN(ONE,BETA(J)) / + ABS(CURVE)+BETA(J)) - BETA(J) IF (ABS(STP).LE.EPSMAC*ABS(BETA(J))) THEN IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 6 RETURN ELSE PVPSTP = SPVB(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF END IF ELSE * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA * STP = (TWO*TOL*ABS(D)*SIGN(ONE,XPLUSD(NROW,J)) / + ABS(CURVE)+XPLUSD(NROW,J)) - XPLUSD(NROW,J) IF (ABS(STP).LE.EPSMAC*ABS(XPLUSD(NROW,J))) THEN IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 6 RETURN ELSE PVPSTP = SPVD(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) IF (ISTOPF.NE.0) THEN RETURN END IF END IF END IF * C COMPUTE THE NEW NUMERICAL DERIVATIVE * FD = (PVPSTP-PV)/STP * C CHECK WHETHER THE NEW NUMERICAL DERIVATIVE IS OK * IF (ABS(FD-D).GT.TWO*TOL*ABS(D)) THEN * C NUMERICAL DERIVATIVE COMPUTED USING NEW STEP SIZE DOES C NOT AGREE WITH ANALYTIC DERIVATIVE. * C CHECK IF THE PROBLEM COULD BE THE FORWARD DIFFERENCE QUOTIENT C DERIVATIVE. * C (FUDGE FACTOR IS 2) * IF (ABS(STP*(FD-D)).GE.TWO*ETA*ABS(PV+PVPSTP)) THEN * C FINITE PRECISION COULD NOT BE THE CULPRIT * MSG(1) = 1 MSG(J+1) = 1 ELSE * C FINITE PRECISION MAY BE THE CULPRIT * IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 6 END IF END IF END IF * RETURN END *SJCKF SUBROUTINE SJCKF + (FUN,NFEV,N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL, + J,NROW,PV,D,FD,PARMX,PVPSTP,STP,CURVE, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) C***BEGIN PROLOGUE SJCKF C***REFER TO SODR,SODRC C***ROUTINES CALLED SPVB,SPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE CHECK WHETHER FINITE PRECISION ARITHMETIC COULD BE THE C CAUSE OF THE DISAGREEMENT BETWEEN THE DERIVATIVES. C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKFPA) C***END PROLOGUE SJCKF * C...SCALAR ARGUMENTS REAL + CURVE,D,ETA,FD,PARMX,PV,PVPSTP,STP,TOL INTEGER + ISTOPF,J,LDXPD,LMSG,M,N,NFEV,NP,NROW LOGICAL + ISWRTB * C...ARRAY ARGUMENTS REAL + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) INTEGER + MSG(LMSG) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS REAL + ONE,TEN,TWO LOGICAL + LARGE * C...EXTERNAL FUNCTIONS REAL + SPVB,SPVD EXTERNAL + SPVB,SPVD * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SIGN * C...DATA STATEMENTS DATA + ONE,TWO,TEN + /1.0E0,2.0E0,10.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL CURVE C A MEASURE OF THE CURVATURE IN THE MODEL. C REAL D C THE SCALAR IN WHICH ROW NROW OF THE DERIVATIVE C MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER C IS STORED. C REAL ETA C THE RELATIVE NOISE IN THE MODEL C REAL FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C LOGICAL ISWRTB C THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT C BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C LOGICAL LARGE C AN INDICATOR VALUE INDICATING WHETHER THE RECOMMENDED C INCREASE IN THE STEP SIZE WOULD BE GREATER THAN PARMX. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSG(LMSG) C THE ERROR CHECKING RESULTS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL ONE C THE VALUE 1.0E0. C REAL PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE C TYPICAL VALUE OF THAT PARAMETER C REAL PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C REAL PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP. C REAL PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C REAL TEN C THE VALUE 10.0E0. C REAL TOL C THE AGREEMENT TOLERANCE. C REAL TWO C THE VALUE 2.0E0. C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT SJCKF * * C CHECK WHETHER FINITE PRECISION COULD BE THE PROBLEM * IF (ABS(STP*(FD-D)).GE.TEN*ETA*(ABS(PV)+ABS(PVPSTP))) THEN * C DISCREPANCY BETWEEN NUMERICAL AND ANALYTICAL DERIVATIVES CANNOT C BE ACCOUNTED FOR BY FINITE PRECISION ARITHMETIC * MSG(1) = 1 MSG(J+1) = 1 ELSE * C FINITE PRECISION ARITHMETIC COULD BE THE PROBLEM. C TRY A LARGER STEP SIZE * * IF (ISWRTB) THEN * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA * STP = (ETA*(ABS(PV)+ABS(PVPSTP))*SIGN(ONE,BETA(J))/ + (TOL*ABS(D))+BETA(J)) - BETA(J) IF (ABS(STP).GT.PARMX) THEN STP = PARMX*SIGN(ONE,BETA(J)) LARGE = .TRUE. ELSE LARGE = .FALSE. END IF PVPSTP = SPVB(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) ELSE * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA * STP = (ETA*(ABS(PV)+ABS(PVPSTP))*SIGN(ONE,XPLUSD(NROW,J))/ + (TOL*ABS(D))+XPLUSD(NROW,J)) - XPLUSD(NROW,J) IF (ABS(STP).GT.PARMX) THEN STP = PARMX*SIGN(ONE,XPLUSD(NROW,J)) LARGE = .TRUE. ELSE LARGE = .FALSE. END IF PVPSTP = SPVD(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) END IF IF (ISTOPF.NE.0) THEN RETURN END IF * FD = (PVPSTP-PV)/STP * C CHECK FOR AGREEMENT * IF ((ABS(FD-D)).GT.TWO*TOL*ABS(D)) THEN * C FORWARD DIFFERENCE QUOTIENT AND ANALYTIC DERIVATIVES STILL DISAGREE. C CHECK IF CURVATURE IS THE PROBLEM * IF (ABS(CURVE*STP).GE.ABS(FD-D) .OR. LARGE) THEN * C CURVATURE MAY BE THE CULPRIT * IF (MSG(1).EQ.0) MSG(1) = 2 IF (LARGE) THEN MSG(J+1) = 5 ELSE MSG(J+1) = 6 END IF ELSE * C CURVATURE COULDNT BE THE CULPRIT * MSG(1) = 1 MSG(J+1) = 1 END IF END IF END IF * RETURN END *SJCKM SUBROUTINE SJCKM + (FUN,NFEV, + N,NP,M,XPLUSD,LDXPD,BETA,TYPJ, + ETA,TOL,EPSMAC, + J,NROW,PV,D,PVTEMP, + ISWRTB,MSG,LMSG,ISTOPF) C***BEGIN PROLOGUE SJCKM C***REFER TO SODR,SODRC C***ROUTINES CALLED SJCKC,SJCKZ,SPVB,SPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE CHECK USER-SUPPLIED ANALYTIC DERIVATIVES AGAINST NUMERICAL C DERIVATIVES C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKMN.) C***END PROLOGUE SJCKM * C...SCALAR ARGUMENTS REAL + D,EPSMAC,ETA,PV,TOL,TYPJ INTEGER + ISTOPF,J,LDXPD,LMSG,M,N,NFEV,NP,NROW LOGICAL + ISWRTB * C...ARRAY ARGUMENTS REAL + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) INTEGER + MSG(LMSG) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS REAL + FD,ONE,PARMX,PVPSTP,STP,ZERO * C...EXTERNAL FUNCTIONS REAL + SPVB,SPVD EXTERNAL + SPVB,SPVD * C...EXTERNAL SUBROUTINES EXTERNAL + SJCKC,SJCKZ * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MAX,SIGN,SQRT * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0E0,1.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL D C THE SCALAR IN WHICH ROW NROW OF THE DERIVATIVE C MATRIX WITH RESPECT TO THE JTH UNKNOWN PARAMETER C IS STORED. C REAL EPSMAC C THE VALUE OF MACHINE PRECISION. C REAL ETA C THE RELATIVE NOISE IN THE MODEL C REAL FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C LOGICAL ISWRTB C THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT C BETA (ISWRTB=TRUE) OR DELTA(ISWRTB=FALSE) ARE BEING CHECKED. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSG(LMSG) C THE ERROR CHECKING RESULTS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL ONE C THE VALUE 1.0E0. C REAL PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE C TYPICAL VALUE OF THAT PARAMETER C REAL PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C REAL PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP. C REAL PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C REAL TOL C THE AGREEMENT TOLERANCE. C REAL TYPJ C THE TYPICAL SIZE OF THE J-TH UNKNOWN BETA OR DELTA. C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SJCKM * * C CALCULATE THE JTH PARTIAL DERIVATIVE USING FORWARD DIFFERENCE C QUOTIENTS AND DECIDE IF IT AGREES WITH USER SUPPLIED VALUES * MSG(J+1) = 0 * IF (ISWRTB) THEN * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA * PARMX = MAX(ABS(BETA(J)),ABS(TYPJ)) STP = (SQRT(ETA)*PARMX*SIGN(ONE,BETA(J))+BETA(J)) - BETA(J) PVPSTP = SPVB(FUN,NFEV, + N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) ELSE * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA * PARMX = MAX(ABS(XPLUSD(NROW,J)),ABS(TYPJ)) STP = (SQRT(ETA)*PARMX*SIGN(ONE,XPLUSD(NROW,J))+XPLUSD(NROW,J)) + - XPLUSD(NROW,J) PVPSTP = SPVD(FUN,NFEV, + N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,STP,ISTOPF) END IF IF (ISTOPF.NE.0) THEN RETURN END IF * FD = (PVPSTP-PV)/STP * C CHECK FOR DISAGREEMENT * IF (ABS(FD-D).LE.TOL*ABS(D)) THEN * C NUMERICAL AND ANALYTIC DERIVATIVES AGREE * C CHECK IF ANALYTIC DERIVATIVE IS IDENTICALLY ZERO, INDICATING C THE POSSIBILITY THAT THE DERIVATIVE SHOULD BE RECHECKED AT C ANOTHER POINT. * IF (D.EQ.ZERO) THEN * C JTH ANALYTIC AND NUMERICAL DERIVATIVES BOTH ARE ZERO. C SET MSG FLAG ACCORDINGLY. * IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 2 END IF * ELSE * C NUMERICAL AND ANALYTIC DERIVATIVES DISAGREE * C CHECK WHY * IF (D.EQ.ZERO) THEN CALL SJCKZ(FUN,NFEV, + N,NP,M,XPLUSD,LDXPD,BETA,EPSMAC, + J,NROW,PV,FD,PARMX,PVPSTP,STP, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) ELSE CALL SJCKC(FUN,NFEV, + N,NP,M,XPLUSD,LDXPD,BETA,ETA,TOL,EPSMAC, + J,NROW,PV,D,FD,PARMX,PVPSTP,STP, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) END IF END IF * RETURN END *SJCKZ SUBROUTINE SJCKZ + (FUN,NFEV,N,NP,M,XPLUSD,LDXPD,BETA,EPSMAC, + J,NROW,PV,FD,PARMX,PVPSTP,STP, + PVTEMP,ISWRTB,MSG,LMSG,ISTOPF) C***BEGIN PROLOGUE SJCKZ C***REFER TO SODR,SODRC C***ROUTINES CALLED SPVB,SPVD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE RECHECK THE DERIVATIVES IN THE CASE WHERE THE FINITE C DIFFERENCE DERIVATIVE DISAGREES WITH THE ANALYTIC C DERIVATIVE AND THE ANALYTIC DERIVATIVE IS ZERO. C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKZRO) C***END PROLOGUE SJCKZ * C...SCALAR ARGUMENTS REAL + EPSMAC,FD,PARMX,PV,PVPSTP,STP INTEGER + ISTOPF,J,LDXPD,LMSG,M,N,NFEV,NP,NROW LOGICAL + ISWRTB * C...ARRAY ARGUMENTS REAL + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) INTEGER + MSG(LMSG) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS REAL + CD,ONE,PVMSTP,THREE,TWO,ZERO * C...EXTERNAL FUNCTIONS REAL + SPVB,SPVD EXTERNAL + SPVB,SPVD * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MIN * C...DATA STATEMENTS DATA + ZERO,ONE,TWO,THREE + /0.0E0,1.0E0,2.0E0,3.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL CD C THE CENTRAL DIFFERENCE QUOTIENT DERIVATIVE WITH C RESPECT TO THE JTH PARAMETER. C REAL EPSMAC C THE VALUE OF MACHINE PRECISION. C REAL FD C THE FORWARD DIFFERENCE QUOTIENT DERIVATIVE WITH RESPECT TO THE C JTH PARAMETER. C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C LOGICAL ISWRTB C THE CONTROL VALUE DETERMINING WHETHER THE DERIVATIVES WRT C BETA (ISWRTB=TRUE) OR X (ISWRTB=FALSE) ARE BEING CHECKED. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER LMSG C THE LENGTH OF THE VECTOR MSG. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSG(LMSG) C THE ERROR CHECKING RESULTS. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL ONE C THE VALUE 1.0E0. C REAL PARMX C THE MAXIMUM OF THE CURRENT PARAMETER ESTIMATE AND THE TYPICAL C VALUE OF THAT PARAMETER. C REAL PV C THE SCALAR IN WHICH THE PREDICTED VALUE FROM THE MODEL FOR C ROW NROW IS STORED. C REAL PVMSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) - STP. C REAL PVPSTP C THE PREDICTED VALUE FOR ROW NROW OF THE MODEL C BASED ON THE CURRENT PARAMETER ESTIMATES C FOR ALL BUT THE JTH PARAMETER VALUE, WHICH IS BETA(J) + STP. C REAL PVTEMP(N) C THE VECTOR OF PREDICTED VALUES FROM THE MODEL. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE C REAL THREE C THE VALUE 3.0E0. C REAL TWO C THE VALUE 2.0E0. C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SJCKZ * * C RECALCULATE NUMERICAL DERIVATIVE USING CENTRAL DIFFERENCE AND STEP C SIZE OF 2*STP * IF (ISWRTB) THEN * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT BETA * PVMSTP = SPVB(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,-STP,ISTOPF) ELSE * C PERFORM COMPUTATIONS FOR DERIVATIVES WRT DELTA * PVMSTP = SPVD(FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP, + NROW,J,-STP,ISTOPF) END IF IF (ISTOPF.NE.0) THEN RETURN END IF * CD = (PVPSTP-PVMSTP)/(TWO*STP) * C CHECK FOR DISAGREEMENT * IF (CD.EQ.ZERO) THEN * C NUMERICAL AND ANALYTIC DERIVATIVES NOW AGREE, BUT BOTH EQUAL ZERO, C INDICATING THAT DERIVATIVES SHOULD BE RECHECKED AT ANOTHER POINT. * IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 2 ELSE * C NUMERICAL AND ANALYTIC DERIVATIVE STILL DO NOT AGREE. C CHECK IF NUMERICAL DERIVATIVE IS CLOSE TO ZERO. * IF (MIN(ABS(CD),ABS(FD))*PARMX.LE. + ABS(PV*EPSMAC**(ONE/THREE))) THEN * C NUMERICAL DERIVATIVE IS CLOSE TO ZERO * IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 3 ELSE * C NUMERICAL DERIVATIVE NOT CLOSE TO ZERO * IF (MSG(1).EQ.0) MSG(1) = 2 MSG(J+1) = 4 END IF END IF * RETURN END *SODCHK SUBROUTINE SODCHK + (N,NP,M, + IFIXB, + LDX,LDIFX,LDSCLD,LDWD, + LWORK,LWKMN,LIWORK,LIWKMN, + SCLD,SCLB,W,WD, + INFO) C***BEGIN PROLOGUE SODCHK C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE CHECK INPUT PARAMETERS, INDICATING ERRORS FOUND USING C NONZERO VALUES OF ARGUMENT INFO AS DESCRIBED IN THE C PROLOGUES FOR SODR AND SODRC. C***END PROLOGUE SODCHK * C...SCALAR ARGUMENTS INTEGER + INFO,LDIFX,LDSCLD,LDWD,LDX,LIWKMN,LIWORK,LWKMN,LWORK,M,N, + NP * C...ARRAY ARGUMENTS REAL + SCLB(NP),SCLD(LDSCLD,M),W(N),WD(LDWD,M) INTEGER + IFIXB(NP) * C...LOCAL SCALARS REAL + ZERO INTEGER + I,J,K,LAST,NNZW,NPP * C...INTRINSIC FUNCTIONS INTRINSIC + LOG10 * C...DATA STATEMENTS DATA + ZERO + /0.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER J C AN INDEXING VARIABLE. C INTEGER K C AN INDEXING VARIABLE. C INTEGER LAST C THE LAST ROW OF THE ARRAY TO BE ACCESSED. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NNZW C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C REAL SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SODCHK * * C FIND ACTUAL NUMBER OF PARAMETERS BEING ESTIMATED * IF (NP.LE.0 .OR. IFIXB(1).LT.0) THEN NPP = NP ELSE NPP = 0 DO 10 K=1,NP IF (IFIXB(K).NE.0) THEN NPP = NPP + 1 END IF 10 CONTINUE END IF * C CHECK PROBLEM SPECIFICATION PARAMETERS * IF (N.LE.0 .OR. M.LE.0 .OR. NPP.LE.0 .OR. NPP.GT.N) THEN INFO = 10000 IF (N.LE.0) THEN INFO = INFO + 1000 END IF IF (M.LE.0) THEN INFO = INFO + 100 END IF IF (NPP.LE.0 .OR. NPP.GT.N) THEN INFO = INFO + 10 END IF RETURN END IF * C CHECK DIMENSION SPECIFICATION PARAMETERS * IF (LDX.LT.N .OR. + (LDIFX.NE.1 .AND. LDIFX.LT.N) .OR. + (LDSCLD.NE.1 .AND. LDSCLD.LT.N) .OR. + (LDWD.NE.1 .AND. LDWD.LT.N) .OR. + LWORK.LT.LWKMN .OR. LIWORK.LT.LIWKMN) THEN INFO = 20000 IF (LDX.LT.N) THEN INFO = INFO + 1000 END IF IF (LDIFX.NE.1 .AND. LDIFX.LT.N) THEN INFO = INFO + 100 END IF IF (LDSCLD.NE.1 .AND. LDSCLD.LT.N) THEN INFO = INFO + 200 END IF IF (LDWD.NE.1 .AND. LDWD.LT.N) THEN INFO = INFO + 400 END IF IF (LWORK.LT.LWKMN) THEN INFO = INFO + 10 END IF IF (LIWORK.LT.LIWKMN) THEN INFO = INFO + 1 END IF RETURN END IF * C CHECK DELTA SCALING * IF (SCLD(1,1).GT.0) THEN DO 30 J=1,M IF (LDSCLD.GE.N) THEN LAST = N ELSE LAST = 1 END IF DO 20 I=1,LAST IF (SCLD(I,J).LE.0) THEN INFO = 31000 GO TO 40 END IF 20 CONTINUE 30 CONTINUE END IF * C CHECK BETA SCALING * 40 IF (SCLB(1).GT.0) THEN DO 50 K=1,NP IF (SCLB(K).LE.0) THEN IF (INFO.EQ.0) THEN INFO = 30100 ELSE INFO = INFO + 100 END IF GO TO 60 END IF 50 CONTINUE END IF * C CHECK OBSERVATIONAL ERROR WEIGHTS IF INDIVIDUALLY SPECIFIED * 60 IF (W(1).GE.ZERO) THEN NNZW = 0 DO 70 I=1,N IF (W(I).LT.ZERO) THEN IF (INFO.EQ.0) THEN INFO = 30010 ELSE INFO = INFO + 10 END IF GO TO 80 ELSE IF (W(I).GT.ZERO) THEN NNZW = NNZW + 1 END IF 70 CONTINUE IF (NNZW.LT.NPP) THEN IF (INFO.EQ.0) THEN INFO = 30020 ELSE INFO = INFO + 20 END IF END IF END IF * C CHECK DELTA WEIGHTS IF INDIVIDUALLY SPECIFIED * 80 IF (WD(1,1).GE.ZERO) THEN DO 100 J=1,M IF (LDWD.GE.N) THEN LAST = N ELSE LAST = 1 END IF DO 90 I=1,LAST IF (WD(I,J).LE.ZERO) THEN IF (INFO.EQ.0) THEN INFO = 30001 ELSE INFO = INFO + 1 END IF GO TO 110 END IF 90 CONTINUE 100 CONTINUE END IF * 110 RETURN * END *SODDRV SUBROUTINE SODDRV + (SHORT, + FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) C***BEGIN PROLOGUE SODDRV C***REFER TO SODR,SODRC C***ROUTINES CALLED SCOPY,SDIAGS,SDOT,SETAF,SEVFUN,SFLAGS, C SINIWK,SIWINF,SJCK,SNRM2,SODCHK,SODMN, C SODPER,SPACK,SSETN,SWDS,SWINF C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE PERFORM ERROR CHECKING AND INITIALIZATION, AND BEGIN C PROCEDURE FOR PERFORMING ORTHOGONAL DISTANCE REGRESSION C (ODR) ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) C***END PROLOGUE SODDRV * C...SCALAR ARGUMENTS REAL + PARTOL,SSTOL,TAUFAC INTEGER + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDWD,LDX,LIWORK,LUNERR, + LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP LOGICAL + SHORT * C...ARRAY ARGUMENTS REAL + BETA(NP),SCLB(NP),SCLD(LDSCLD,M), + W(N),WD(LDWD,M),WORK(LWORK),X(LDX,M),Y(N) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS REAL + EPSMAC,ETA,TEN,ZERO INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,DDELTI,DELTAI,DELTNI,DELTSI, + EPSMAI,ETAI,FI,FJACBI,FJACXI,FNI,FSI,I,IDFI,INT2I,IPRINI, + IRANKI,ISTOPF,ISTOPJ,JOBI,JPVTI,LDTT,LDTTI,LIWKMN,LUNERI, + LUNRPI,LWKMN,MAXITI,MSGB,MSGX,NETA,NETAI,NFEV,NFEVI,NITERI, + NJEV,NJEVI,NNZWI,NPPI,NROW,NROWI,NTOL,NTOLI,OLMAVI,OMEGAI, + PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,RNORSI,RVARI,SI,SSFI,SSI, + SSSI,SSTOLI,TAUFCI,TAUI,TFJACI,TI,TTI,UI,WRK1I,WRK2I,WSSI, + WSSDEI,WSSEPI,XPLUSI,YTI LOGICAL + ANAJAC,CHKJAC,DOVCV,INITD,ISODR,RESTRT * C...EXTERNAL FUNCTIONS REAL + SDOT,SNRM2 EXTERNAL + SDOT,SNRM2 * C...EXTERNAL SUBROUTINES EXTERNAL + SCOPY,SDIAGS,SETAF,SEVFUN,SFLAGS,SINIWK,SIWINF,SJCK, + SODCHK,SODMN,SODPER,SPACK,SSETN,SWDS,SWINF * C...DATA STATEMENTS DATA + ZERO,TEN + /0.0E0,10.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE FUNCTION. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER ACTRSI C THE LOCATION IN ARRAY WORK OF C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER ALPHAI C THE LOCATION IN ARRAY WORK OF C THE LEVENBERG-MARQUARDT PARAMETER. C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER BETACI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETANI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETASI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C INTEGER DDELTI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (W*D)**2 * DELTA. C INTEGER DELTAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C INTEGER EPSMAI C THE LOCATION IN ARRAY WORK OF C THE VALUE OF MACHINE PRECISION. C REAL ETA C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C INTEGER ETAI C THE LOCATION IN ARRAY WORK OF C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C INTEGER FI C THE STARTING LOCATION IN ARRAY WORK OF C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FJACBI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO BETA. C INTEGER FJACXI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO X. C INTEGER FNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER I C AN INDEX VARIABLE. C INTEGER IDFI C THE STARTING LOCATION IN ARRAY IWORK OF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C INTEGER INT2I C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF INTERNAL DOUBLING STEPS. C INTEGER IPRINI C THE LOCATION IN ARRAY IWORK OF C THE PRINT CONTROL VARIABLE. C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IRANKI C THE LOCATION IN ARRAY IWORK OF C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER ISTOPJ C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE JACOBIAN GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOBI C THE LOCATION IN ARRAY IWORK OF C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C INTEGER JPVTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE PIVOT VECTOR. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDTTI C THE STARTING LOCATION IN ARRAY IWORK OF C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNERI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPI C THE LOCATION IN ARRAY IWORK OF C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXITI C THE LOCATION IN ARRAY IWORK OF C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C INTEGER MSGB C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX C THE STARTING LOCATION IN ARRAY IWORK OF C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NDIGIT C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NETAI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NFEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITERI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NJEVI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NNZWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPPI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C INTEGER NROW C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NROWI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF THE ROW AT WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTOL C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C TO BE SET BY SJCK. C INTEGER NTOLI C THE LOCATION IN ARRAY IWORK OF C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C NUMERICAL DERIVATIVES AND THE USER SUPPLIED DERIVATIVES, C TO BE SET BY SJCK. C INTEGER OLMAVI C THE LOCATION IN ARRAY WORK OF C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OMEGAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C INTEGER PARTLI C THE LOCATION IN ARRAY WORK OF C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C REAL PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL PNORM C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C INTEGER PNORMI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C INTEGER PRERSI C THE LOCATION IN ARRAY WORK OF C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER QRAUXI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C INTEGER RCONDI C THE LOCATION IN ARRAY WORK OF C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C INTEGER RNORSI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C INTEGER RVARI C THE LOCATION IN ARRAY WORK OF C THE RESIDUAL VARIANCE, I.E. STANDARD DEVIATION SQUARED. C REAL SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS C INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG- C CALL (SHORT=.FALSE.). C INTEGER SI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED BETA'S. C INTEGER SSFI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE BETA'S. C INTEGER SSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE ESTIMATED BETA'S. C INTEGER SSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C REAL SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER SSTOLI C THE LOCATION IN ARRAY WORK OF C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C REAL TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER TAUFCI C THE LOCATION IN ARRAY WORK OF C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C INTEGER TAUI C THE LOCATION IN ARRAY WORK OF C THE TRUST REGION DIAMETER. C REAL TEN C THE VALUE 10.0E0. C INTEGER TFJACI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER TI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED DELTA'S. C INTEGER TTI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE DELTA'S. C INTEGER UI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR TFJACB. C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WORK(LWORK) C THE REAL WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER WRK1I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WRK2I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C INTEGER WSSDEI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C INTEGER WSSEPI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER XPLUSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY X + DELTA. C REAL Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER YTI C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SODDRV * * C SET STARTING LOCATIONS WITHIN INTEGER WORKSPACE C (INVALID VALUES OF M AND/OR NP ARE HANDLED REASONABLY BY SIWINF) * CALL SIWINF(M,NP, + MSGB,MSGX,JPVTI, + NNZWI,NPPI,IDFI, + JOBI,IPRINI,LUNERI,LUNRPI, + NROWI,NTOLI,NETAI, + MAXITI,NITERI,NFEVI,NJEVI,INT2I,IRANKI,LDTTI, + LIWKMN) * C SET STARTING LOCATIONS WITHIN REAL WORK SPACE C (INVALID VALUES OF N, M AND/OR NP ARE HANDLED REASONABLY BY SWINF) * CALL SWINF(N,M,NP, + DELTAI,FI, + WSSI,WSSDEI,WSSEPI,RVARI, + PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI, + FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,DELTSI, + DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,TAUI, + ALPHAI,TFJACI,OMEGAI,YTI,UI,QRAUXI,WRK1I,WRK2I,RCONDI, + ETAI,ACTRSI,PNORMI,PRERSI,RNORSI, + LWKMN) * C INITIALIZE NECESSARY VARIABLES * CALL SFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR,DOVCV) INFO = 0 * IF (RESTRT) THEN * C RESET MAXIMUM NUMBER OF ITERATIONS * IWORK(JOBI) = (JOB/10000)*10000 + MOD(IWORK(JOBI),10000) IWORK(MAXITI) = IWORK(MAXITI) + 10 WORK(OLMAVI) = WORK(OLMAVI)*IWORK(NITERI) CALL SCOPY(N,WORK(SSSI),1,WORK(FI),1) * ELSE * C PERFORM ERROR CHECKING * CALL SODCHK(N,NP,M, + IFIXB, + LDX,LDIFX,LDSCLD,LDWD, + LWORK,LWKMN,LIWORK,LIWKMN, + SCLD,SCLB,W,WD, + INFO) IF (INFO.NE.0) THEN GO TO 20 END IF * C INITIALIZE WORK VECTORS AS NECESSARY * CALL SINIWK(N,M,NP,WORK,LWORK,IWORK,LIWORK, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + BETA,SCLB, + SSTOL,PARTOL,MAXIT,TAUFAC, + JOB,IPRINT,LUNERR,LUNRPT, + EPSMAI,SSTOLI,PARTLI,MAXITI,TAUFCI, + JOBI,IPRINI,LUNERI,LUNRPI, + SSFI,TTI,LDTTI,DELTAI) * IWORK(INT2I) = 0 IWORK(IRANKI) = 0 IWORK(NFEVI) = 0 IWORK(NITERI) = 0 IWORK(NJEVI) = 0 IWORK(IDFI) = 0 * WORK(ACTRSI) = ZERO WORK(ALPHAI) = ZERO WORK(OLMAVI) = ZERO WORK(PNORMI) = ZERO WORK(PRERSI) = ZERO WORK(RCONDI) = ZERO WORK(WSSI) = ZERO WORK(WSSEPI) = ZERO WORK(WSSDEI) = ZERO WORK(RVARI) = ZERO WORK(RNORSI) = ZERO * WORK(TAUI) = -WORK(TAUFCI) * C SET UP FOR PARAMETER ESTIMATION - C PULL BETA'S TO BE ESTIMATED AND CORRESPONDING SCALE VALUES C AND STORE IN WORK(BETACI) AND WORK(SSI), RESPECTIVELY * CALL SPACK(NP,IWORK(NPPI),WORK(BETACI),BETA,IFIXB) IF (WORK(SSFI).GT.ZERO) THEN CALL SPACK(NP,IWORK(NPPI),WORK(SSI),WORK(SSFI),IFIXB) ELSE WORK(SSI) = WORK(SSFI) END IF * C EVALUATE THE WEIGHTED EPSILONS AT THE STARTING POINT * CALL SEVFUN(N,NP,M,WORK(BETACI),BETA,IFIXB,FUN, + X,LDX,Y,WORK(DELTAI),N,WORK(XPLUSI),N, + W,WORK(FI),IWORK(NFEVI),ISTOPF) IF (ISTOPF.NE.0) THEN INFO = 52000 GO TO 20 END IF * C FIND NUMBER OF NONZERO WEIGHTS * IF (W(1).LT.ZERO) THEN IWORK(NNZWI) = N ELSE IWORK(NNZWI) = 0 DO 10 I=1,N IF (W(I).GT.ZERO) THEN IWORK(NNZWI) = IWORK(NNZWI) + 1 END IF 10 CONTINUE END IF * C COMPUTE NORM OF THE INITIAL ESTIMATES * CALL SDIAGS(IWORK(NPPI),1,WORK(SSI),IWORK(NPPI), + WORK(BETACI),IWORK(NPPI),WORK(SSSI),IWORK(NPPI)) CALL SDIAGS(N,M,WORK(TTI),IWORK(LDTTI),WORK(DELTAI),N, + WORK(SSSI+IWORK(NPPI)),N) WORK(PNORMI) = SNRM2(IWORK(NPPI)+N*M,WORK(SSSI),1) * C COMPUTE SUM OF SQUARES OF THE WEIGHTED EPSILONS AND WEIGHTED DELTAS * CALL SCOPY(N,WORK(FI),1,WORK(SSSI),1) WORK(WSSEPI) = SDOT(N,WORK(SSSI),1,WORK(SSSI),1) CALL SWDS(N,M,W,WD,LDWD,WORK(DELTAI),N,WORK(SSSI+N),N) WORK(WSSDEI) = SDOT(N*M,WORK(SSSI+N),1,WORK(SSSI+N),1) WORK(WSSI) = WORK(WSSEPI) + WORK(WSSDEI) * C SELECT FIRST ROW OF X + DELTA THAT CONTAINS NO ZEROS * NROW = -1 CALL SSETN(N,M,WORK(XPLUSI),N,NROW) IWORK(NROWI) = NROW * C SET NUMBER OF GOOD DIGITS IN FUNCTION RESULTS * EPSMAC = WORK(EPSMAI) IF ((NDIGIT.LT.2) .OR. + (NDIGIT.GT.INT(-LOG10(EPSMAC)))) THEN IWORK(NETAI) = -1 NFEV = IWORK(NFEVI) CALL SETAF(FUN,NFEV, + N,NP,M,WORK(XPLUSI),N, + BETA,ETA,NETA,EPSMAC, + NROW,WORK(BETANI),WORK(FNI),ISTOPF) IWORK(NFEVI) = NFEV IF (ISTOPF.NE.0) THEN INFO = 53000 IWORK(NETAI) = 0 WORK(ETAI) = ZERO GO TO 20 ELSE IWORK(NETAI) = NETA WORK(ETAI) = ETA END IF ELSE IWORK(NETAI) = NDIGIT WORK(ETAI) = TEN**(-NDIGIT) END IF * C CHECK DERIVATIVES IF NECESSARY * IF (CHKJAC .AND. ANAJAC) THEN NTOL = -1 NFEV = IWORK(NFEVI) NJEV = IWORK(NJEVI) NETA = IWORK(NETAI) LDTT = IWORK(LDTTI) ETA = WORK(ETAI) EPSMAC = WORK(EPSMAI) CALL SJCK(FUN,JAC,NFEV,NJEV, + N,NP,M,BETA,WORK(XPLUSI),N, + ETA,NETA,NTOL, + WORK(SSFI),WORK(TTI),LDTT,NROW, + ISODR,EPSMAC, + WORK(FNI),WORK(FJACBI),N,WORK(FJACXI),N, + IWORK(MSGB),IWORK(MSGX),ISTOPF,ISTOPJ) IWORK(NFEVI) = NFEV IWORK(NJEVI) = NJEV IWORK(NTOLI) = NTOL IF (ISTOPF.NE.0) THEN INFO = 54000 ELSE IF (ISTOPJ.NE.0) THEN INFO = 50200 ELSE IF (IWORK(MSGB).NE.0 .OR. IWORK(MSGX).NE.0) THEN INFO = 40000 END IF ELSE * C INDICATE USER-SUPPLIED DERIVATIVES WERE NOT CHECKED * IWORK(MSGB) = -1 IWORK(MSGX) = -1 END IF END IF * C PRINT APPROPRIATE ERROR MESSAGES * 20 IF (INFO.NE.0) THEN IF (LUNERR.NE.0 .AND. IPRINT.NE.0) THEN CALL SODPER + (INFO,LUNERR,SHORT, + N,NP,M, + LDSCLD,LDWD, + LWKMN,LIWKMN, + SCLD,SCLB,W,WD, + IWORK(MSGB),ISODR,IWORK(MSGX), + WORK(XPLUSI),N,IWORK(NROWI),IWORK(NETAI),IWORK(NTOLI)) END IF * C SET INFO TO REFLECT ERRORS IN THE USER-SUPPLIED JACOBIANS * IF (INFO.EQ.40000) THEN IF (IWORK(MSGB).EQ.1 .OR. IWORK(MSGX).EQ.1) THEN IF (IWORK(MSGB).EQ.1) THEN INFO = INFO + 1000 END IF IF (IWORK(MSGX).EQ.1) THEN INFO = INFO + 100 END IF ELSE INFO = 0 END IF END IF IF (INFO.NE.0) THEN RETURN END IF END IF * C FIND LEAST SQUARES SOLUTION * LDTT = IWORK(LDTTI) CALL SODMN(FUN,JAC, + N,NP,M, + X,LDX,IFIXX,LDIFX,Y, + WORK(BETACI),IFIXB,BETA,WORK(BETANI),WORK(BETASI), + WORK(SI),WORK(DELTAI),WORK(DELTNI),WORK(DELTSI), + WORK(TI),WORK(FI),WORK(FNI),WORK(FSI), + WORK(FJACBI),IWORK(MSGB),WORK(FJACXI),IWORK(MSGX), + W,WD,LDWD, + WORK(SSFI),WORK(SSI),WORK(TTI),LDTT, + WORK(XPLUSI),WORK(DDELTI),WORK(SSSI), + WORK,LWORK,IWORK,LIWORK,INFO) * RETURN * END *SODLM SUBROUTINE SODLM + (N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX, + W,WD,LDWD,SS,TT,LDTT,DDELT, + ALPHA2,TAU,EPSMAC, + SSS,WRK1,TFJACB,OMEGA,YT, + U,QRAUX,WRK2,JPVT, + S,T,NLMS,RCOND,IRANK) C***BEGIN PROLOGUE SODLM C***REFER TO SODR,SODRC C***ROUTINES CALLED SDIAGI,SDOT,SNRM2,SODSTP C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE LEVENBERG-MARQUARDT PARAMETER AND STEPS S AND T C USING ANALOG OF THE TRUST-REGION LEVENBERG-MARQUARDT C ALGORITHM C***END PROLOGUE SODLM * C...SCALAR ARGUMENTS REAL + ALPHA2,EPSMAC,RCOND,TAU INTEGER + IRANK,LDFJB,LDFJX,LDTT,LDWD,M,N,NLMS,NP,NPP * C...ARRAY ARGUMENTS REAL + DDELT(N,M),F(N),FJACB(LDFJB,NP),FJACX(LDFJX,M), + OMEGA(N),QRAUX(N),S(NP),SS(NP), + SSS(N+N*M),T(N,M),TFJACB(N,NP),TT(LDTT,M),U(N), + W(N),WD(LDWD,M),WRK1(N,M),WRK2(NP),YT(N) INTEGER + JPVT(NP) * C...LOCAL SCALARS REAL + ALPHA1,ALPHAN,BOT,P001,P1,PHI1,PHI2,SA,TOP,ZERO INTEGER + I,J * C...EXTERNAL FUNCTIONS REAL + SDOT,SNRM2 EXTERNAL + SDOT,SNRM2 * C...EXTERNAL SUBROUTINES EXTERNAL + SDIAGI,SODSTP * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MAX,MIN,SQRT * C...DATA STATEMENTS DATA + ZERO,P001,P1 + /0.0E0,0.001E0,0.1E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL ALPHAN C THE NEW LEVENBERG-MARQUARDT PARAMETER. C REAL ALPHA1 C THE PREVIOUS LEVENBERG-MARQUARDT PARAMETER. C REAL ALPHA2 C THE CURRENT LEVENBERG-MARQUARDT PARAMETER. C REAL BOT C THE LOWER LIMIT FOR SETTING ALPHA. C REAL DDELT(N,M) C THE ARRAY (W*D)**2 * DELTA. C REAL EPSMAC C THE VALUE OF MACHINE PRECISION. C REAL F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C REAL FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C REAL FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO X. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C INTEGER J C AN INDEXING VARIABLE. C INTEGER JPVT(NP) C THE PIVOT VECTOR. C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NLMS C THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C REAL OMEGA(N) C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C REAL P001 C THE VALUE 0.001E0 C REAL P1 C THE VALUE 0.1E0 C REAL PHI1 C THE PREVIOUS DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP C AND THE TRUST REGION DIAMETER. C REAL PHI2 C THE CURRENT DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP C AND THE TRUST REGION DIAMETER. C REAL QRAUX(N) C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C REAL RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C REAL S(NP) C THE STEP FOR THE ESTIMATED BETA'S. C REAL SA C THE SCALAR PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2). C REAL SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SSS(N+N*M) C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C REAL T(N,M) C THE STEP FOR THE ESTIMATED DELTA'S. C REAL TAU C THE TRUST REGION DIAMETER. C REAL TFJACB(N,NP) C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C REAL TOP C THE UPPER LIMIT FOR SETTING ALPHA. C REAL TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL U(N) C THE APPROXIMATE NULL VECTOR FOR TFJACB. C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WRK1(N,M) C A WORK ARRAY. C REAL WRK2(NP) C A WORK ARRAY. C REAL YT(N) C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SODLM * * C COMPUTE FULL GAUSS-NEWTON STEP (ALPHA=0) * ALPHA1 = ZERO CALL SODSTP(N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX, + W,WD,LDWD,SS,TT,LDTT,DDELT, + ALPHA1,EPSMAC, + SSS,TFJACB,WRK1,OMEGA, + YT,U,QRAUX,WRK2, + JPVT,S,T,PHI1,IRANK, + RCOND) * C INITIALIZE TAU IF NECESSARY * IF (TAU.LT.ZERO) THEN TAU = ABS(TAU)*PHI1 END IF * C CHECK IF FULL GAUSS-NEWTON STEP IS OPTIMAL * IF ((PHI1-TAU).LE.P1*TAU) THEN NLMS = 1 ALPHA2 = ZERO RETURN END IF * C FULL GAUSS-NEWTON STEP IS OUTSIDE TRUST REGION - C FIND LOCALLY CONSTRAINED OPTIMAL STEP * PHI1 = PHI1 - TAU * C INITIALIZE UPPER AND LOWER BOUNDS FOR ALPHA * BOT = ZERO * IF (NPP.GE.1) THEN DO 10 I=1,NPP SSS(I) = SDOT(N,FJACB(1,I),1,F,1) 10 CONTINUE CALL SDIAGI(NPP,1,SS,NPP,SSS,NPP,SSS,NPP) END IF DO 30 J=1,M DO 20 I=1,N WRK1(I,J) = FJACX(I,J)*F(I) + DDELT(I,J) 20 CONTINUE 30 CONTINUE CALL SDIAGI(N,M,TT,LDTT,WRK1,N,SSS(1+NPP),N) TOP = SNRM2(NPP+N*M,SSS,1)/TAU IF (ALPHA2.GT.TOP .OR. ALPHA2.EQ.ZERO) THEN ALPHA2 = P001*TOP END IF * C MAIN LOOP * DO 40 I=1,10 * C COMPUTE LOCALLY CONSTRAINED STEPS S AND T AND PHI(ALPHA) FOR C CURRENT VALUE OF ALPHA * CALL SODSTP(N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX, + W,WD,LDWD,SS,TT,LDTT,DDELT, + ALPHA2,EPSMAC, + SSS,TFJACB,WRK1,OMEGA, + YT,U,QRAUX,WRK2, + JPVT,S,T,PHI2,IRANK, + RCOND) PHI2 = PHI2-TAU * C CHECK WHETHER CURRENT STEP IS OPTIMAL * IF (ABS(PHI2).LE.P1*TAU .OR. + (ALPHA2.EQ.BOT .AND. PHI2.LT.ZERO)) THEN NLMS = I+1 RETURN END IF * C CURRENT STEP IS NOT OPTIMAL * C UPDATE BOUNDS FOR ALPHA AND COMPUTE NEW ALPHA * IF (PHI1-PHI2.EQ.ZERO) THEN NLMS = 12 RETURN END IF SA = PHI2*(ALPHA1-ALPHA2)/(PHI1-PHI2) IF (PHI2.LT.ZERO) THEN TOP = MIN(TOP,ALPHA2) ELSE BOT = MAX(BOT,ALPHA2) END IF IF (PHI1*PHI2.GT.ZERO) THEN BOT = MAX(BOT,ALPHA2-SA) ELSE TOP = MIN(TOP,ALPHA2-SA) END IF * ALPHAN = ALPHA2 - SA*(PHI1+TAU)/TAU IF (ALPHAN.GE.TOP .OR. ALPHAN.LE.BOT) THEN ALPHAN = MAX(P001*TOP,SQRT(TOP*BOT)) END IF * C GET READY FOR NEXT ITERATION * ALPHA1 = ALPHA2 ALPHA2 = ALPHAN PHI1 = PHI2 40 CONTINUE * C SET NLMS TO INDICATE AN OPTIMAL STEP COULD NOT BE FOUND IN 10 TRYS * NLMS = 12 * RETURN END *SODMN SUBROUTINE SODMN + (FUN,JAC, + N,NP,M, + X,LDX,IFIXX,LDIFX,Y, + BETAC,IFIXB,BETA,BETAN,BETAS,S, + DELTA,DELTAN,DELTAS,T, + F,FN,FS, + FJACB,MSGB,FJACX,MSGX, + W,WD,LDWD,SSF,SS,TT,LDTT, + XPLUSD,DDELT,SSS, + WORK,LWORK,IWORK,LIWORK,INFO) C***BEGIN PROLOGUE SODMN C***REFER TO SODR,SODRC C***ROUTINES CALLED SACCES,SCOPY,SDIAGS,SDIAGW,SDOT,SEVFUN,SEVJAC, C SFLAGS,SIDTS,SNRM2,SODLM,SODPCR,SQRDC,SPODI, C SSCAL,SUNPAC,SWDS,SXPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE ITERATIVELY COMPUTE LEAST SQUARES SOLUTION C***END PROLOGUE SODMN * C...SCALAR ARGUMENTS INTEGER + INFO,LDIFX,LDTT,LDWD,LDX,LIWORK,LWORK,M, + N,NP * C...ARRAY ARGUMENTS REAL + BETA(NP),BETAC(NP),BETAN(NP),BETAS(NP), + DDELT(N,M),DELTA(N,M),DELTAN(N,M),DELTAS(N,M), + F(N),FJACB(N,NP),FJACX(N,M),FN(N),FS(N), + S(NP),SS(NP),SSF(NP),SSS(N+N*M), + T(N,M),TT(LDTT,M),W(N),WD(LDWD,M),WORK(LWORK), + X(LDX,M),XPLUSD(N,M),Y(N) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK),MSGB(NP+1),MSGX(M+1) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS REAL + ACTRED,ACTRS,ALPHA,DIRDER,EPSMAC,OLMAVG,ONE, + P0001,P1,P25,P5,P75,PARTOL,PNORM,PRERED,PRERS, + RATIO,RCOND,RNORM,RNORMN,RNORMS,RVAR,SSTOL,TAU,TAUFAC, + TEMP,TEMP1,TEMP2,TSNORM,WSS,WSSDEL,WSSEPS,ZERO INTEGER + I,IDF,IFLAG,INT2,IPR1,IPR2,IPR2F,IPR3,IRANK,ISTOPF,ISTOPJ,J, + JOB,JPVT,JUNFIX,LUNRPT,MAXIT,NETA,NFEV,NITER,NJEV,NLMS,NNZW, + NPP,OMEGA,QRAUX,TFJACB,U,WRK1,WRK2,YT LOGICAL + ACCESS,ANAJAC,CHKJAC,CNVPAR,CNVSS,DIDVCV,DOVCV,FSTITR,HEAD, + INITD,INTDBL,ISODR,LSTEP,RESTRT * C...LOCAL ARRAYS REAL + W2(1) * C...EXTERNAL FUNCTIONS REAL + SDOT,SNRM2 EXTERNAL + SDOT,SNRM2 * C...EXTERNAL SUBROUTINES EXTERNAL + SACCES,SCOPY,SDIAGS,SDIAGW,SEVFUN,SEVJAC,SFLAGS,SIDTS, + SODLM,SODPCR,SQRDC,SPODI,SSCAL,SUNPAC,SWDS,SXPY * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MIN,MOD,SQRT * C...DATA STATEMENTS DATA + ZERO,P0001,P1,P25,P5,P75,ONE,W2(1) + /0.0E0,0.00010E0,0.10E0,0.250E0, + 0.50E0,0.750E0,1.0E0,-1.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE FUNCTION. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ACCESS C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER INFORMATION C IS TO BE ACCESSED FROM THE WORK ARRAYS (ACCESS=TRUE) OR C STORED IN THEM (ACCESS=FALSE). C REAL ACTRED C THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES OF THE C WEIGHTED OBSERVATIONAL ERRORS. C REAL ACTRS C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C REAL ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL BETAC(NP) C THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. C REAL BETAN(NP) C THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C REAL BETAS(NP) C THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C LOGICAL CNVPAR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER PARAMETER C CONVERGENCE HAS BEEN ATTAINED (CNVPAR=.TRUE.) OR NOT C (CNVPAR=.FALSE.). C LOGICAL CNVSS C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER SUM-OF-SQUARES C CONVERGENCE HAS BEEN ATTAINED (CNVSS=.TRUE.) OR NOT C (CNVSS=.FALSE.). C REAL DDELT(N,M) C THE ARRAY (W*D)**2 * DELTA. C REAL DELTA(N,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C REAL DELTAN(N,M) C THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C REAL DELTAS(N,M) C THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DIDVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX WAS COMPUTED (DIDVCV=.TRUE.) C OR NOT (DIDVCV=.FALSE.). C REAL DIRDER C THE DIRECTIONAL DERIVATIVE. C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX SHOULD TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C REAL EPSMAC C THE VALUE OF MACHINE PRECISION. C REAL F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C REAL FJACB(N,NP) C THE JACOBIAN WITH RESPECT TO BETA. C REAL FJACX(N,M) C THE JACOBIAN WITH RESPECT TO X. C REAL FN(N) C THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON. C REAL FS(N) C THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON. C LOGICAL FSTITR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THIS IS THE C FIRST ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). C LOGICAL HEAD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE C HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). C INTEGER I C AN INDEXING VARIABLE. C INTEGER IDF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFLAG C AN INDICATOR VARIABLE, USED TO SPECIFY WHICH COMPUTATION REPORT C IS TO BE PRINTED. C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C INTEGER INT2 C THE NUMBER OF INTERNAL DOUBLING STEPS TAKEN. C LOGICAL INTDBL C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER INTERNAL C DOUBLING IS TO BE USED (INTDBL=.TRUE.) OR NOT (INTDBL=.FALSE.). C INTEGER IPR1 C THE VALUE OF THE FOURTH DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE INITIAL SUMMARY REPORT. C INTEGER IPR2 C THE VALUE OF THE THIRD DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE ITERATION REPORTS. C INTEGER IPR2F C THE VALUE OF THE SECOND DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FREQUENCY OF THE ITERATION REPORTS. C INTEGER IPR3 C THE VALUE OF THE FIRST DIGIT (FROM THE RIGHT) OF IPRINT, C WHICH CONTROLS THE FINAL SUMMARY REPORT. C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER ISTOPJ C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE JACOBIAN GIVEN THE CURRENT ESTIMATES C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER J C AN INDEX VARIABLE. C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JPVT C THE STARTING LOCATION IN IWORK OF C THE PIVOT VECTOR. C INTEGER JUNFIX C THE INDEX OF THE NEXT UNFIXED PARAMETER. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL LSTEP C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER A SUCCESSFUL C STEP HAS BEEN FOUND (LSTEP=.TRUE.) OR NOT (LSTEP=.FALSE.). C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE NUMBER OF ITERATIONS TAKEN. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NLMS C THE NUMBER OF LEVENBERG-MARQUARDT STEPS TAKEN. C INTEGER NNZW C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C REAL OLMAVG C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OMEGA C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C REAL ONE C THE VALUE 1.0E0. C REAL P0001 C THE VALUE 0.0001E0. C REAL P1 C THE VALUE 0.1E0. C REAL P25 C THE VALUE 0.25E0. C REAL P5 C THE VALUE 0.5E0. C REAL P75 C THE VALUE 0.75E0. C REAL PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL PNORM C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C REAL PRERED C THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C REAL PRERS C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER QRAUX C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C REAL RATIO C THE RATIO OF THE ACTUAL RELATIVE REDUCTION TO THE PREDICTED C RELATIVE REDUCTION IN THE SUM-OF-SQUARES. C REAL RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C REAL RNORM C THE NORM OF THE WEIGHTED OBSERVATIONAL ERRORS. C REAL RNORMN C THE NORM OF THE NEW WEIGHTED OBSERVATIONAL ERRORS. C REAL RNORMS C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C REAL RVAR C THE RESIDUAL VARIANCE. C REAL S(NP) C THE STEP FOR THE ESTIMATED BETA'S. C REAL SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SSF(NP) C THE SCALE USED FOR THE BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SSS(N+N*M) C THE WORK ARRAY USED PRIMARILY FOR COMPUTING VARIOUS C SUMS-OF-SQUARES. C REAL SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL T(N,M) C THE STEP FOR THE ESTIMATED DELTA'S. C REAL TAU C THE TRUST REGION DIAMETER. C REAL TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TEMP C A TEMPORARY STORAGE LOCATION. C REAL TEMP1 C A TEMPORARY STORAGE LOCATION. C REAL TEMP2 C A TEMPORARY STORAGE LOCATION. C INTEGER TFJACB C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB, C ALSO USED TO RETURN THE VARIANCE COVARIANCE MATRIX OF THE C ESTIMATORS OF THE PARAMETERS. C REAL TSNORM C THE NORM OF THE SCALED STEP. C REAL TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER U C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR TFJACB. C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WORK(LWORK) C THE REAL WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C REAL WSSDEL C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C REAL WSSEPS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C REAL W2(1) C THE VALUE USED TO INDICATE THAT THE DEFAULT VALUE C OF THE OBSERVATIONAL ERROR WEIGHTS IS TO BE USED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER WRK1 C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WRK2 C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY, C ALSO USED TO RETURN THE STANDARD ERRORS FOR THE PARAMETERS. C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL XPLUSD(N,M) C THE ARRAY X + DELTA. C REAL Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER YT C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SODMN * * C INITIALIZE NECESSARY VARIABLES * ACCESS = .TRUE. CALL SACCES(N,M,NP,WORK,LWORK,IWORK,LIWORK, + ACCESS, + JPVT,WRK1,TFJACB,OMEGA,YT,U,QRAUX,WRK2, + NNZW,NPP, + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,EPSMAC,NETA, + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS) RNORM = SQRT(WSS) CALL SFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR,DOVCV) * DIDVCV = .FALSE. INTDBL = .FALSE. LSTEP = .TRUE. HEAD = .TRUE. * FSTITR = .TRUE. * C PRINT INITIAL SUMMARY IF DESIRED * IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN IFLAG = 1 CALL SODPCR(HEAD,IFLAG,IPR1,FSTITR,DIDVCV,LUNRPT, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT,Y,W, + BETA,IFIXB,SSF,WORK(WRK2), + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO) END IF * C STOP IF INITIAL ESTIMATES ARE EXACT SOLUTION * IF (RNORM .EQ. ZERO) THEN INFO = 1 OLMAVG = ZERO GO TO 40 END IF * C MAIN LOOP * 10 CONTINUE * NITER = NITER + 1 RNORMS = RNORM * C EVALUATE JACOBIAN * CALL SEVJAC(FUN,JAC,ANAJAC,N,NP,NPP,M,BETAC,BETA, + IFIXB,IFIXX,LDIFX, + X,LDX,DELTA,N,XPLUSD,N, + SS,TT,LDTT,NETA,FN,SSS, + FJACB,N,ISODR,FJACX,N,W,NJEV,NFEV,ISTOPJ) IF (ISTOPJ.NE.0) THEN INFO = 50100 GO TO 200 END IF * C COMPUTE DDELT = (W*D)**2 * DELTA * CALL SWDS(N,M,W,WD,LDWD,DELTA,N,DDELT,N) CALL SWDS(N,M,W,WD,LDWD,DDELT,N,DDELT,N) * C SUB LOOP FOR C INTERNAL DOUBLING OR C COMPUTING NEW STEP WHEN OLD FAILED * 20 CONTINUE * C COMPUTE STEPS S AND T * CALL SODLM(N,NP,NPP,M, + F,FJACB,N,FJACX,N, + W,WD,LDWD,SS,TT,LDTT,DDELT, + ALPHA,TAU,EPSMAC, + SSS,WORK(WRK1),WORK(TFJACB),WORK(OMEGA),WORK(YT), + WORK(U),WORK(QRAUX),WORK(WRK2),IWORK(JPVT), + S,T,NLMS,RCOND,IRANK) OLMAVG = OLMAVG+NLMS * C COMPUTE BETAN = BETAC + S C DELTAN = DELTA + T * CALL SXPY(NPP,1,BETAC,NPP,S,NPP,BETAN,NPP) CALL SXPY(N,M,DELTA,N,T,N,DELTAN,N) * C COMPUTE NORM OF SCALED STEPS S AND T (TSNORM) * IF (NPP.GE.1) THEN CALL SDIAGS(NPP,1,SS,NPP,S,NPP,SSS,NPP) END IF CALL SDIAGS(N,M,TT,LDTT,T,N,SSS(NPP+1),N) TSNORM = SNRM2(NPP+N*M,SSS,1) * C COMPUTE SCALED PREDICTED REDUCTION * DO 30 I=1,N SSS(I) = SDOT(NPP,FJACB(I,1),N,S,1) + + SDOT(M,FJACX(I,1),N,T(I,1),N) 30 CONTINUE CALL SWDS(N,M,W,WD,LDWD,T,N,SSS(N+1),N) TEMP1 = SNRM2(N+N*M,SSS,1)/RNORM TEMP2 = SQRT(ALPHA)*TSNORM/RNORM PRERED = TEMP1**2+TEMP2**2/P5 * DIRDER = -(TEMP1**2+TEMP2**2) * C EVALUATE WEIGHTED EPSILONS AT NEW POINT * CALL SEVFUN(N,NP,M,BETAN,BETA,IFIXB,FUN, + X,LDX,Y,DELTAN,N,XPLUSD,N, + W,FN,NFEV,ISTOPF) IF (ISTOPF.LT.0) THEN * C SET INFO TO INDICATE USER HAS STOPPED THE COMPUTATIONS IN FUN * INFO = 51000 GO TO 200 ELSE IF (ISTOPF.GT.0) THEN * C SET NORM TO INDICATE STEP SHOULD BE REJECTED * RNORMN = RNORM/(P1*P75) ELSE * C COMPUTE NORM OF NEW WEIGHTED EPSILONS AND WEIGHTED DELTAS (RNORMN) * CALL SCOPY(N,FN,1,SSS,1) CALL SWDS(N,M,W,WD,LDWD,DELTAN,N,SSS(N+1),N) RNORMN = SNRM2(N+N*M,SSS,1) END IF * C COMPUTE SCALED ACTUAL REDUCTION * IF (P1*RNORMN.LT.RNORM) THEN ACTRED = ONE - (RNORMN/RNORM)**2 ELSE ACTRED = -ONE END IF * C COMPUTE RATIO OF ACTUAL REDUCTION TO PREDICTED REDUCTION * IF(PRERED .EQ. ZERO) THEN RATIO = ZERO ELSE RATIO = ACTRED/PRERED END IF * C CHECK ON LACK OF REDUCTION IN INTERNAL DOUBLING CASE * IF (INTDBL .AND. (RATIO.LT.P0001 .OR. RNORMN.GT.RNORMS)) THEN TAU = TAU*P5 ALPHA = ALPHA/P5 CALL SCOPY(NPP,BETAS,1,BETAN,1) CALL SCOPY(N*M,DELTAS,1,DELTAN,1) CALL SCOPY(N,FS,1,FN,1) ACTRED = ACTRS PRERED = PRERS RNORMN = RNORMS RATIO = P5 END IF * C UPDATE STEP BOUND * INTDBL = .FALSE. IF (RATIO.LT.P25) THEN IF (ACTRED.GE.ZERO) THEN TEMP = P5 ELSE TEMP = P5*DIRDER/(DIRDER+P5*ACTRED) END IF IF (P1*RNORMN.GE.RNORM .OR. TEMP.LT.P1) THEN TEMP = P1 END IF TAU = TEMP*MIN(TAU,TSNORM/P1) ALPHA = ALPHA/TEMP * ELSE IF (ALPHA.EQ.ZERO) THEN TAU = TSNORM/P5 * ELSE IF (RATIO.GE.P75 .AND. NLMS.LE.11) THEN * C STEP QUALIFIES FOR INTERNAL DOUBLING C - UPDATE TAU AND ALPHA C - SAVE INFORMATION FOR CURRENT POINT * INTDBL = .TRUE. * TAU = TSNORM/P5 ALPHA = ALPHA*P5 * CALL SCOPY(NPP,BETAN,1,BETAS,1) CALL SCOPY(N*M,DELTAN,1,DELTAS,1) CALL SCOPY(N,FN,1,FS,1) ACTRS = ACTRED PRERS = PRERED RNORMS = RNORMN END IF * C IF INTERNAL DOUBLING, SKIP CONVERGENCE CHECKS * IF (INTDBL .AND. TAU.GT.ZERO) THEN INT2 = INT2+1 GO TO 20 END IF * C CHECK ACCEPTANCE * IF (RATIO.GE.P0001) THEN CALL SCOPY(N,FN,1,F,1) CALL SCOPY(NPP,BETAN,1,BETAC,1) CALL SCOPY(N*M,DELTAN,1,DELTA,1) RNORM = RNORMN IF (NPP.GE.1) THEN CALL SDIAGS(NPP,1,SS,NPP,BETAC,NPP,SSS,NPP) END IF CALL SDIAGS(N,M,TT,LDTT,DELTA,N,SSS(NPP+1),N) PNORM = SNRM2(NPP+N*M,SSS,1) LSTEP = .TRUE. ELSE LSTEP = .FALSE. END IF * C TEST CONVERGENCE * INFO = 0 CNVSS = RNORM.EQ.ZERO + .OR. + (ABS(ACTRED).LE.SSTOL .AND. + PRERED.LE.SSTOL .AND. + P5*RATIO.LE.ONE) CNVPAR = TAU.LE.PARTOL*PNORM IF (CNVSS) INFO = 1 IF (CNVPAR) INFO = 2 IF (CNVSS .AND. CNVPAR) INFO = 3 * C PRINT ITERATION REPORT * IF (INFO.NE.0 .OR. LSTEP) THEN IF (IPR2.NE.0 .AND. LUNRPT.NE.0) THEN IF (IPR2F.EQ.1 .OR. MOD(NITER,IPR2F).EQ.1) THEN IFLAG = 2 CALL SUNPAC(NP,BETAC,BETA,IFIXB) WSS = RNORM*RNORM CALL SODPCR(HEAD,IFLAG,IPR2,FSTITR,DIDVCV,LUNRPT, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT,Y,W, + BETA,IFIXB,SSF,WORK(WRK2), + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO) FSTITR = .FALSE. END IF END IF END IF * C CHECK IF FINISHED * IF (INFO.EQ.0) THEN IF (LSTEP) THEN * C BEGIN NEXT INTERATION UNLESS A STOPPING CRITERIA HAS BEEN MET * IF (NITER.GE.MAXIT) THEN INFO = 4 ELSE GO TO 10 END IF ELSE * C STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET * GO TO 20 END IF END IF * 40 CONTINUE * IF (ISTOPF.GT.0) INFO = INFO + 100 * C COMPUTE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER * CALL SEVFUN(N,NP,M,BETAC,BETA,IFIXB,FUN, + X,LDX,Y,DELTA,N,XPLUSD,N, + W2,F,NFEV,ISTOPF) IF (ISTOPF.LT.0) THEN INFO = 51000 GO TO 200 END IF * C COMPUTE VARIANCE COVARIANCE MATRIX OF ESTIMATED PARAMETERS C IN UPPER TRIANGULAR PORTION OF WORK(TFJACB) IF REQUESTED * IF (DOVCV .AND. IRANK.EQ.0 .AND. ISTOPF.EQ.0) THEN * C EVALUATE JACOBIANS AT FINAL SOLUTION * CALL SEVJAC(FUN,JAC,ANAJAC,N,NP,NPP,M,BETAC,BETA, + IFIXB,IFIXX,LDIFX, + X,LDX,DELTA,N,XPLUSD,N, + SSF,TT,LDTT,NETA,FN,SSS, + FJACB,N,ISODR,FJACX,N,W,NJEV,NFEV,ISTOPJ) IF (ISTOPJ.NE.0) THEN INFO = 50100 GO TO 200 END IF IDF = 0 DO 70 I=1,N DO 50 J=1,NPP IF (FJACB(I,J).NE.ZERO) THEN IDF = IDF + 1 GO TO 70 END IF 50 CONTINUE DO 60 J=1,M IF (FJACX(I,J).NE.ZERO) THEN IDF = IDF + 1 GO TO 70 END IF 60 CONTINUE 70 CONTINUE * IF (ISODR) THEN * C PROBLEM IS ODR -- C SET UP OMEGA AND TFJACB C (VDTD = FJACX * INV(DT) WHERE DT = (W*D)**2) * CALL SIDTS(N,M, + W,WD,LDWD,ZERO,TT,LDTT,FJACX,N,WORK(WRK1),N) DO 90 I=1,N WORK(OMEGA-1+I) = + SQRT(ONE+SDOT(M,WORK(WRK1+I-1),N,FJACX(I,1),N)) DO 80 J=1,NPP WORK(TFJACB-1+I+(J-1)*N) = FJACB(I,J)/WORK(OMEGA-1+I) 80 CONTINUE 90 CONTINUE * ELSE * C PROBLEM IS OLS -- * CALL SCOPY(N*NPP,FJACB,1,WORK(TFJACB),1) * END IF * CALL SQRDC + (WORK(TFJACB),N,N,NPP,WORK(QRAUX),IWORK(JPVT),WORK(WRK2),0) CALL SPODI + (WORK(TFJACB),N,NPP,WORK(WRK2),1) * IF (IDF.GT.NPP) THEN IDF = IDF - NPP RVAR = RNORM*RNORM/IDF ELSE IDF = 0 RVAR = RNORM*RNORM END IF * CALL SSCAL + (N*NPP,RVAR,WORK(TFJACB),1) CALL SCOPY + (NPP,WORK(TFJACB),N+1,WORK(WRK2),1) IF (NP.GT.NPP) THEN JUNFIX = NPP-1 DO 100 J=NP-1,0,-1 IF (IFIXB(J+1).EQ.0) THEN WORK(WRK2+J) = ZERO ELSE WORK(WRK2+J) = SQRT(WORK(WRK2+JUNFIX)) JUNFIX = JUNFIX - 1 END IF 100 CONTINUE ELSE DO 110 J=0,NP-1 WORK(WRK2+J) = SQRT(WORK(WRK2+J)) 110 CONTINUE END IF * DIDVCV = .TRUE. * END IF * C STORE VARIOUS SCALARS IN WORK ARRAYS FOR RETURN TO USER * 200 OLMAVG = OLMAVG/NITER * C COMPUTE WEIGHTED EPSILONS AND WEIGHTED DELTAS FOR RETURN TO USER * CALL SDIAGW(N,1,W,F,N,SSS,N) WSSEPS = SDOT(N,SSS,1,SSS,1) CALL SWDS(N,M,W,WD,LDWD,DELTA,N,SSS(N+1),N) WSSDEL = SDOT(N*M,SSS(N+1),1,SSS(N+1),1) WSS = WSSEPS + WSSDEL * C COMPUTE ESTIMATED RESPONSE VARIABLE RETURN TO USER, I.E., C EST = OBS + EST * CALL SXPY(N,1,Y,N,F,N,FN,N) * ACCESS = .FALSE. CALL SACCES(N,M,NP,WORK,LWORK,IWORK,LIWORK, + ACCESS, + JPVT,WRK1,TFJACB,OMEGA,YT,U,QRAUX,WRK2, + NNZW,NPP, + JOB,PARTOL,SSTOL,MAXIT,TAUFAC,EPSMAC,NETA, + LUNRPT,IPR1,IPR2,IPR2F,IPR3, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + TAU,ALPHA,NITER,NFEV,NJEV,INT2,OLMAVG, + RCOND,IRANK,ACTRS,PNORM,PRERS,RNORMS) * C ENCODE EXISTANCE OF QUESTIONABLE RESULTS INTO INFO * IF (INFO.LE.9) THEN IF (MSGB(1).EQ.2 .OR. MSGX(1).EQ.2) THEN INFO = INFO + 1000 END IF IF (ISTOPF.NE.0) THEN INFO = INFO + 100 END IF IF (IRANK.GE.1) THEN IF (NPP.GT.IRANK) THEN INFO = INFO + 10 ELSE INFO = INFO + 20 END IF END IF END IF * C PRINT FINAL SUMMARY * IF (IPR3.NE.0 .AND. LUNRPT.NE.0) THEN IFLAG = 3 * CALL SODPCR(HEAD,IFLAG,IPR3,FSTITR,DIDVCV,LUNRPT, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT,Y,W, + BETA,IFIXB,SSF,WORK(WRK2), + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO) END IF * RETURN * END *SODPC1 SUBROUTINE SODPC1 + (IPR,LUNRPT, + ANAJAC,CHKJAC,INITD,RESTRT,ISODR,DOVCV, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT, + Y,W, + BETA,IFIXB,SSF, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS) C***BEGIN PROLOGUE SODPC1 C***REFER TO SODR,SODRC C***ROUTINES CALLED NONE C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE GENERATE INITIAL SUMMARY REPORT C***END PROLOGUE SODPC1 * C...SCALAR ARGUMENTS REAL + PARTOL,SSTOL,TAUFAC,WSS,WSSDEL,WSSEPS INTEGER + IPR,JOB,LDIFX,LDTT,LDWD,LDX,LUNRPT,M,MAXIT,N,NETA,NNZW,NP,NPP LOGICAL + ANAJAC,CHKJAC,DOVCV,INITD,ISODR,RESTRT * C...ARRAY ARGUMENTS REAL + BETA(NP),DELTA(N,M),SSF(NP),TT(LDTT,M),W(N),WD(LDWD,M), + X(LDX,M),Y(N) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NP+1),MSGX(M+1) * C...LOCAL SCALARS REAL + ONE,ZERO INTEGER + J,K,L,NPLM1 CHARACTER FMT1*90 * C...LOCAL ARRAYS CHARACTER TEMPC(10)*5 * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MIN * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0E0,1.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C REAL DELTA(N,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C CHARACTER*90 FMT1 C A CHARACTER VARIABLE USED FOR FORMATS. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C INTEGER IPR C THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER J C AN INDEXING VARIABLE. C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER K C AN INDEXING VARIABLE. C INTEGER L C AN INDEXING VARIABLE. C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NNZW C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPLM1 C THE NUMBER OF ITEMS TO PRINT PER LINE, MINUS ONE. C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C REAL ONE C THE VALUE 1.0E0. C REAL PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C REAL SSF(NP) C THE SCALE USED FOR THE BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C CHARACTER*5 TEMPC(10) C A TEMPORARY CHARACTER VECTOR. C REAL TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C REAL WSSDEL C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C REAL WSSEPS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SODPC1 * * C PRINT PROBLEM SIZE SPECIFICATION * WRITE (LUNRPT,1000) N,NNZW,M,NP,NPP * IF (IPR.GE.2) THEN * C PRINT INDEPENDENT VARIABLE DATA * IF (ISODR) THEN WRITE (LUNRPT,2010) ELSE WRITE (LUNRPT,2020) END IF NPLM1 = 1 DO 20 J = 1,M,NPLM1+1 IF (.NOT.ISODR) THEN L = MIN(M,J+NPLM1) - J + 1 WRITE (FMT1,7000) 6,L WRITE (LUNRPT,FMT1) (K,K=J,MIN(M,J+NPLM1)) WRITE (FMT1,8000) 5,L WRITE (LUNRPT,FMT1) WRITE (LUNRPT,2100) (X(1,K),X(N,K),K=J,MIN(M,J+NPLM1)) ELSE L = MIN(M,J+NPLM1) - J + 1 WRITE (FMT1,7000) 20,L WRITE (LUNRPT,FMT1) (K,K=J,MIN(M,J+NPLM1)) WRITE (FMT1,8000) 19,L WRITE (LUNRPT,FMT1) WRITE (LUNRPT,2200) (X(1,K),X(N,K),K=J,MIN(M,J+NPLM1)) IF (IFIXX(1,1).LT.0) THEN WRITE (LUNRPT,2300) (' NO',K=1,2*L) ELSE L = 0 DO 10 K=J,MIN(M,J+NPLM1) L = L + 1 IF (IFIXX(1,K).EQ.0) THEN TEMPC(2*L-1) = ' YES' ELSE TEMPC(2*L-1) = ' NO' END IF IF (LDIFX.EQ.1) THEN IF (IFIXX(1,K).EQ.0) THEN TEMPC(2*L) = ' YES' ELSE TEMPC(2*L) = ' NO' END IF ELSE IF (IFIXX(N,K).EQ.0) THEN TEMPC(2*L) = ' YES' ELSE TEMPC(2*L) = ' NO' END IF END IF 10 CONTINUE WRITE (LUNRPT,2300) (TEMPC(K),K=1,2*L) END IF WRITE (LUNRPT,2500) (DELTA(1,K),DELTA(N,K), + K=J,MIN(M,J+NPLM1)) IF (TT(1,1).LT.0) THEN WRITE (LUNRPT,2600) (ABS(TT(1,1)),ABS(TT(1,1)), + K=J,MIN(M,J+NPLM1)) ELSE IF (LDTT.EQ.1) THEN WRITE (LUNRPT,2600) (TT(1,K),TT(1,K), + K=J,MIN(M,J+NPLM1)) ELSE WRITE (LUNRPT,2600) (TT(1,K),TT(N,K), + K=J,MIN(M,J+NPLM1)) END IF END IF IF (WD(1,1).LT.0) THEN WRITE (LUNRPT,2700) (ABS(WD(1,1)),ABS(WD(1,1)), + K=J,MIN(M,J+NPLM1)) ELSE IF (LDWD.EQ.1) THEN WRITE (LUNRPT,2700) (WD(1,K),WD(1,K), + K=J,MIN(M,J+NPLM1)) ELSE WRITE (LUNRPT,2700) (WD(1,K),WD(N,K), + K=J,MIN(M,J+NPLM1)) END IF END IF END IF 20 CONTINUE * C PRINT DEPENDENT VARIABLE DATA AND OBSERVATION ERROR WEIGHTS * WRITE (LUNRPT,3000) WRITE (FMT1,8000) 19,1 WRITE (LUNRPT,FMT1) WRITE (LUNRPT,3100) Y(1),Y(N) IF (W(1).LT.ZERO) THEN WRITE (LUNRPT,3200) ONE,ONE ELSE WRITE (LUNRPT,3200) W(1),W(N) END IF * C PRINT FUNCTION PARAMETER DATA * WRITE (LUNRPT,4000) NPLM1 = 3 DO 50 J=1,NP,NPLM1+1 WRITE (LUNRPT,4100) (K,K=J,MIN(NP,J+NPLM1)) WRITE (LUNRPT,4200) (BETA(K),K=J,MIN(NP,J+NPLM1)) L = 0 IF (IFIXB(1).LT.0) THEN DO 30 K=J,MIN(NP,J+NPLM1) L = L + 1 TEMPC(L) = ' NO' 30 CONTINUE ELSE DO 40 K=J,MIN(NP,J+NPLM1) L = L + 1 IF (IFIXB(K).NE.0) THEN TEMPC(L) = ' NO' ELSE TEMPC(L) = ' YES' END IF 40 CONTINUE END IF WRITE (LUNRPT,4300) (TEMPC(K),K=1,L) IF (SSF(1).LT.ZERO) THEN WRITE (LUNRPT,4400) (ABS(SSF(1)),K=J,MIN(NP,J+NPLM1)) ELSE WRITE (LUNRPT,4400) (SSF(K),K=J,MIN(NP,J+NPLM1)) END IF 50 CONTINUE END IF * C PRINT JOB SPECS AND STOPPING CRITERIA * WRITE (LUNRPT,5000) JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT IF (RESTRT) THEN WRITE (LUNRPT,5110) ELSE WRITE (LUNRPT,5120) END IF IF (ISODR) THEN IF (INITD) THEN WRITE (LUNRPT,5211) ELSE WRITE (LUNRPT,5212) END IF ELSE WRITE (LUNRPT,5220) END IF IF (DOVCV) THEN WRITE (LUNRPT,5310) ELSE WRITE (LUNRPT,5320) END IF IF (ANAJAC) THEN WRITE (LUNRPT,5410) IF (CHKJAC) THEN WRITE (LUNRPT,5411) IF (MSGB(1).EQ.2 .OR. MSGX(1).EQ.2) THEN WRITE (LUNRPT,5412) ELSE WRITE (LUNRPT,5413) END IF ELSE WRITE (LUNRPT,5414) END IF ELSE WRITE (LUNRPT,5420) END IF IF (ISODR) THEN WRITE (LUNRPT,5510) ELSE WRITE (LUNRPT,5520) END IF * C PRINT INITIAL SUM OF SQUARES * WRITE (LUNRPT,6000) WRITE (LUNRPT,6100) WSS IF (ISODR) THEN WRITE (LUNRPT,6200) WSSDEL WRITE (LUNRPT,6300) WSSEPS END IF * RETURN * C FORMAT STATEMENTS * 1000 FORMAT + (///' PROBLEM SIZE:'/ + ' -------------'// + ' NUMBER OF OBSERVATIONS ',I5/ + ' NUMBER OF OBSERVATIONS WITH NONZERO WEIGHTS ',I5/ + ' NUMBER OF COLUMNS OF DATA IN INDEPENDENT VARIABLE ',I5/ + ' NUMBER OF FUNCTION PARAMETERS ',I5/ + ' NUMBER OF UNFIXED FUNCTION PARAMETERS ',I5) 2010 FORMAT + (///' INDEPENDENT VARIABLE AND DELTA WEIGHT SUMMARY:'/ + ' ----------------------------------------------') 2020 FORMAT + (///' INDEPENDENT VARIABLE SUMMARY:'/ + ' -----------------------------') 2100 FORMAT + (' X - ', 6E13.5) 2200 FORMAT + (' X - ', 6E13.5) 2300 FORMAT + (' FIXED - ', 6(8X,A5)) 2500 FORMAT + (' INITIAL DELTA - ', 6E13.5) 2600 FORMAT + (' DELTA SCALE - ', 6E13.5) 2700 FORMAT + (' DELTA WEIGHTS - ', 6E13.5) 3000 FORMAT + (///' DEPENDENT VARIABLE AND OBSERVATIONAL ERROR WEIGHT', + ' SUMMARY:'/ + ' -------------------------------------------------', + '---------'/) 3100 FORMAT + (' Y - ', 6E13.5) 3200 FORMAT + (' OBS. ERROR WTS. - ', 6E13.5) 4000 FORMAT + (///' FUNCTION PARAMETER SUMMARY:'/ + ' ---------------------------') 4100 FORMAT + (/' INDEX - ', 5I16) 4200 FORMAT + (' INITIAL BETA - ', 5E16.8) 4300 FORMAT + (' FIXED - ', 5(11X,A5)) 4400 FORMAT + (' BETA SCALE - ', 5E16.8) 5000 FORMAT + (///' CONTROL VALUES AND STOPPING CRITERIA:'/ + ' --------------------------------------'// + ' * '/ + ' JOB NDIGIT TAUFAC SSTOL PARTOL MAXIT'/ + 1X,I6.5,5X,I5,3E10.2,I7//' *') 5110 FORMAT + (' A. FIT IS A RESTART.') 5120 FORMAT + (' A. FIT IS NOT A RESTART.') 5211 FORMAT + (' B. DELTAS ARE INITIALIZED TO ZERO.') 5212 FORMAT + (' B. DELTAS ARE INITIALIZED BY USER.') 5220 FORMAT + (' B. DELTAS ARE FIXED AT ZERO.') 5310 FORMAT + (' C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS'/ + ' WILL BE COMPUTED AT THE SOLUTION.') 5320 FORMAT + (' C. THE COVARIANCE MATRIX OF THE PARAMETER ESTIMATORS'/ + ' WILL NOT BE COMPUTED AT THE SOLUTION.') 5410 FORMAT + (' D. DERIVATIVES ARE SUPPLIED BY USER.') 5411 FORMAT + (' USER-SUPPLIED DERIVATIVES WERE CHECKED.') 5412 FORMAT + (' THE CORRECTNESS OF SOME OF THE DERIVATIVES IS'/ + ' QUESTIONABLE. SEE ERROR MESSAGES FOR DETAILS.') 5413 FORMAT + (' THE DERIVATIVES APPEAR TO BE CORRECT.') 5414 FORMAT + (' USER-SUPPLIED DERIVATIVES WERE NOT CHECKED.') 5420 FORMAT + (' D. DERIVATIVES ARE COMPUTED BY FINITE DIFFERENCES.') 5510 FORMAT + (' E. FIT IS BY METHOD OF ORTHOGONAL DISTANCE REGRESSION.') 5520 FORMAT + (' E. FIT IS BY METHOD OF ORDINARY LEAST SQUARES.') 6000 FORMAT + (///' INITIAL SUMS OF SQUARES:'/ + ' ------------------------'/) 6100 FORMAT + ( ' SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS ', E17.8) 6200 FORMAT + ( ' SUM OF SQUARED WEIGHTED DELTAS ', E17.8) 6300 FORMAT + ( ' SUM OF SQUARED WEIGHTED EPSILONS ', E17.8) 7000 FORMAT + ('(/',I2,'X,',I2,'('' COLUMN '',I3,'' ''))') 8000 FORMAT + ('(',I2,'X,',I2,'('' OBS 1 OBS N''))') END *SODPC2 SUBROUTINE SODPC2 + (IPR,FSTITR,LUNRPT,NP, + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,BETA) C***BEGIN PROLOGUE SODPC2 C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE GENERATE ITERATION REPORTS C***END PROLOGUE SODPC2 * C...SCALAR ARGUMENTS REAL + ACTRED,ALPHA,PNORM,PRERED,TAU,WSS INTEGER + IPR,LUNRPT,NFEV,NITER,NP LOGICAL + FSTITR * C...ARRAY ARGUMENTS REAL + BETA(NP) * C...LOCAL SCALARS REAL + RATIO,ZERO INTEGER + J,K,L CHARACTER GN*3 * C...INTRINSIC FUNCTIONS INTRINSIC + MIN * C...DATA STATEMENTS DATA + ZERO + /0.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL ACTRED C THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C REAL ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL FSTITR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THIS IS THE C FIRST ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). C CHARACTER*3 GN C THE CHARACTER VARIABLE USED TO INDICATE WHETHER A GAUSS-NEWTON C STEP WAS TAKEN. C INTEGER IPR C THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED. C INTEGER J C AN INDEXING VARIABLE. C INTEGER K C AN INDEXING VARIABLE. C INTEGER L C AN INDEXING VARIABLE. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE NUMBER OF ITERATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL PNORM C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C REAL PRERED C THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C REAL RATIO C THE RATIO OF TAU TO PNORM. C REAL TAU C THE TRUST REGION DIAMETER. C REAL WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SODPC2 * * IF (FSTITR) THEN IF (IPR.EQ.1) THEN WRITE (LUNRPT,1120) ELSE WRITE (LUNRPT,1130) END IF END IF IF (ALPHA.EQ.ZERO) THEN GN = 'YES' ELSE GN = ' NO' END IF IF (PNORM.NE.ZERO) THEN RATIO = TAU/PNORM ELSE RATIO = ZERO END IF IF (IPR.EQ.1) THEN WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + RATIO,GN ELSE J = 1 K = MIN(3,NP) IF (J.EQ.K) THEN WRITE (LUNRPT,1141) NITER,NFEV,WSS,ACTRED,PRERED, + RATIO,GN,J,BETA(J) ELSE WRITE (LUNRPT,1142) NITER,NFEV,WSS,ACTRED,PRERED, + RATIO,GN,J,K,(BETA(L),L=J,K) END IF IF (NP.GT.3) THEN DO 10 J=4,NP,3 K = MIN(J+2,NP) IF (J.EQ.K) THEN WRITE (LUNRPT,1151) J,BETA(J) ELSE WRITE (LUNRPT,1152) J,K,(BETA(L),L=J,K) END IF 10 CONTINUE END IF END IF * RETURN * C FORMAT STATEMENTS * 1120 FORMAT + (// + ' CUM. ACT. REL. PRED. REL.'/ + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + ' G-N'/ + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + ' TAU/PNORM STEP'/ + ' ---- ------ ----------- ----------- -----------', + ' --------- ----'/) 1130 FORMAT + (// + ' CUM. ACT. REL. PRED. REL.'/ + ' IT. NO. FN WEIGHTED SUM-OF-SQS SUM-OF-SQS', + ' G-N BETA -------------->'/ + ' NUM. EVALS SUM-OF-SQS REDUCTION REDUCTION', + ' TAU/PNORM STEP INDEX VALUE'/ + ' ---- ------ ----------- ----------- -----------', + ' --------- ---- ----- -----'/) 1141 FORMAT + (1X,I4,I8,1X,E12.5,2E13.4,E11.3,3X,A3,7X,I3,3E16.8) 1142 FORMAT + (1X,I4,I8,1X,E12.5,2E13.4,E11.3,3X,A3,1X,I3,' TO',I3,3E16.8) 1151 FORMAT + (76X,I3,E16.8) 1152 FORMAT + (70X,I3,' TO',I3,3E16.8) END *SODPC3 SUBROUTINE SODPC3 + (IPR,LUNRPT, + N,M,NP,NPP, + INFO,NITER,NFEV,NJEV,RCOND,IRANK, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + BETA,SDBETA,IFIXB,F,ISODR,DIDVCV,DOVCV,ANAJAC,DELTA) C***BEGIN PROLOGUE SODPC3 C***REFER TO SODR,SODRC C***ROUTINES CALLED NONE C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE GENERATE FINAL SUMMARY REPORT C***END PROLOGUE SODPC3 * C...SCALAR ARGUMENTS REAL + RCOND,RVAR,WSS,WSSDEL,WSSEPS INTEGER + IDF,INFO,IPR,IRANK,LUNRPT,M,N,NFEV,NITER,NJEV,NP,NPP LOGICAL + ANAJAC,DIDVCV,DOVCV,ISODR * C...ARRAY ARGUMENTS REAL + BETA(NP),DELTA(N,M),F(N),SDBETA(NP) INTEGER + IFIXB(NP) * C...LOCAL SCALARS INTEGER + D1,D2,D3,D4,D5,I,J,K,L,LAST,MAXLST,NPLM1 CHARACTER FMT1*90 * C...INTRINSIC FUNCTIONS INTRINSIC + MIN,MOD * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER D1 C THE FIRST DIGIT OF INFO. C INTEGER D2 C THE SECOND DIGIT OF INFO. C INTEGER D3 C THE THIRD DIGIT OF INFO. C INTEGER D4 C THE FOURTH DIGIT OF INFO. C INTEGER D5 C THE FIFTH DIGIT OF INFO. C REAL DELTA(N,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DIDVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX WAS COMPUTED (DIDVCV=.TRUE.) C OR NOT (DIDVCV=.FALSE.). C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C REAL F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C CHARACTER*90 FMT1 C A CHARACTER VARIABLE USED FOR FORMATS. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IDF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C INTEGER IPR C THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED. C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER J C AN INDEXING VARIABLE. C INTEGER K C AN INDEXING VARIABLE. C INTEGER L C AN INDEXING VARIABLE. C INTEGER LAST C THE LAST ROW OF THE GIVEN ARRAY TO BE PRINTED. C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXLST C THE MAXIMUM NUMBER OF ITEMS TO BE PRINTED. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE NUMBER OF ITERATIONS. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPLM1 C THE NUMBER OF ITEMS TO BE PRINTED PER LINE, MINUS ONE. C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C REAL RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C REAL RVAR C THE RESIDUAL VARIANCE. C REAL SDBETA(NP) C THE STANDARD ERRORS OF THE ESTIMATED PARAMETERS. C REAL WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C REAL WSSDEL C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C REAL WSSEPS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. * * C***FIRST EXECUTABLE STATEMENT SODPC3 * * D1 = INFO/10000 D2 = MOD(INFO,10000)/1000 D3 = MOD(INFO,1000)/100 D4 = MOD(INFO,100)/10 D5 = MOD(INFO,10) * C PRINT STOPPING CONDITIONS * WRITE (LUNRPT,1000) INFO IF (D1.EQ.5) THEN IF (D2.NE.0) THEN WRITE (LUNRPT,1110) ELSE IF (D3.NE.0) THEN WRITE (LUNRPT,1115) END IF ELSE IF (D5.EQ.1) THEN WRITE (LUNRPT,1120) ELSE IF (D5.EQ.2) THEN WRITE (LUNRPT,1130) ELSE IF (D5.EQ.3) THEN WRITE (LUNRPT,1140) ELSE IF (D5.EQ.4) THEN WRITE (LUNRPT,1150) ELSE WRITE (LUNRPT,1160) END IF * C PRINT WARNING DIAGNOSTICS * IF (D2.NE.0 .OR. D3.NE.0 .OR. D4.NE.0) THEN WRITE (LUNRPT,1210) IF (D2.NE.0) THEN IF (D3.NE.0 .OR. D4.NE.0) THEN WRITE (LUNRPT,1220) ', AND' ELSE WRITE (LUNRPT,1220) '. ' END IF END IF IF (D3.NE.0) THEN IF (D4.NE.0) THEN WRITE (LUNRPT,1230) ', AND' ELSE WRITE (LUNRPT,1230) '. ' END IF END IF IF (D4.EQ.1) THEN WRITE (LUNRPT,1240) END IF IF (D4.EQ.2) THEN WRITE (LUNRPT,1250) END IF END IF END IF * C PRINT MISC. STOPPING INFO * IF (ANAJAC) THEN WRITE (LUNRPT,1300) NITER,NFEV,NJEV,RCOND,IRANK ELSE WRITE (LUNRPT,1400) NITER,NFEV,RCOND,IRANK END IF * C PRINT FINAL SUM OF SQUARES * WRITE (LUNRPT,2000) WRITE (LUNRPT,2100) WSS IF (ISODR) THEN WRITE (LUNRPT,2200) WSSDEL WRITE (LUNRPT,2300) WSSEPS END IF IF (DIDVCV) THEN WRITE (LUNRPT,2400) RVAR WRITE (LUNRPT,2500) IDF END IF * NPLM1 = 3 * C PRINT ESTIMATED BETA'S, AND, C IF, FULL RANK, THEIR STANDARD ERRORS * WRITE (LUNRPT,3000) IF (DIDVCV) THEN WRITE (LUNRPT,7300) * DO 10 J=1,NP IF (NP.EQ.NPP) THEN WRITE (LUNRPT,8100) J,BETA(J),SDBETA(J) ELSE IF (IFIXB(J).EQ.0) THEN WRITE (LUNRPT,8400) J,BETA(J) ELSE WRITE (LUNRPT,8100) J,BETA(J),SDBETA(J) END IF END IF 10 CONTINUE ELSE IF (DOVCV) WRITE (LUNRPT,7400) IF (NP.EQ.1) THEN WRITE (LUNRPT,7100) ELSE WRITE (LUNRPT,7200) END IF * DO 20 J=1,NP,NPLM1+1 K = MIN(J+NPLM1,NP) IF (K.EQ.J) THEN WRITE (LUNRPT,8100) J,BETA(J) ELSE WRITE (LUNRPT,8200) J,K,(BETA(L),L=J,K) END IF 20 CONTINUE END IF * C PRINT ESTIMATED EPSILON'S AND DELTA'S * MAXLST = 32 IF (IPR.GE.2 .OR. N.LT.MAXLST) THEN LAST = N ELSE LAST = MAXLST END IF * C PRINT EPSILON'S AND DELTA'S TOGETHER IN A COLUMN IF THE NUMBER OF C COLUMNS OF DATA IN DELTA IS LESS THAN OR EQUAL TO THREE. * IF (ISODR .AND. M.LE.3) THEN WRITE (LUNRPT,4100) WRITE (FMT1,9100) M WRITE (LUNRPT,FMT1) (J,J=1,M) DO 30 I=1,LAST WRITE (LUNRPT,4110) I,F(I),(DELTA(I,J),J=1,M) 30 CONTINUE IF (N.GT.LAST) THEN IF (N.LE.LAST+4) THEN DO 40 I=LAST+1,N WRITE (LUNRPT,4110) I,F(I),(DELTA(I,J),J=1,M) 40 CONTINUE ELSE WRITE (FMT1,9200) M+1 WRITE (LUNRPT,FMT1) WRITE (LUNRPT,FMT1) WRITE (LUNRPT,FMT1) WRITE (LUNRPT,4110) N,F(N),(DELTA(N,J),J=1,M) END IF END IF ELSE * C PRINT EPSILON'S AND DELTA'S SEPARATELY * C PRINT EPSILON'S * WRITE (LUNRPT,4200) IF (LAST.EQ.1) THEN WRITE (LUNRPT,7100) ELSE WRITE (LUNRPT,7200) END IF DO 50 I=1,LAST,NPLM1+1 K = MIN(I+NPLM1,LAST) IF (I.EQ.K) THEN WRITE (LUNRPT,8100) I,F(I) ELSE WRITE (LUNRPT,8200) I,K,(F(L),L=I,K) END IF 50 CONTINUE IF (N.GT.LAST) THEN IF (N.EQ.LAST+1) THEN WRITE (LUNRPT,8100) N,F(N) ELSE IF (N.GT.LAST+1) THEN WRITE (LUNRPT,8300) N,F(N) END IF END IF * C PRINT DELTA'S * IF (ISODR) THEN DO 70 J=1,M WRITE (LUNRPT,4300) J IF (LAST.EQ.1) THEN WRITE (LUNRPT,7100) ELSE WRITE (LUNRPT,7200) END IF DO 60 I=1,LAST,NPLM1+1 K = MIN(I+NPLM1,LAST) IF (I.EQ.K) THEN WRITE (LUNRPT,8100) I,DELTA(I,J) ELSE WRITE (LUNRPT,8200) I,K,(DELTA(L,J),L=I,K) END IF 60 CONTINUE IF (N.EQ.LAST+1) THEN WRITE (LUNRPT,8100) N,DELTA(N,J) ELSE IF (N.GT.LAST+1) THEN WRITE (LUNRPT,8300) N,DELTA(N,J) END IF 70 CONTINUE END IF END IF * RETURN * C FORMAT STATEMENTS * 1000 FORMAT + (///' STOPPING CONDITION (INFO = ',I6,'):'/ + ' -----------------------------------'/) 1110 FORMAT + ( ' THE COMPUTATIONS WERE STOPPED BY THE USER DURING'/ + ' THE EVALUATION OF THE FUNCTION') 1115 FORMAT + ( ' THE COMPUTATIONS WERE STOPPED BY THE USER DURING'/ + ' THE EVALUATION OF THE JACOBIAN') 1120 FORMAT + ( ' THE RELATIVE CHANGE IN THE SUM OF THE SQUARED'/ + ' WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL') 1130 FORMAT + ( ' THE RELATIVE CHANGE IN THE NORM OF BETA AND DELTA'/ + ' IS LESS THAN PARTOL') 1140 FORMAT + ( ' THE RELATIVE CHANGE IN THE SUM OF THE SQUARED'/ + ' WEIGHTED OBSERVATIONAL ERRORS IS LESS THAN SSTOL'/ + ' AND'/ + ' THE RELATIVE CHANGE IN THE NORM OF BETA AND DELTA'/ + ' IS LESS THAN PARTOL') 1150 FORMAT + ( ' MAXIMUM NUMBER OF ITERATIONS REACHED') 1160 FORMAT + ( ' ERROR. PLEASE CHECK WITH AUTHORS.') 1210 FORMAT + (/ ' NOTE:'// + ' THE RESULTS FROM ODRPACK ARE QUESTIONABLE BECAUSE'/) 1220 FORMAT + ( ' THE ODRPACK JACOBIAN MATRIX CHECKING PROCEDURE HAS '/ + ' DETERMINED THAT THE CORRECTNESS OF THE USER-SUPPLIED'/ + ' JACOBIAN MATRICES IS QUESTIONABLE',A5/) 1230 FORMAT + ( ' THE MOST RECENTLY TRIED STEP WAS REJECTED BY THE '/ + ' USER AS INDICATED BY THE VALUE OF VARIABLE ISTOPF '/ + ' RETURNED FROM USER-SUPPLIED SUBROUTINE FUN',A5/) 1240 FORMAT + ( ' THE JACOBIAN OF THE MODEL FUNCTION WITH RESPECT TO '/ + ' THE FUNCTION PARAMETERS (BETA) IS NOT FULL RANK AT '/ + ' THE SOLUTION. ') 1250 FORMAT + ( ' THE RESULTS OF THE MODEL FUNCTION AND/OR ITS '/ + ' DERIVATIVES ARE UNAFFECTED BY CHANGES IN THE UNFIXED'/ + ' FUNCTION PARAMETERS (BETA), INDICATING A PROBABLE '/ + ' ERROR IN USER-SUPPLIED SUBROUTINES FUN AND/OR JAC.'/) 1300 FORMAT + (/' CONDITION', + ' '/ + ' NUMBER OF NUMBER OF NUMBER OF NUMBER', + ' RANK'/ + ' ITERATIONS FN EVALS JAC EVALS (INVERSE)', + ' DEFICIENCY'/ + 6X,I10,2I11,E11.4,6X,I6) 1400 FORMAT + (/' CONDITION '/ + ' NUMBER OF NUMBER OF NUMBER RANK'/ + ' ITERATIONS FN EVALS (INVERSE) DEFICIENCY'/ + 6X,I10,I11,E11.4,6X,I6) 2000 FORMAT + (///' FINAL SUMS OF SQUARES:'/ + ' ----------------------'/) 2100 FORMAT + ( ' SUM OF SQUARED WEIGHTED OBSERVATIONAL ERRORS ', E17.8) 2200 FORMAT + ( ' SUM OF SQUARED WEIGHTED DELTAS ', E17.8) 2300 FORMAT + ( ' SUM OF SQUARED WEIGHTED EPSILONS ', E17.8) 2400 FORMAT + (/ ' ESTIMATED RESIDUAL VARIANCE ', E17.8) 2500 FORMAT + ( ' (',I5,' DEGREES OF FREEDOM)') 3000 FORMAT + (///' ESTIMATED BETA(J), J = 1, ..., NP:'/ + ' ----------------------------------') 4100 FORMAT + (///' ESTIMATED EPSILON(I) AND DELTA(I,*), I = 1, ..., N:'/ + ' ---------------------------------------------------') 4110 FORMAT(1X,I5,5E16.8) 4200 FORMAT + (///' ESTIMATED EPSILON(I), I = 1, ..., N:'/ + ' ------------------------------------') 4300 FORMAT + (///' ESTIMATED DELTA(I,',I3,'), I = 1, ..., N:'/ + ' --------------------------------------') 7100 FORMAT + (/' INDEX VALUE') 7200 FORMAT + (/' INDEX VALUE -------------->') 7300 FORMAT + (/' J BETA(J) STD. DEV. BETA(J)') 7400 FORMAT + (/' N.B. STANDARD ERRORS OF THE ESTIMATED BETAS WERE NOT'/ + ' COMPUTED BECAUSE EITHER THE JACOBIAN IS NOT FULL'/ + ' RANK AT THE SOLUTION, OR THE MOST RECENTLY TRIED'/ + ' VALUES OF BETA AND/OR X+DELTA WERE UNACCEPTABLE.') 8100 FORMAT + (9X,I5,1X,E16.8,6X,E16.8) 8200 FORMAT + (1X,I5,' TO',I5,1X,7E16.8) 8300 FORMAT + (1X,' ... TO',I5,1X,' ... ',E16.8) 8400 FORMAT + (9X,I5,1X,E16.8,17X,'FIXED') 9100 FORMAT + ('(/'' I EPSILON(I)'',',I1, + '('' DELTA(I,'',I1,'')''))') 9200 FORMAT('(5X,''.'',',I1,'(3X,''.'',12X))') END *SODPCR SUBROUTINE SODPCR + (HEAD,IFLAG,IPR,FSTITR,DIDVCV,LUNRPT, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT,Y,W, + BETA,IFIXB,SSF,SDBETA, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + NITER,NFEV,NJEV,ACTRED,PRERED, + TAU,PNORM,ALPHA,F,RCOND,IRANK,INFO) C***BEGIN PROLOGUE SODPCR C***REFER TO SODR,SODRC C***ROUTINES CALLED SFLAGS,SODPC1,SODPC2,SODPC3,SODPHD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE GENERATE COMPUTATION REPORTS C***END PROLOGUE SODPCR * C...SCALAR ARGUMENTS REAL + ACTRED,ALPHA,PARTOL,PNORM,PRERED,RCOND,RVAR, + SSTOL,TAU,TAUFAC,WSS,WSSDEL,WSSEPS INTEGER + IDF,IFLAG,INFO,IPR,IRANK,JOB,LDIFX,LDTT,LDWD,LDX,LUNRPT,M, + MAXIT,N,NETA,NFEV,NITER,NJEV,NNZW,NP,NPP LOGICAL + ANAJAC,CHKJAC,DIDVCV,DOVCV,FSTITR,HEAD,INITD,ISODR,RESTRT * C...ARRAY ARGUMENTS REAL + BETA(NP),DELTA(N,M),F(N), + SDBETA(NP),SSF(NP),TT(LDTT,M),W(N),WD(LDWD,M),X(LDX,M), + Y(N) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),MSGB(NP+1),MSGX(M+1) * C...LOCAL SCALARS CHARACTER TYP*3 * C...EXTERNAL SUBROUTINES EXTERNAL + SFLAGS,SODPC1,SODPC2,SODPC3,SODPHD * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL ACTRED C THE ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C REAL ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C LOGICAL ANAJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE JACOBIANS C ARE COMPUTED BY FINITE DIFFERENCES (ANAJAC=.FALSE.) OR NOT C (ANAJAC=.TRUE.). C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL CHKJAC C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER- C SUPPLIED JACOBIANS ARE TO BE CHECKED (CHKJAC=.TRUE.) OR NOT C (CHKJAC=.FALSE.). C REAL DELTA(N,M) C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C LOGICAL DIDVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX WAS COMPUTED (DIDVCV=.TRUE.) C OR NOT (DIDVCV=.FALSE.). C LOGICAL DOVCV C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE C VARIANCE COVARIANCE MATRIX IS TO BE COMPUTED (DOVCV=.TRUE.) C OR NOT (DOVCV=.FALSE.). C REAL F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C LOGICAL FSTITR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THIS IS THE C FIRST ITERATION (FSTITR=.TRUE.) OR NOT (FSTITR=.FALSE.). C LOGICAL HEAD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE C HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). C INTEGER IDF C THE DEGREES OF FREEDOM OF THE FIT, EQUAL TO THE NUMBER OF C OBSERVATIONS WITH NONZERO WEIGHTED DERIVATIVES MINUS THE C NUMBER OF PARAMETERS BEING ESTIMATED. C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFLAG C AN INDICATOR VARIABLE, USED HERE TO DESIGNATE WHICH PART OF C THE REPORT IS TO BE PRINTED. C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C LOGICAL INITD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE DELTA'S C ARE TO BE INITIALIZED TO ZERO (INITD=.TRUE.) OR WHETHER THEY C ARE TO BE INITIALIZED TO THE VALUES PASSED VIA THE FIRST N BY M C ELEMENTS OF ARRAY WORK (INITD=.FALSE.). C INTEGER IPR C THE VALUE WHICH CONTROLS THE REPORT BEING PRINTED. C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS. C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NITER C THE NUMBER OF ITERATIONS. C INTEGER NJEV C THE NUMBER OF JACOBIAN EVALUATIONS. C INTEGER NNZW C THE NUMBER OF NONZERO OBSERVATIONAL ERROR WEIGHTS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C REAL PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL PNORM C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C REAL PRERED C THE PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C REAL RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C LOGICAL RESTRT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE CALL IS C A RESTART (RESTRT=TRUE) OR NOT (RESTRT=FALSE). C REAL RVAR C THE RESIDUAL VARIANCE. C REAL SDBETA(NP) C THE STANDARD DEVIATIONS OF THE ESTIMATED BETA'S. C REAL SSF(NP) C THE SCALE USED FOR THE BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TAU C THE TRUST REGION DIAMETER. C REAL TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C CHARACTER*3 TYP C THE CHARACTER STRING ODR OR OLS. C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WSS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C REAL WSSDEL C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C REAL WSSEPS C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) * * C***FIRST EXECUTABLE STATEMENT SODPCR * * CALL SFLAGS(JOB,RESTRT,INITD,ANAJAC,CHKJAC,ISODR,DOVCV) * IF (HEAD) THEN CALL SODPHD(HEAD,LUNRPT) ELSE IF (IFLAG.NE.2 .OR. FSTITR) THEN WRITE (LUNRPT,1000) END IF IF (ISODR) THEN TYP = 'ODR' ELSE TYP = 'OLS' END IF * C PRINT INITIAL SUMMARY * IF (IFLAG.EQ.1) THEN IF (RESTRT) THEN WRITE (LUNRPT,1100) TYP ELSE WRITE (LUNRPT,1200) TYP CALL SODPC1 + (IPR,LUNRPT, + ANAJAC,CHKJAC,INITD,RESTRT,ISODR,DOVCV, + MSGB,MSGX, + N,M,NP,NPP,NNZW, + X,LDX,IFIXX,LDIFX,DELTA,WD,LDWD,TT,LDTT, + Y,W, + BETA,IFIXB,SSF, + JOB,NETA,TAUFAC,SSTOL,PARTOL,MAXIT, + WSS,WSSDEL,WSSEPS) END IF * C PRINT ITERATION REPORTS * ELSE IF (IFLAG.EQ.2) THEN * IF (FSTITR) THEN WRITE (LUNRPT,1300) TYP END IF CALL SODPC2 + (IPR,FSTITR,LUNRPT,NP, + NITER,NFEV,WSS,ACTRED,PRERED,ALPHA,TAU,PNORM,BETA) * C PRINT FINAL SUMMARY * ELSE IF (IFLAG.EQ.3) THEN * WRITE (LUNRPT,1400) TYP CALL SODPC3 + (IPR,LUNRPT, + N,M,NP,NPP, + INFO,NITER,NFEV,NJEV,RCOND,IRANK, + WSS,WSSDEL,WSSEPS,RVAR,IDF, + BETA,SDBETA,IFIXB,F,ISODR,DIDVCV,DOVCV,ANAJAC,DELTA) END IF * RETURN * C FORMAT STATEMENTS * 1000 FORMAT(//) 1100 FORMAT + (////' RESTART OF FIT BY METHOD OF ',A3/ + ' ===============================') 1200 FORMAT + (////' INITIAL SUMMARY FOR FIT BY METHOD OF ',A3/ + ' ========================================') 1300 FORMAT + (//' ITERATION REPORTS FOR FIT BY METHOD OF ',A3/ + ' ==========================================') 1400 FORMAT + (////' FINAL SUMMARY FOR FIT BY METHOD OF ',A3/ + ' ======================================') END *SODPE1 SUBROUTINE SODPE1 + (UNIT,D1,D2,D3,D4,D5, + N, + LDSCLD,LDWD, + LWKMN,LIWKMN) C***BEGIN PROLOGUE SODPE1 C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE PRINT ERROR REPORTS. C***END PROLOGUE SODPE1 * C...SCALAR ARGUMENTS INTEGER + D1,D2,D3,D4,D5,LDSCLD,LDWD,LIWKMN,LWKMN,N,UNIT * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER D1 C THE FIRST DIGIT OF INFO. C INTEGER D2 C THE SECOND DIGIT OF INFO. C INTEGER D3 C THE THIRD DIGIT OF INFO. C INTEGER D4 C THE FOURTH DIGIT OF INFO. C INTEGER D5 C THE FIFTH DIGIT OF INFO. C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER UNIT C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. * * C***FIRST EXECUTABLE STATEMENT SODPE1 * * C PRINT APPROPRIATE MESSAGES FOR ERRORS IN PROBLEM SPECIFICATION C PARAMETERS * IF (D1.EQ.1) THEN IF (D2.NE.0) THEN WRITE(UNIT,1100) END IF IF (D3.NE.0) THEN WRITE(UNIT,1200) END IF IF (D4.NE.0) THEN WRITE(UNIT,1300) END IF * C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DIMENSION SPECIFICATION C PARAMETERS * ELSE IF (D1.EQ.2) THEN IF (D2.NE.0) THEN WRITE(UNIT,2100) END IF IF (D3.NE.0) THEN IF (D3.EQ.1 .OR. D3.EQ.3 .OR. D3.EQ.5 .OR. D3.EQ.7) THEN WRITE(UNIT,2210) END IF IF (D3.EQ.2 .OR. D3.EQ.3 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN WRITE(UNIT,2220) END IF IF (D3.EQ.4 .OR. D3.EQ.5 .OR. D3.EQ.6 .OR. D3.EQ.7) THEN WRITE(UNIT,2230) END IF END IF IF (D4.NE.0) THEN WRITE(UNIT,2300) LWKMN END IF IF (D5.NE.0) THEN WRITE(UNIT,2400) LIWKMN END IF * ELSE IF (D1.EQ.3) THEN * C PRINT APPROPRIATE MESSAGES FOR ERRORS SCALE VALUES * IF (D2.NE.0) THEN IF (LDSCLD.GE.N) THEN WRITE(UNIT,3110) ELSE WRITE(UNIT,3120) END IF END IF IF (D3.NE.0) THEN WRITE(UNIT,3130) END IF * C PRINT APPROPRIATE MESSAGES FOR ERRORS IN OBSERVATIONAL ERROR WEIGHTS * IF (D4.NE.0) THEN IF (D4.EQ.1) THEN WRITE(UNIT,3210) ELSE WRITE(UNIT,3220) END IF END IF * C PRINT APPROPRIATE MESSAGES FOR ERRORS IN DELTA WEIGHTS * IF (D5.NE.0) THEN IF (LDWD.GE.N) THEN WRITE(UNIT,3310) ELSE WRITE(UNIT,3320) END IF END IF * END IF * C FORMAT STATEMENTS * 1100 FORMAT + (/' ERROR : N IS LESS THAN ONE.') 1200 FORMAT + (/' ERROR : M IS LESS THAN ONE.') 1300 FORMAT + (/' ERROR : NP IS LESS THAN ONE'/ + ' OR NP IS GREATER THAN N.') 2100 FORMAT + (/' ERROR : LDX IS LESS THAN N.') 2210 FORMAT + (/' ERROR : LDIFX IS LESS THAN N'/ + ' AND LDIFX IS NOT EQUAL TO ONE.') 2220 FORMAT + (/' ERROR : LDSCLD IS LESS THAN N'/ + ' AND LDSCLD IS NOT EQUAL TO ONE.') 2230 FORMAT + (/' ERROR : LDWD IS LESS THAN N'/ + ' AND LDWD IS NOT EQUAL TO ONE.') 2300 FORMAT + (/' ERROR : LWORK IS LESS THAN ',I5, ','/ + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY WORK.') 2400 FORMAT + (/' ERROR : LIWORK IS LESS THAN ',I5, ','/ + ' THE SMALLEST ACCEPTABLE DIMENSION OF ARRAY', + ' IWORK.') 3110 FORMAT + (/' ERROR : SCLD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + ' AND LDSCLD IS GREATER THAN OR EQUAL TO N THEN'/ + ' EACH OF THE N BY M ELEMENTS OF'/ + ' SCLD MUST BE GREATER THAN ZERO.') 3120 FORMAT + (/' ERROR : SCLD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME J = 1, ..., M.'// + ' WHEN SCLD(1,1) IS GREATER THAN ZERO'/ + ' AND LDSCLD IS EQUAL TO ONE THEN'/ + ' EACH OF THE 1 BY M ELEMENTS OF'/ + ' SCLD MUST BE GREATER THAN ZERO.') 3130 FORMAT + (/' ERROR : SCLB(K) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME K = 1, ..., NP.'// + ' ALL NP ELEMENTS OF', + ' SCLB MUST BE GREATER THAN ZERO.') 3210 FORMAT + (/' ERROR : W(I) IS LESS THAN ZERO FOR SOME I = 1, ..., N.'// + ' WHEN W(1) IS GREATER THAN OR EQUAL TO ZERO THEN'/ + ' ALL N ELEMENTS OF', + ' W MUST BE GREATER THAN OR EQUAL TO ZERO.') 3220 FORMAT + (/' ERROR : THE NUMBER OF NONZERO VALUES IN ARRAY W IS'/ + ' LESS THAN NP.') 3310 FORMAT + (/' ERROR : WD(I,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME I = 1, ..., N AND J = 1, ..., M.'// + ' WHEN WD(1,1) IS GREATER THAN ZERO'/ + ' AND LDWD IS GREATER THAN OR EQUAL TO N THEN'/ + ' EACH OF THE N BY M ELEMENTS OF'/ + ' WD MUST BE GREATER THAN ZERO.') 3320 FORMAT + (/' ERROR : WD(1,J) IS LESS THAN OR EQUAL TO ZERO'/ + ' FOR SOME J = 1, ..., M.'// + ' WHEN WD(1,1) IS GREATER THAN ZERO'/ + ' AND LDWD IS EQUAL TO ONE THEN'/ + ' EACH OF THE 1 BY M ELEMENTS OF'/ + ' WD MUST BE GREATER THAN ZERO.') END *SODPE2 SUBROUTINE SODPE2 + (UNIT, + NP,M, + MSGB,ISODR,MSGX, + XPLUSD,LDXPD,NROW,NETA,NTOL) C***BEGIN PROLOGUE SODPE2 C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE GENERATE THE DERIVATIVE CHECKING REPORT C (THIS ROUTINE IS MODELED AFTER STARPAC SUBROUTINE DCKZRO) C***END PROLOGUE SODPE2 * C...SCALAR ARGUMENTS INTEGER + LDXPD,M,NETA,NP,NROW,NTOL,UNIT LOGICAL + ISODR * C...ARRAY ARGUMENTS REAL + XPLUSD(LDXPD,M) INTEGER + MSGB(NP+1),MSGX(M+1) * C...LOCAL SCALARS INTEGER + I,J,K CHARACTER TYP*3 * C...LOCAL ARRAYS LOGICAL + FTNOTE(6) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL FTNOTE(6) C THE ARRAY WHICH CONTROLS PRINTING OF FOOTNOTES. C INTEGER I C AN INDEX VARIABLE. C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER J C AN INDEX VARIABLE. C INTEGER K C AN INDEX VARIABLE. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER NETA C THE NUMBER OF RELIABLE DIGITS IN THE MODEL. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTOL C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C FINITE DIFFERENCE AND THE USER-SUPPLIED DERIVATIVES. C CHARACTER*3 TYP C THE SOLUTION TYPE, ODR OR OLS. C INTEGER UNIT C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT SODPE2 * * C SET UP FOR FOOTNOTES * DO 10 I=1,6 FTNOTE(I) = .FALSE. 10 CONTINUE * IF (MSGB(1).GE.1) THEN DO 20 I=1,NP IF (MSGB(I+1).GE.2) THEN FTNOTE(1) = .TRUE. FTNOTE(MSGB(I+1)) = .TRUE. END IF 20 CONTINUE END IF * IF (MSGX(1).GE.1) THEN DO 30 I=1,M IF (MSGX(I+1).GE.2) THEN FTNOTE(1) = .TRUE. FTNOTE(MSGX(I+1)) = .TRUE. END IF 30 CONTINUE END IF * C PRINT REPORT * IF (ISODR) THEN TYP = 'ODR' ELSE TYP = 'OLS' END IF WRITE (UNIT,1000) TYP IF (FTNOTE(1)) WRITE (UNIT,2100) WRITE (UNIT,2200) * * DO 40 I=1,NP K = MSGB(I+1) - 1 IF (K.EQ.(-1)) WRITE (UNIT,3100) I IF (K.EQ.0) WRITE (UNIT,3200) I IF (K.GE.1) WRITE (UNIT,3300) I, K 40 CONTINUE IF (ISODR) THEN DO 50 I=1,M K = MSGX(I+1) - 1 IF (K.EQ.(-1)) WRITE (UNIT,4100) NROW,I IF (K.EQ.0) WRITE (UNIT,4200) NROW,I IF (K.GE.1) WRITE (UNIT,4300) NROW,I,K 50 CONTINUE END IF * C PRINT FOOTNOTES * IF (FTNOTE(1)) THEN * WRITE (UNIT,5100) IF (FTNOTE(2)) WRITE (UNIT,5200) IF (FTNOTE(3)) WRITE (UNIT,5300) IF (FTNOTE(4)) WRITE (UNIT,5400) IF (FTNOTE(5)) WRITE (UNIT,5500) IF (FTNOTE(6)) WRITE (UNIT,5600) END IF * WRITE (UNIT,6000) NETA WRITE (UNIT,7000) NTOL * C PRINT OUT ROW OF INDEPENDENT VARIABLE WHICH WAS CHECKED. * WRITE (UNIT,8100) NROW * DO 60 J=1,M WRITE (UNIT,8110) NROW,J,XPLUSD(NROW,J) 60 CONTINUE * RETURN * C FORMAT STATEMENTS * 1000 FORMAT + (//' DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ',A3/ + ' ==================================================='/) 2100 FORMAT (' *') 2200 FORMAT (' DERIVATIVE '/ + ' DERIVATIVE WRT ASSESSMENT '/) 3100 FORMAT (' BETA(',I3,') OK ') 3200 FORMAT (' BETA(',I3,') INCORRECT ') 3300 FORMAT (' BETA(',I3,') QUESTIONABLE (',I1,')') 4100 FORMAT (' X(',I2,',',I2,') OK ') 4200 FORMAT (' X(',I2,',',I2,') INCORRECT ') 4300 FORMAT (' X(',I2,',',I2,') QUESTIONABLE (',I1,')') 5100 FORMAT + (/' *'/ + ' NUMBERS IN PARENTHESES REFER TO THE FOLLOWING NOTES.') 5200 FORMAT + (/' (1) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/ + ' AGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE BOTH'/ + ' ARE ZERO.') 5300 FORMAT + (/' (2) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/ + ' AGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE USER-'/ + ' SUPPLIED DERIVATIVE IS IDENTICALLY ZERO AND FINITE '/ + ' DIFFERENCE DERIVATIVE IS ONLY APPROXIMATELY ZERO.') 5400 FORMAT + (/' (3) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/ + ' DISAGREE, BUT RESULTS ARE QUESTIONABLE BECAUSE'/ + ' USER-SUPPLIED DERIVATIVE IS IDENTICALLY ZERO.') 5500 FORMAT + (/' (4) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/ + ' DISAGREE, BUT FINITE DIFFERENCE DERIVATIVE IS'/ + ' QUESTIONABLE BECAUSE EITHER THE RATIO OF RELATIVE'/ + ' CURVATURE TO RELATIVE SLOPE IS TOO HIGH OR THE SCALE'/ + ' IS WRONG.') 5600 FORMAT + (/' (5) USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVES'/ + ' DISAGREE, BUT FINITE DIFFERENCE DERIVATIVE IS'/ + ' QUESTIONABLE BECAUSE THE RATIO OF RELATIVE CURVATURE'/ + ' TO RELATIVE SLOPE IS TOO HIGH.') 6000 FORMAT * (/' NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS ',I5) 7000 FORMAT + (/' NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN '/ + ' USER-SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR '/ + ' USER-SUPPLIED DERIVATIVE TO BE CONSIDERED CORRECT ',I5) 8100 FORMAT + (/' ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED ',I5// + ' -VALUES OF THE INDEPENDENT VARIABLES AT THIS ROW'/) 8110 FORMAT + (6X,'X(',I2,',',I2,')',1X,3E16.8) END *SODPE3 SUBROUTINE SODPE3 + (UNIT,D2,D3) C***BEGIN PROLOGUE SODPE3 C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE PRINT ERROR REPORTS TO INDICATE THAT COMPUTATIONS WERE C STOPPED IN USER-SUPPLIED SUBROUTINES FUN AND/OR JAC. C***END PROLOGUE SODPE3 * C...SCALAR ARGUMENTS INTEGER + D2,D3,UNIT * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER D2 C THE SECOND DIGIT OF INFO. C INTEGER D3 C THE THIRD DIGIT OF INFO. C INTEGER UNIT C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. * * C***FIRST EXECUTABLE STATEMENT SODPE3 * * C PRINT APPROPRIATE MESSAGES TO INDICATE WHERE COMPUTATIONS WERE C STOPPED * IF (D2.EQ.2) THEN WRITE(UNIT,1100) ELSE IF (D2.EQ.3) THEN WRITE(UNIT,1200) ELSE IF (D2.EQ.4) THEN WRITE(UNIT,1300) END IF IF (D3.EQ.2) THEN WRITE(UNIT,1400) END IF * C FORMAT STATEMENTS * 1100 FORMAT + (//' VARIABLE ISTOPF HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER-SUPPLIED SUBROUTINE FUN WHEN INVOKED USING THE'/ + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ + ' PROPER EVALUATION OF SUBROUTINE FUN BEFORE THE '/ + ' REGRESSION PROCEDURE CAN CONTINUE.') 1200 FORMAT + (//' VARIABLE ISTOPF HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER-SUPPLIED SUBROUTINE FUN. THIS OCCURRED DURING'/ + ' THE COMPUTATION OF THE NUMBER OF RELIABLE DIGITS IN THE '/ + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FUN, INDI-'/ + ' CATING THAT CHANGES IN THE INITIAL ESTIMATES OF BETA(K),'/ + ' K=1,NP, AS SMALL AS 2*BETA(K)*SQRT(MACHINE PRECISION), '/ + ' WHERE MACHINE PRECISION IS DEFINED AS THE SMALLEST VALUE'/ + ' E SUCH THAT 1+E>1 ON THE COMPUTER BEING USED, PREVENT '/ + ' SUBROUTINE FUN FROM BEING PROPERLY EVALUATED. THE '/ + ' INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + ' EVALUATION OF SUBROUTINE FUN DURING THESE COMPUTATIONS '/ + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') 1300 FORMAT + (//' VARIABLE ISTOPF HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER-SUPPLIED SUBROUTINE FUN. THIS OCCURRED DURING'/ + ' THE DERIVATIVE CHECKING PROCEDURE, INDICATING THAT '/ + ' CHANGES IN THE INITIAL ESTIMATES OF BETA(K), K=1,NP, AS '/ + ' SMALL AS MAX[BETA(K),1/SCLB(K)]*10**(-NETA/2), AND/OR '/ + ' OF DELTA(I,J), I=1,N AND J=1,M, AS SMALL AS '/ + ' MAX[DELTA(I,J),1/SCLD(I,J)]*10**(-NETA/2), WHERE NETA '/ + ' IS DEFINED TO BE THE NUMBER OF RELIABLE DIGITS IN '/ + ' PREDICTED VALUES (F) RETURNED FROM SUBROUTINE FUN, '/ + ' PREVENT SUBROUTINE FUN FROM BEING PROPERLY EVALUATED. '/ + ' THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW PROPER '/ + ' EVALUATION OF SUBROUTINE FUN DURING THESE COMPUTATIONS '/ + ' BEFORE THE REGRESSION PROCEDURE CAN CONTINUE.') 1400 FORMAT + (//' VARIABLE ISTOPJ HAS BEEN RETURNED WITH A NONZERO VALUE '/ + ' FROM USER-SUPPLIED SUBROUTINE JAC WHEN INVOKED USING THE'/ + ' INITIAL ESTIMATES OF BETA AND DELTA SUPPLIED BY THE '/ + ' USER. THE INITIAL ESTIMATES MUST BE ADJUSTED TO ALLOW '/ + ' PROPER EVALUATION OF SUBROUTINE JAC BEFORE THE '/ + ' REGRESSION PROCEDURE CAN CONTINUE.') END *SODPER SUBROUTINE SODPER + (INFO,LUNERR,SHORT, + N,NP,M, + LDSCLD,LDWD, + LWKMN,LIWKMN, + SCLD,SCLB,W,WD, + MSGB,ISODR,MSGX, + XPLUSD,LDXPD,NROW,NETA,NTOL) C***BEGIN PROLOGUE SODPER C***REFER TO SODR,SODRC C***ROUTINES CALLED SODPE1,SODPE2,SODPE3,SODPHD C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE CONTROLLING ROUTINE FOR PRINTING ERROR REPORTS. C***END PROLOGUE SODPER * C...SCALAR ARGUMENTS INTEGER + INFO,LDSCLD,LDWD,LDXPD,LIWKMN,LUNERR,LWKMN,M,N,NETA,NP, + NROW,NTOL LOGICAL + ISODR,SHORT * C...ARRAY ARGUMENTS REAL + SCLB(NP),SCLD(LDSCLD,M),W(N),WD(LDWD,M),XPLUSD(LDXPD,M) INTEGER + MSGB(NP+1),MSGX(M+1) * C...LOCAL SCALARS INTEGER + D1,D2,D3,D4,D5,UNIT LOGICAL + HEAD * C...EXTERNAL SUBROUTINES EXTERNAL + SODPE1,SODPE2,SODPE3,SODPHD * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER D1 C THE FIRST DIGIT OF INFO. C INTEGER D2 C THE SECOND DIGIT OF INFO. C INTEGER D3 C THE THIRD DIGIT OF INFO. C INTEGER D4 C THE FOURTH DIGIT OF INFO. C INTEGER D5 C THE FIFTH DIGIT OF INFO. C LOGICAL HEAD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE C HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL ISODR C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE SOLUTION C IS TO BE FOUND BY ODR (ISODR=.TRUE.) OR BY OLS (ISODR=.FALSE.). C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER LIWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY IWORK. C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MSGB(NP+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT BETA. C INTEGER MSGX(M+1) C THE ERROR CHECKING RESULTS FOR THE JACOBIAN WRT X. C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NETA C THE NUMBER OF RELIABLE DIGITS IN THE MODEL. C REAL SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C INTEGER NTOL C THE NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN THE C FINITE DIFFERENCE AND THE USER-SUPPLIED DERIVATIVES. C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS C INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG- C CALL (SHORT=.FALSE.). C INTEGER UNIT C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT SODPER * * C SET LOGICAL UNIT NUMBER FOR ERROR REPORT * IF (LUNERR.EQ.0) THEN RETURN ELSE IF (LUNERR.LT.0) THEN UNIT = 6 ELSE UNIT = LUNERR END IF * C PRINT HEADING * HEAD = .TRUE. CALL SODPHD(HEAD,UNIT) * C EXTRACT INDIVIDUAL DIGITS FROM VARIABLE INFO * D1 = MOD(INFO,100000)/10000 D2 = MOD(INFO,10000)/1000 D3 = MOD(INFO,1000)/100 D4 = MOD(INFO,100)/10 D5 = MOD(INFO,10) * C PRINT APPROPRIATE ERROR MESSAGES FOR ODRPACK INVOKED STOP * IF (D1.GE.1 .AND. D1.LE.3) THEN * C PRINT APPROPRIATE MESSAGES FOR ERRORS IN C PROBLEM SPECIFICATION PARAMETERS C DIMENSION SPECIFICATION PARAMETERS C NUMBER OF GOOD DIGITS IN X C OBSERVATIONAL ERROR WEIGHTS C DELTA WEIGHTS * CALL SODPE1(UNIT,D1,D2,D3,D4,D5, + N, + LDSCLD,LDWD, + LWKMN,LIWKMN) * ELSE IF (D1.EQ.4) THEN * C PRINT APPROPRIATE MESSAGES FOR ERRORS DETECTED IN THE USER-SUPPLIED C JACOBIAN * CALL SODPE2(UNIT, + NP,M, + MSGB,ISODR,MSGX, + XPLUSD,LDXPD,NROW,NETA,NTOL) * ELSE IF (D1.EQ.5) THEN * C PRINT APPROPRIATE ERROR MESSAGE FOR USER INVOKED STOP FROM FUN OR JAC * CALL SODPE3(UNIT,D2,D3) * END IF * C PRINT CORRECT FORM OF CALL STATEMENT * IF ((D1.GE.1 .AND. D1.LE.3) .OR. + (D1.EQ.4 .AND. (D2.EQ.2 .OR. D3.EQ.2)) .OR. + (D1.EQ.5)) THEN IF (SHORT) THEN WRITE (UNIT,1100) ELSE WRITE (UNIT,1200) END IF END IF * RETURN * C FORMAT STATEMENTS * 1100 FORMAT + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + ' CALL SODR'/ + ' + (FUN,JAC,'/ + ' + N,M,NP,'/ + ' + X,LDX,'/ + ' + Y,'/ + ' + BETA,'/ + ' + WD,LDWD,'/ + ' + JOB,'/ + ' + IPRINT,LUNERR,LUNRPT,'/ + ' + WORK,LWORK,IWORK,LIWORK,'/ + ' + INFO)') 1200 FORMAT + (//' THE CORRECT FORM OF THE CALL STATEMENT IS '// + ' CALL SODRC'/ + ' + (FUN,JAC,'/ + ' + N,M,NP,'/ + ' + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD,'/ + ' + Y,'/ + ' + BETA,IFIXB,SCLB,'/ + ' + WD,LDWD,W,'/ + ' + JOB,NDIGIT,TAUFAC,'/ + ' + SSTOL,PARTOL,MAXIT,'/ + ' + IPRINT,LUNERR,LUNRPT,'/ + ' + WORK,LWORK,IWORK,LIWORK,'/ + ' + INFO)') * END *SODPHD SUBROUTINE SODPHD + (HEAD,UNIT) C***BEGIN PROLOGUE SODPHD C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890727 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE PRINT ODRPACK HEADING C***END PROLOGUE SODPHD * C...SCALAR ARGUMENTS INTEGER + UNIT LOGICAL + HEAD * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL HEAD C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE PACKAGE C HEADING IS TO BE PRINTED (HEAD=.TRUE.) OR NOT (HEAD=.FALSE.). C INTEGER UNIT C THE LOGICAL UNIT NUMBER TO WHICH THE HEADING IS WRITTEN. * * C***FIRST EXECUTABLE STATEMENT SODPHD * * IF (HEAD) THEN WRITE(UNIT,1000) HEAD = .FALSE. END IF * RETURN * C FORMAT STATEMENTS * 1000 FORMAT (/// + ' ******************************************************* '/ + ' * ODRPACK VERSION 1.71 OF 07-27-89 (SINGLE PRECISION) * '/ + ' ******************************************************* '/) END *SODR SUBROUTINE SODR + (FUN,JAC, + N,M,NP, + X,LDX, + Y, + BETA, + WD,LDWD, + JOB, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) C***BEGIN PROLOGUE SODR C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE USER-CALLABLE SINGLE PRECISION CONTROL ROUTINE FOR FINDING C THE WEIGHTED ORTHOGONAL DISTANCE REGRESSION (ODR) OR C ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) SOLUTION C (SHORT CALL STATEMENT) C***DESCRIPTION C REFERENCE FOR ONLINE DOCUMENTATION IS GIVEN BELOW. C THE ONLINE DOCUMENTATION CAN BE INSERTED HERE IF REQUIRED BY C YOUR DOCUMENTATION RETRIEVAL SYSTEM. ONLINE DOCUMENTATION DOES C NOT EXTEND BEYOND COLUMN 80, AND COLUMN 1 OF ONLINE C DOCUMENTATION CAN BE CHANGED TO 'C' WITHOUT LOSS OF INFORMATION. C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1987), C "ODRPACK -- SOFTWARE FOR WEIGHTED ORTHOGONAL C DISTANCE REGRESSION," C UNIVERSITY OF COLORADO DEPARTMENT OF COMPUTER SCIENCE C TECHNICAL REPORT NUMBER CU-CS-360-87. C (TO APPEAR IN ACM TRANS. MATH. SOFTWARE.) C BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1989), C "REFERENCE GUIDE FOR ODRPACK SOFTWARE FOR WEIGHTED C ORTHOGONAL DISTANCE REGRESSION," C ONLINE DOCUMENTATION AVAILABLE FROM AUTHORS C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR C ORTHOGONAL DISTANCE REGRESSION," C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. C***ROUTINES CALLED SODDRV C***END PROLOGUE SODR * C...SCALAR ARGUMENTS INTEGER + INFO,JOB,LDWD,LDX,LIWORK,LWORK,M,N,NDIGIT,NP * C...ARRAY ARGUMENTS REAL + BETA(NP),WD(LDWD,M),WORK(LWORK),X(LDX,M),Y(N) INTEGER + IWORK(LIWORK) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS REAL + NEGONE,PARTOL,SSTOL,TAUFAC INTEGER + IPRINT,LDIFX,LDSCLD,LUNERR,LUNRPT,MAXIT LOGICAL + SHORT * C...LOCAL ARRAYS REAL + SCLB(1),SCLD(1,1),W(1) INTEGER + IFIXB(1),IFIXX(1,1) * C...EXTERNAL SUBROUTINES EXTERNAL + SODDRV * C...DATA STATEMENTS DATA + NEGONE + /-1.0E0/ * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE FUNCTION. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXB(1) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(1,1) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL NEGONE C THE VALUE -1.0E0. C INTEGER NDIGIT C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SCLB(1) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SCLD(1,1) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS C INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG- C CALL (SHORT=.FALSE.). C REAL SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL W(1) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WORK(LWORK) C THE REAL WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) * * C***FIRST EXECUTABLE STATEMENT SODR * * C INITIALIZE NECESSARY VARIABLES TO INDICATE USE OF DEFAULT VALUES * IFIXX(1,1) = -1 LDIFX = 1 SCLD(1,1) = NEGONE LDSCLD = 1 IFIXB(1) = -1 SCLB(1) = NEGONE W(1) = NEGONE TAUFAC = NEGONE SSTOL = NEGONE PARTOL = NEGONE MAXIT = -1 NDIGIT = -1 * SHORT = .TRUE. * CALL SODDRV + (SHORT, + FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) * RETURN * END *SODRC SUBROUTINE SODRC + (FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) C***BEGIN PROLOGUE SODRC C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE USER-CALLABLE SINGLE PRECISION CONTROL ROUTINE FOR FINDING C THE WEIGHTED ORTHOGONAL DISTANCE REGRESSION (ODR) OR C ORDINARY LINEAR OR NONLINEAR LEAST SQUARES (OLS) SOLUTION C (LONG CALL STATEMENT) C***DESCRIPTION C REFERENCE FOR ONLINE DOCUMENTATION IS GIVEN BELOW. C THE ONLINE DOCUMENTATION CAN BE INSERTED HERE IF REQUIRED BY C YOUR DOCUMENTATION RETRIEVAL SYSTEM. ONLINE DOCUMENTATION DOES C NOT EXTEND BEYOND COLUMN 80, AND COLUMN 1 OF ONLINE C DOCUMENTATION CAN BE CHANGED TO 'C' WITHOUT LOSS OF INFORMATION. C***REFERENCES BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1987), C "ODRPACK -- SOFTWARE FOR WEIGHTED ORTHOGONAL C DISTANCE REGRESSION," C UNIVERSITY OF COLORADO DEPARTMENT OF COMPUTER SCIENCE C TECHNICAL REPORT NUMBER CU-CS-360-87. C (TO APPEAR IN ACM TRANS. MATH. SOFTWARE.) C BOGGS, P. T., R. H. BYRD, J. R. DONALDSON, AND C R. B. SCHNABEL (1989), C "REFERENCE GUIDE FOR ODRPACK SOFTWARE FOR WEIGHTED C ORTHOGONAL DISTANCE REGRESSION," C ONLINE DOCUMENTATION AVAILABLE FROM AUTHORS C BOGGS, P. T., R. H. BYRD, AND R. B. SCHNABEL (1987), C "A STABLE AND EFFICIENT ALGORITHM FOR NONLINEAR C ORTHOGONAL DISTANCE REGRESSION," C SIAM J. SCI. STAT. COMPUT., 8(6):1052-1078. C***ROUTINES CALLED SODDRV C***END PROLOGUE SODRC * C...SCALAR ARGUMENTS REAL + PARTOL,SSTOL,TAUFAC INTEGER + INFO,IPRINT,JOB,LDIFX,LDSCLD,LDWD,LDX,LIWORK,LUNERR, + LUNRPT,LWORK,M,MAXIT,N,NDIGIT,NP * C...ARRAY ARGUMENTS REAL + BETA(NP),SCLB(NP),SCLD(LDSCLD,M), + W(N),WD(LDWD,M),WORK(LWORK),X(LDX,M),Y(N) INTEGER + IFIXB(NP),IFIXX(LDIFX,M),IWORK(LIWORK) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN,JAC * C...LOCAL SCALARS LOGICAL + SHORT * C...EXTERNAL SUBROUTINES EXTERNAL + SODDRV * C...ROUTINE NAMES USED AS SUBPROGRAM ARGUMENTS C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE FUNCTION. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C EXTERNAL JAC C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE JACOBIANS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT JAC.) * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXB(NP) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF BETA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IFIXX(LDIFX,M) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF DELTA ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER INFO C AN INDICATOR VARIABLE, USED PRIMARILY TO DESIGNATE WHY THE C COMPUTATIONS WERE STOPPED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IPRINT C THE PRINT CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER IWORK(LIWORK) C THE INTEGER WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER JOB C THE PROBLEM INITIALIZATION AND COMPUTATIONAL C METHOD CONTROL VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDIFX C THE LEADING DIMENSION OF ARRAY IFIXX. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDSCLD C THE LEADING DIMENSION OF ARRAY SCLD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LIWORK C THE LENGTH OF VECTOR IWORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNERR C THE LOGICAL UNIT NUMBER USED FOR ERROR MESSAGES. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LUNRPT C THE LOGICAL UNIT NUMBER USED FOR COMPUTATION REPORTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LWORK C THE LENGTH OF VECTOR WORK. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER MAXIT C THE MAXIMUM NUMBER OF ITERATIONS ALLOWED. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NDIGIT C THE NUMBER OF ACCURATE DIGITS IN THE FUNCTION RESULTS, AS C SUPPLIED BY THE USER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL PARTOL C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SCLB(NP) C THE SCALE OF EACH BETA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SCLD(LDSCLD,M) C THE SCALE OF EACH DELTA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL SHORT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THE USER HAS C INVOKED ODRPACK BY THE SHORT-CALL (SHORT=.TRUE.) OR THE LONG- C CALL (SHORT=.FALSE.). C REAL SSTOL C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TAUFAC C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WORK(LWORK) C THE REAL WORK SPACE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL Y(N) C THE DEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) * * C***FIRST EXECUTABLE STATEMENT SODRC * * SHORT = .FALSE. * CALL SODDRV + (SHORT, + FUN,JAC, + N,M,NP, + X,LDX,IFIXX,LDIFX,SCLD,LDSCLD, + Y, + BETA,IFIXB,SCLB, + WD,LDWD,W, + JOB,NDIGIT,TAUFAC, + SSTOL,PARTOL,MAXIT, + IPRINT,LUNERR,LUNRPT, + WORK,LWORK,IWORK,LIWORK, + INFO) * RETURN * END *SODSTP SUBROUTINE SODSTP + (N,NP,NPP,M,F,FJACB,LDFJB,FJACX,LDFJX, + W,WD,LDWD,SS,TT,LDTT,DDELT, + ALPHA,EPSMAC, + SSS,TFJACB,VDTD,OMEGA,YT,U,QRAUX,WRK2,JPVT, + S,T,PHI,IRANK, + RCOND) C***BEGIN PROLOGUE SODSTP C***REFER TO SODR,SODRC C***ROUTINES CALLED ISAMAX,SCHEX,SDIAGS,SDOT,SIDTS,SNRM2,SQRDC, C SQRSL,SROT,SROTG,STRCO,STRSL,SZERO C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE LOCALLY CONSTRAINED STEPS S AND T, AND PHI(ALPHA) C***END PROLOGUE SODSTP * C...SCALAR ARGUMENTS REAL + ALPHA,EPSMAC,PHI,RCOND INTEGER + IRANK,LDFJB,LDFJX,LDTT,LDWD,M,N,NP,NPP * C...ARRAY ARGUMENTS REAL + DDELT(N,M),F(N),FJACB(LDFJB,NP),FJACX(LDFJX,M), + OMEGA(N),QRAUX(NP),S(NP),SS(NP), + SSS(N+N*M),T(N,M),TFJACB(N,NP),TT(LDTT,M),U(N), + VDTD(N,M),W(N),WD(LDWD,M),WRK2(NP),YT(N) INTEGER + JPVT(NP) * C...LOCAL SCALARS REAL + CO,ONE,SI,TEMP,ZERO INTEGER + I,IMAX,INF,IPVT,J,KP LOGICAL + ELIM * C...LOCAL ARRAYS REAL + DUM(1) * C...EXTERNAL FUNCTIONS REAL + SDOT,SNRM2 INTEGER + ISAMAX EXTERNAL + SDOT,SNRM2,ISAMAX * C...EXTERNAL SUBROUTINES EXTERNAL + SCHEX,SDIAGS,SIDTS,SQRDC,SQRSL,SROT,SROTG,STRCO,STRSL, + SZERO * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SQRT * C...DATA STATEMENTS DATA + ZERO,ONE + /0.0E0,1.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL ALPHA C THE LEVENBERG-MARQUARDT PARAMETER. C REAL CO C THE COSINE FROM THE PLANE ROTATION. C REAL DDELT(N,M) C THE ARRAY (W*D)**2 * DELTA. C REAL DUM C AN DUMMY VARIABLE. C LOGICAL ELIM C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER COLUMNS OF THE C JACOBIAN WRT BETA HAVE BEEN ELIMINATED (ELIM=.TRUE.) OR NOT C (ELIM=.FALSE.). C REAL EPSMAC C THE VALUE OF MACHINE PRECISION. C REAL F(N) C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C REAL FJACB(LDFJB,NP) C THE JACOBIAN WITH RESPECT TO BETA. C REAL FJACX(LDFJX,M) C THE JACOBIAN WITH RESPECT TO X. C INTEGER I C AN INDEXING VARIABLE. C INTEGER IMAX C THE INDEX OF THE ELEMENT OF U HAVING THE LARGEST ABSOLUTE C VALUE. C INTEGER INF C THE RETURN CODE FROM SQRSL AND STRSL. C INTEGER IPVT C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER OR NOT C PIVOTING IS TO BE DONE. C INTEGER IRANK C THE RANK DEFICIENCY OF THE JACOBIAN WRT BETA. C INTEGER J C AN INDEXING VARIABLE. C INTEGER JPVT(NP) C THE PIVOT VECTOR. C INTEGER KP C THE RANK OF THE JACOBIAN WRT BETA. C INTEGER LDFJB C THE LEADING DIMENSION OF ARRAY FJACB. C INTEGER LDFJX C THE LEADING DIMENSION OF ARRAY FJACX. C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NPP C THE NUMBER OF FUNCTION PARAMETERS ACTUALLY BEING ESTIMATED. C REAL OMEGA(N) C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C REAL ONE C THE VALUE 1.0E0. C REAL PHI C THE DIFFERENCE BETWEEN THE NORM OF THE SCALED STEP C AND THE TRUST REGION DIAMETER. C REAL QRAUX(NP) C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C REAL RCOND C THE APPROXIMATE RECIPROCAL CONDITION OF TFJACB. C REAL S(NP) C THE STEP FOR THE ESTIMATED BETA'S. C REAL SI C THE SINE FROM THE PLANE ROTATION. C REAL SS(NP) C THE SCALE USED FOR THE ESTIMATED BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL SSS(N+N*M) C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C REAL T(N,M) C THE STEP FOR THE ESTIMATED DELTA'S. C REAL TEMP C A TEMPORARY STORAGE LOCATION. C REAL TFJACB(N,NP) C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C REAL TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL U(N) C THE APPROXIMATE NULL VECTOR FOR TFJACB. C REAL VDTD(N,M) C THE ARRAY DDELT*INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2. C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WRK2(NP) C A WRK2 ARRAY. C REAL YT(N) C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SODSTP * * C COMPUTE LOOP PARAMETERS WHICH DEPEND ON WEIGHT STRUCTURE * C SET UP JPVT IF ALPHA = 0 * IF (ALPHA.EQ.ZERO) THEN KP = NPP DO 10 I=1,NPP JPVT(I) = I 10 CONTINUE ELSE IF (NPP.GE.1) THEN KP = NPP-IRANK ELSE KP = NPP END IF END IF * C SET UP OMEGA AND TFJACB C (VDTD = FJACX * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2) * CALL SIDTS(N,M,W,WD,LDWD,ALPHA,TT,LDTT,FJACX,LDFJX,VDTD,N) DO 20 I=1,N OMEGA(I) = SQRT(ONE+SDOT(M,VDTD(I,1),N,FJACX(I,1),LDFJX)) 20 CONTINUE DO 40 J=1,KP DO 30 I=1,N TFJACB(I,J) = FJACB(I,JPVT(J))/OMEGA(I) 30 CONTINUE 40 CONTINUE * C SET UP VDTD AND YT C (VDTD = DDELT * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2) * CALL SIDTS(N,M,W,WD,LDWD,ALPHA,TT,LDTT,DDELT,N,VDTD,N) DO 50 I=1,N VDTD(I,1) = SDOT(M,FJACX(I,1),LDFJX,VDTD(I,1),N) YT(I) = -(F(I)-VDTD(I,1))/OMEGA(I) 50 CONTINUE * C COMPUTE S * C DO QR FACTORIZATION (WITH COLUMN PIVOTING OF TRJACB IF ALPHA = 0) * IF (ALPHA.EQ.ZERO) THEN IPVT = 1 DO 60 I=1,NPP JPVT(I) = 0 60 CONTINUE ELSE IPVT = 0 END IF * CALL SQRDC(TFJACB,N,N,KP,QRAUX,JPVT,WRK2,IPVT) * C GET TR(Q)*YT * CALL SQRSL(TFJACB,N,N,KP,QRAUX,YT,DUM,YT,DUM,DUM,DUM,1000,INF) * C ELIMINATE ALPHA PART USING GIVENS ROTATIONS * IF (ALPHA.NE.ZERO) THEN CALL SZERO(NPP,1,S,NPP) DO 90 I=1,KP CALL SZERO(KP,1,WRK2,KP) IF (SS(1).GT.ZERO) THEN WRK2(I) = SQRT(ALPHA)*SS(JPVT(I)) ELSE WRK2(I) = SQRT(ALPHA)*ABS(SS(1)) END IF DO 80 J=I,KP CALL SROTG(TFJACB(J,J),WRK2(J),CO,SI) IF (KP-J.GE.1) THEN CALL SROT(KP-J,TFJACB(J,J+1),N,WRK2(J+1),1,CO,SI) END IF TEMP = CO*YT(J) + SI*S(JPVT(I)) S(JPVT(I)) = -SI*YT(J) + CO*S(JPVT(I)) YT(J) = TEMP 80 CONTINUE 90 CONTINUE END IF * C COMPUTE SOLUTION - ELIMINATE VARIABLES IF NECESSARY * IF (NPP.GE.1) THEN IF (ALPHA.EQ.ZERO) THEN KP = NPP * C ESTIMATE RCOND - U WILL CONTAIN APPROX NULL VECTOR * 100 CALL STRCO(TFJACB,N,KP,RCOND,U,1) IF (RCOND.LE.EPSMAC) THEN ELIM = .TRUE. IMAX = ISAMAX(KP,U,1) * C IMAX IS THE COLUMN TO REMOVE - USE SCHEX AND FIX JPVT * IF (IMAX.NE.KP) THEN CALL SCHEX(TFJACB,N,KP,IMAX,KP,YT,N,1,QRAUX,WRK2,2) J = JPVT(IMAX) DO 110 I=IMAX,KP-1 JPVT(I) = JPVT(I+1) 110 CONTINUE JPVT(KP) = J END IF KP = KP-1 ELSE ELIM = .FALSE. END IF IF (ELIM .AND. KP.GE.1) THEN GO TO 100 ELSE IRANK = NPP-KP END IF END IF * C BACKSOLVE AND UNSCRAMBLE * DO 120 I=KP+1,NPP YT(I) = ZERO 120 CONTINUE IF (KP.GE.1) THEN CALL STRSL(TFJACB,N,KP,YT,01,INF) END IF DO 130 I=1,NPP S(JPVT(I)) = YT(I) 130 CONTINUE END IF * C COMPUTE T * DO 140 I=1,N TEMP = F(I)+SDOT(NPP,FJACB(I,1),LDFJB,S,1) U(I) = (TEMP-VDTD(I,1))/(OMEGA(I)**2) 140 CONTINUE DO 160 J=1,M DO 150 I=1,N T(I,J) = -(FJACX(I,J)*U(I) + DDELT(I,J)) 150 CONTINUE 160 CONTINUE * C (T = T * INV(DT) WHERE DT = (W*D)**2 + ALPHA*TT**2) * CALL SIDTS(N,M,W,WD,LDWD,ALPHA,TT,LDTT,T,N,T,N) * C COMPUTE PHI(ALPHA) FROM SCALED S AND T * IF (NPP.GE.1) THEN CALL SDIAGS(NPP,1,SS,NPP,S,NPP,SSS,NPP) END IF CALL SDIAGS(N,M,TT,LDTT,T,N,SSS(NPP+1),N) PHI = SNRM2(NPP+N*M,SSS,1) * RETURN END *SPACK SUBROUTINE SPACK + (N2,N1,V1,V2,IFIX) C***BEGIN PROLOGUE SPACK C***REFER TO SODR,SODRC C***ROUTINES CALLED SCOPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SELECT THE UNFIXED ELEMENTS OF V2 AND RETURN THEM IN V1 C***END PROLOGUE SPACK * C...SCALAR ARGUMENTS INTEGER + N1,N2 * C...ARRAY ARGUMENTS REAL + V1(N2),V2(N2) INTEGER + IFIX(N2) * C...LOCAL SCALARS INTEGER + I * C...EXTERNAL SUBROUTINES EXTERNAL + SCOPY * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIX(N2) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF V2 ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE DISCUSSION OF IFIXB AND IFIXX IN PROLOGUE OF C SUBROUTINE SODR OR SODRC.) C INTEGER N1 C THE NUMBER OF ITEMS IN V1. C INTEGER N2 C THE NUMBER OF ITEMS IN V2. C REAL V1(N2) C THE VECTOR OF THE UNFIXED ITEMS FROM V2. C REAL V2(N2) C THE VECTOR OF THE FIXED AND UNFIXED ITEMS FROM WHICH THE C UNFIXED ELEMENTS ARE TO BE EXTRACTED. * * C***FIRST EXECUTABLE STATEMENT SPACK * * N1 = 0 IF (IFIX(1).GE.0) THEN DO 10 I=1,N2 IF (IFIX(I).NE.0) THEN N1 = N1+1 V1(N1) = V2(I) END IF 10 CONTINUE ELSE N1 = N2 CALL SCOPY(N2,V2,1,V1,1) END IF * RETURN END *SPVB REAL FUNCTION SPVB + (FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,NROW,J,STP,ISTOPF) C***BEGIN PROLOGUE SPVB C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE THE NROW-TH FUNCTION VALUE USING BETA(J) + STP C***END PROLOGUE SPVB * C...SCALAR ARGUMENTS REAL + STP INTEGER + ISTOPF,J,LDXPD,M,N,NFEV,NP,NROW * C...ARRAY ARGUMENTS REAL + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS REAL + TEMP * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL PVTEMP(N) C THE VECTOR OF PREDICTED VALUE FROM THE MODEL. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE. C REAL TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE JTH C PARAMETER IS STORED. C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT SPVB * * C COMPUTE PREDICTED VALUES * TEMP = BETA(J) BETA(J) = BETA(J) + STP ISTOPF = 0 CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,ISTOPF) NFEV = NFEV + 1 BETA(J) = TEMP * SPVB = PVTEMP(NROW) * RETURN END *SPVD REAL FUNCTION SPVD + (FUN,NFEV,N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,NROW,J,STP,ISTOPF) C***BEGIN PROLOGUE SPVD C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE NROW-TH FUNCTION VALUE USING C X(NROW,J) + DELTA(NROW,J) + STP C***END PROLOGUE SPVD * C...SCALAR ARGUMENTS REAL + STP INTEGER + ISTOPF,J,LDXPD,M,N,NFEV,NP,NROW * C...ARRAY ARGUMENTS REAL + BETA(NP),PVTEMP(N),XPLUSD(LDXPD,M) * C...SUBROUTINE ARGUMENTS EXTERNAL + FUN * C...LOCAL SCALARS REAL + TEMP * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C EXTERNAL FUN C THE NAME OF USER-SUPPLIED ROUTINE FOR COMPUTING THE MODEL. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE SECTION V.B, C ARGUMENT FUN.) C INTEGER ISTOPF C AN INDICATOR VARIABLE, BY WHICH THE USER CAN SPECIFY THAT THERE C ARE PROBLEMS COMPUTING THE FUNCTION GIVEN THE CURRENT ESTIMATES C OF BETA AND DELTA. C INTEGER J C THE INDEX OF THE PARTIAL DERIVATIVE BEING EXAMINED. C INTEGER LDXPD C THE LEADING DIMENSION OF ARRAY XPLUSD. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NFEV C THE NUMBER OF FUNCTION EVALUATIONS. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE NUMBER OF THE ROW OF THE INDEPENDENT VARIABLE ARRAY AT C WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL PVTEMP(N) C THE VECTOR OF PREDICTED VALUE FROM THE MODEL. C REAL STP C THE STEP SIZE CURRENTLY BEING EXAMINED FOR THE FINITE DIFFERENC C DERIVATIVE. C REAL TEMP C A TEMPORARY LOCATION IN WHICH THE CURRENT ESTIMATE OF THE C (NROW,J)TH ELEMENT OF XPLUSD IS STORED. C REAL XPLUSD(LDXPD,M) C THE ARRAY X + DELTA. * * C***FIRST EXECUTABLE STATEMENT SPVD * * C COMPUTE PREDICTED VALUES * TEMP = XPLUSD(NROW,J) XPLUSD(NROW,J) = XPLUSD(NROW,J) + STP ISTOPF = 0 CALL FUN(N,NP,M,BETA,XPLUSD,LDXPD,PVTEMP,ISTOPF) NFEV = NFEV + 1 XPLUSD(NROW,J) = TEMP * SPVD = PVTEMP(NROW) * RETURN END *SSCLB SUBROUTINE SSCLB + (NP,BETA,SSF) C***BEGIN PROLOGUE SSCLB C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE APPROPRIATE SCALE VALUES FOR BETA'S ACCORDING TO C THE ALGORITHM GIVEN IN THE PROLOGUES FOR SODR AND SODRC C***END PROLOGUE SSCLB * C...SCALAR ARGUMENTS INTEGER + NP * C...ARRAY ARGUMENTS REAL + BETA(NP),SSF(NP) * C...LOCAL SCALARS REAL + BMAX,BMIN,ONE,TEN,ZERO INTEGER + K LOGICAL + BIGDIF * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,LOG10,MAX,MIN,SQRT * C...DATA STATEMENTS DATA + ZERO,ONE,TEN + /0.0E0,1.0E0,10.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL BETA(NP) C THE FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C LOGICAL BIGDIF C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THERE IS A C SIGNIFICANT DIFFERENCE IN THE MAGNITUDES OF THE NONZERO C BETA'S (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). C REAL BMAX C THE LARGEST NONZERO MAGNITUDE. C REAL BMIN C THE SMALLEST NONZERO MAGNITUDE. C INTEGER K C AN INDEXING VARIABLE. C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ONE C THE VALUE 1.0E0. C REAL SSF(NP) C THE SCALE USED FOR THE BETA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL TEN C THE VALUE 10.0E0. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SSCLB * * BMAX = ABS(BETA(1)) DO 10 K=2,NP BMAX = MAX(BMAX,ABS(BETA(K))) 10 CONTINUE * IF (BMAX.EQ.ZERO) THEN * C ALL INPUT VALUES OF BETA ARE ZERO * DO 20 K=1,NP SSF(K) = ONE 20 CONTINUE * ELSE * C SOME OF THE INPUT VALUES ARE NONZERO * BMIN = BMAX DO 30 K=1,NP IF (BETA(K).NE.ZERO) THEN BMIN = MIN(BMIN,ABS(BETA(K))) END IF 30 CONTINUE BIGDIF = LOG10(BMAX)-LOG10(BMIN).GE.ONE DO 40 K=1,NP IF (BETA(K).EQ.ZERO) THEN SSF(K) = TEN/BMIN ELSE IF (BIGDIF) THEN SSF(K) = ONE/ABS(BETA(K)) ELSE SSF(K) = ONE/BMAX END IF END IF 40 CONTINUE * END IF * RETURN END *SSCLD SUBROUTINE SSCLD + (N,M,X,LDX,TT,LDTT) C***BEGIN PROLOGUE SSCLD C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE APPROPRIATE SCALE VALUES FOR DELTA'S ACCORDING TO C THE ALGORITHM GIVEN IN THE PROLOGUES FOR SODR AND SODRC C***END PROLOGUE SSCLD * C...SCALAR ARGUMENTS INTEGER + LDTT,LDX,M,N * C...ARRAY ARGUMENTS REAL + TT(LDTT,M),X(LDX,M) * C...LOCAL SCALARS REAL + ONE,TEN,XMAX,XMIN,ZERO INTEGER + I,J LOGICAL + BIGDIF * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,LOG10,MAX,MIN * C...DATA STATEMENTS DATA + ZERO,ONE,TEN + /0.0E0,1.0E0,10.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C LOGICAL BIGDIF C THE INDICATOR VARIABLE USED TO DESIGNATE WHETHER THERE IS A C SIGNIFICANT DIFFERENCE IN THE MAGNITUDES OF THE NONZERO C BETA'S (BIGDIF=.TRUE.) OR NOT (BIGDIF=.FALSE.). C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDTT C THE LEADING DIMENSION OF ARRAY TT. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL ONE C THE VALUE 1.0E0. C REAL TT(LDTT,M) C THE SCALE USED FOR THE DELTA'S. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL XMAX C THE LARGEST NONZERO MAGNITUDE. C REAL XMIN C THE SMALLEST NONZERO MAGNITUDE. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SSCLD * * DO 50 J=1,M XMAX = ABS(X(1,J)) DO 10 I=2,N XMAX = MAX(XMAX,ABS(X(I,J))) 10 CONTINUE * IF (XMAX.EQ.ZERO) THEN * C ALL INPUT VALUES OF X(I,J), I=1,...,N, ARE ZERO * DO 20 I=1,N TT(I,J) = ONE 20 CONTINUE * ELSE * C SOME OF THE INPUT VALUES ARE NONZERO * XMIN = XMAX DO 30 I=1,N IF (X(I,J).NE.ZERO) THEN XMIN = MIN(XMIN,ABS(X(I,J))) END IF 30 CONTINUE BIGDIF = LOG10(XMAX)-LOG10(XMIN).GE.ONE DO 40 I=1,N IF (X(I,J).NE.ZERO) THEN IF (BIGDIF) THEN TT(I,J) = ONE/ABS(X(I,J)) ELSE TT(I,J) = ONE/XMAX END IF ELSE TT(I,J) = TEN/XMIN END IF 40 CONTINUE END IF 50 CONTINUE * RETURN END *SSETN SUBROUTINE SSETN + (N,M,X,LDX,NROW) C***BEGIN PROLOGUE SSETN C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SELECT THE ROW AT WHICH THE DERIVATIVE WILL BE CHECKED C***END PROLOGUE SSETN * C...SCALAR ARGUMENTS INTEGER + LDX,M,N,NROW * C...ARRAY ARGUMENTS REAL + X(LDX,M) * C...LOCAL SCALARS INTEGER + I,J * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEX VARIABLE. C INTEGER J C AN INDEX VARIABLE. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NROW C THE USER-SUPPLIED NUMBER OF THE ROW OF THE INDEPENDENT C VARIABLE ARRAY AT WHICH THE DERIVATIVE IS TO BE CHECKED. C REAL X(LDX,M) C THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) * * C***FIRST EXECUTABLE STATEMENT SSETN * * IF ((NROW.GE.1) .AND. (NROW.LE.N)) RETURN * C SELECT FIRST ROW OF INDEPENDENT VARIABLES WHICH CONTAINS NO ZEROS C IF THERE IS ONE, OTHERWISE FIRST ROW IS USED. * DO 20 I = 1, N DO 10 J = 1, M IF (X(I,J).EQ.0.0) GO TO 20 10 CONTINUE NROW = I RETURN 20 CONTINUE * NROW = 1 * RETURN END *SUNPAC SUBROUTINE SUNPAC + (N2,V1,V2,IFIX) C***BEGIN PROLOGUE SUNPAC C***REFER TO SODR,SODRC C***ROUTINES CALLED SCOPY C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COPY THE ELEMENTS OF V1 INTO THE LOCATIONS OF V2 WHICH ARE C UNFIXED C***END PROLOGUE SUNPAC * C...SCALAR ARGUMENTS INTEGER + N2 * C...ARRAY ARGUMENTS REAL + V1(N2),V2(N2) INTEGER + IFIX(N2) * C...LOCAL SCALARS INTEGER + I,N1 * C...EXTERNAL SUBROUTINES EXTERNAL + SCOPY * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER IFIX(N2) C THE INDICATOR VALUES USED TO DESIGNATE WHETHER THE INDIVIDUAL C ELEMENTS OF V2 ARE FIXED AT THEIR INPUT VALUES OR NOT. C (FOR DETAILS, SEE DISCUSSION OF IFIXB AND IFIXX IN PROLOGUE OF C SUBROUTINE SODR OR SODRC.) C INTEGER N1 C THE NUMBER OF ITEMS IN V1. C INTEGER N2 C THE NUMBER OF ITEMS IN V2. C REAL V1(N2) C THE VECTOR OF THE UNFIXED ITEMS. C REAL V2(N2) C THE VECTOR OF THE FIXED AND UNFIXED ITEMS INTO WHICH THE C ELEMENTS OF V1 ARE TO BE INSERTED. * * C***FIRST EXECUTABLE STATEMENT SUNPAC * * N1 = 0 IF (IFIX(1).GE.0) THEN DO 10 I = 1,N2 IF (IFIX(I).NE.0) THEN N1 = N1 + 1 V2(I) = V1(N1) END IF 10 CONTINUE ELSE N1 = N2 CALL SCOPY(N2,V1,1,V2,1) END IF * RETURN END *SWDS SUBROUTINE SWDS + (N,M,W,WD,LDWD,T,LDT,WDT,LDWDT) C***BEGIN PROLOGUE SWDS C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SCALE MATRIX T USING W*D, I.E., COMPUTE C WDT = W*D*T C WHERE W AND D ARE DEFINED BY EQ.2 OF THE PROLOGUES FOR C SODR AND SODRC C***END PROLOGUE SWDS * C...SCALAR ARGUMENTS INTEGER + LDT,LDWD,LDWDT,M,N * C...ARRAY ARGUMENTS REAL + T(LDT,M),W(N),WD(LDWD,M),WDT(LDWDT,M) * C...LOCAL SCALARS REAL + TEMP,ZERO INTEGER + I,J * C...INTRINSIC FUNCTIONS INTRINSIC + ABS * C...DATA STATEMENTS DATA + ZERO + /0.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDT C THE LEADING DIMENSION OF ARRAY T. C INTEGER LDWD C THE LEADING DIMENSION OF ARRAY WD. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER LDWDT C THE LEADING DIMENSION OF ARRAY WDT. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL T(LDT,M) C THE ARRAY BEING SCALED BY W*D. C REAL TEMP C A TEMPORARY STORAGE LOCATION. C REAL W(N) C THE OBSERVATIONAL ERROR WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WD(LDWD,M) C THE DELTA WEIGHTS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C REAL WDT(LDWDT,M) C THE RESULTS OF SCALING ARRAY T BY W*D. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SWDS * * IF (N.EQ.0 .OR. M.EQ.0) RETURN * IF (W(1).GE.ZERO) THEN IF (WD(1,1).GT.ZERO) THEN IF (LDWD.GE.N) THEN DO 20 J=1,M DO 10 I=1,N WDT(I,J) = W(I)*WD(I,J)*T(I,J) 10 CONTINUE 20 CONTINUE ELSE DO 40 J=1,M DO 30 I=1,N WDT(I,J) = W(I)*WD(1,J)*T(I,J) 30 CONTINUE 40 CONTINUE END IF ELSE DO 60 J=1,M DO 50 I=1,N WDT(I,J) = W(I)*ABS(WD(1,1))*T(I,J) 50 CONTINUE 60 CONTINUE END IF ELSE IF (WD(1,1).GT.ZERO) THEN IF (LDWD.GE.N) THEN DO 80 J=1,M DO 70 I=1,N WDT(I,J) = WD(I,J)*T(I,J) 70 CONTINUE 80 CONTINUE ELSE DO 100 J=1,M TEMP = WD(1,J) DO 90 I=1,N WDT(I,J) = TEMP*T(I,J) 90 CONTINUE 100 CONTINUE END IF ELSE TEMP = ABS(WD(1,1)) DO 120 J=1,M DO 110 I=1,N WDT(I,J) = TEMP*T(I,J) 110 CONTINUE 120 CONTINUE END IF END IF * RETURN END *SWINF SUBROUTINE SWINF + (N,M,NP, + DELTAI,EPSI, + WSSI,WSSDEI,WSSEPI,RVARI, + PARTLI,SSTOLI,TAUFCI,EPSMAI,OLMAVI, + FJACBI,FJACXI,XPLUSI,BETACI,BETASI,BETANI,DELTSI, + DELTNI,DDELTI,FSI,FNI,SI,SSSI,SSI,SSFI,TI,TTI,TAUI, + ALPHAI,VCVI,OMEGAI,YTI,UI,QRAUXI,WRK1I,SEI,RCONDI, + ETAI,ACTRSI,PNORMI,PRERSI,RNORSI, + LWKMN) C***BEGIN PROLOGUE SWINF C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SET STORAGE LOCATIONS WITHIN REAL WORK SPACE C***END PROLOGUE SWINF * C...SCALAR ARGUMENTS INTEGER + ACTRSI,ALPHAI,BETACI,BETANI,BETASI,DDELTI,DELTAI,DELTNI,DELTSI, + EPSI,EPSMAI,ETAI,FJACBI,FJACXI,FNI,FSI,LWKMN,M,N,NP,OLMAVI, + OMEGAI,PARTLI,PNORMI,PRERSI,QRAUXI,RCONDI,RNORSI,RVARI,SEI,SI, + SSFI,SSI,SSSI,SSTOLI,TAUFCI,TAUI,TI,TTI,UI,VCVI,WRK1I, + WSSI,WSSDEI,WSSEPI,XPLUSI,YTI * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER ACTRSI C THE LOCATION IN ARRAY WORK OF C THE SAVED ACTUAL RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER ALPHAI C THE LOCATION IN ARRAY WORK OF C THE LEVENBERG-MARQUARDT PARAMETER. C INTEGER BETACI C THE STARTING LOCATION IN ARRAY WORK OF C THE CURRENT ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETANI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER BETASI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED VALUES OF THE UNFIXED BETA'S. C INTEGER DDELTI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (W*D)**2 * DELTA. C INTEGER DELTAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER DELTSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED ESTIMATED ERRORS IN THE INDEPENDENT VARIABLES. C INTEGER EPSI C THE STARTING LOCATION IN ARRAY WORK OF C THE (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER EPSMAI C THE LOCATION IN ARRAY WORK OF C THE VALUE OF MACHINE PRECISION. C INTEGER ETAI C THE LOCATION IN ARRAY WORK OF C THE RELATIVE NOISE IN THE FUNCTION RESULTS. C INTEGER FJACBI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO BETA. C INTEGER FJACXI C THE STARTING LOCATION IN ARRAY WORK OF C THE JACOBIAN WITH RESPECT TO X. C INTEGER FNI C THE STARTING LOCATION IN ARRAY WORK OF C THE NEW (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER FSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SAVED (WEIGHTED) ESTIMATED VALUES OF EPSILON. C INTEGER LWKMN C THE MINIMUM ACCEPTABLE LENGTH OF ARRAY WORK. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN THE INDEPENDENT VARIABLE. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER N C THE NUMBER OF OBSERVATIONS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER NP C THE NUMBER OF FUNCTION PARAMETERS. C (FOR DETAILS, SEE ODRPACK REFERENCE GUIDE.) C INTEGER OLMAVI C THE LOCATION IN ARRAY WORK OF C THE AVERAGE NUMBER OF LEVENBERG-MARQUARDT STEPS PER ITERATION. C INTEGER OMEGAI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY (I-FJACX*INV(P)*TRANS(FJACX))**(-1/2) WHERE C P = TRANS(FJACX)*FJACX + D**2 + ALPHA*TT**2 C INTEGER PARTLI C THE LOCATION IN ARRAY WORK OF C THE PARAMETER CONVERGENCE STOPPING CRITERIA. C INTEGER PNORMI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SCALED ESTIMATED PARAMETERS. C INTEGER PRERSI C THE LOCATION IN ARRAY WORK OF C THE SAVED PREDICTED RELATIVE REDUCTION IN THE SUM-OF-SQUARES C OF THE WEIGHTED OBSERVATIONAL ERRORS. C INTEGER QRAUXI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY REQUIRED TO RECOVER THE ORTHOGONAL PART OF THE C Q-R DECOMPOSITION. C INTEGER RCONDI C THE LOCATION IN ARRAY WORK OF C THE APPROXIMATE RECIPROCAL CONDITION OF C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER RNORSI C THE LOCATION IN ARRAY WORK OF C THE NORM OF THE SAVED WEIGHTED OBSERVATIONAL ERRORS. C INTEGER RVARI C THE LOCATION IN ARRAY WORK OF C THE RESIDUAL VARIANCE. C INTEGER SEI C THE STARTING LOCATION IN ARRAY WORK OF C THE STANDARD ERRORS FOR THE PARAMETERS, ALSO USED AS A C WORK ARRAY. C INTEGER SI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED BETA'S. C INTEGER SSFI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE BETA'S. C INTEGER SSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE ESTIMATED BETA'S. C INTEGER SSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY USED TO COMPUTED VARIOUS SUMS-OF-SQUARES. C INTEGER SSTOLI C THE LOCATION IN ARRAY WORK OF C THE SUM-OF-SQUARES CONVERGENCE STOPPING CRITERIA. C INTEGER TAUFCI C THE LOCATION IN ARRAY WORK OF C THE FACTOR USED TO COMPUTE THE INITIAL TRUST REGION DIAMETER. C INTEGER TAUI C THE LOCATION IN ARRAY WORK OF C THE TRUST REGION DIAMETER. C INTEGER TI C THE STARTING LOCATION IN ARRAY WORK OF C THE STEP FOR THE ESTIMATED DELTA'S. C INTEGER TTI C THE STARTING LOCATION IN ARRAY WORK OF C THE SCALE USED FOR THE DELTA'S. C INTEGER UI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE NULL VECTOR FOR C THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER VCVI C THE STARTING LOCATION IN ARRAY WORK OF C THE APPROXIMATE VARIANCE COVARIANCE MATRIX, ALSO USED C TO STORE THE ARRAY INV(DIAG(SQRT(OMEGA(I)),I=1,...,N))*FJACB. C INTEGER WRK1I C THE STARTING LOCATION IN ARRAY WORK OF C A WORK ARRAY. C INTEGER WSSI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS AND DELTAS. C INTEGER WSSDEI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED DELTAS. C INTEGER WSSEPI C THE STARTING LOCATION IN ARRAY WORK OF C THE SUM OF THE SQUARES OF THE WEIGHTED EPSILONS. C INTEGER XPLUSI C THE STARTING LOCATION IN ARRAY WORK OF C THE ARRAY X + DELTA. C INTEGER YTI C THE STARTING LOCATION IN WORK OF C THE ARRAY -(DIAG(SQRT(OMEGA(I)),I=1,...,N)*(G1-V*INV(E)*D*G2). * * C***FIRST EXECUTABLE STATEMENT SWINF * * IF (N.GE.1 .AND. NP.GE.1 .AND. M.GE.1) THEN DELTAI = 1 EPSI = DELTAI + N*M WSSI = EPSI + N WSSDEI = WSSI + 1 WSSEPI = WSSDEI + 1 RVARI = WSSEPI + 1 PARTLI = RVARI + 1 SSTOLI = PARTLI + 1 TAUFCI = SSTOLI + 1 EPSMAI = TAUFCI + 1 OLMAVI = EPSMAI + 1 FJACBI = OLMAVI + 1 FJACXI = FJACBI + N*NP XPLUSI = FJACXI + N*M BETACI = XPLUSI + N*M BETASI = BETACI + NP BETANI = BETASI + NP DELTSI = BETANI + NP DELTNI = DELTSI + N*M DDELTI = DELTNI + N*M FSI = DDELTI + N*M FNI = FSI + N SI = FNI + N SSSI = SI + NP SSI = SSSI + N*M + N SSFI = SSI + NP TI = SSFI + NP TTI = TI + N*M TAUI = TTI + N*M ALPHAI = TAUI + 1 VCVI = ALPHAI + 1 OMEGAI = VCVI + N*NP YTI = OMEGAI + N UI = YTI + N QRAUXI = UI + N WRK1I = QRAUXI + NP SEI = WRK1I + N*M RCONDI = SEI + NP ETAI = RCONDI + 1 ACTRSI = ETAI + 1 PNORMI = ACTRSI + 1 PRERSI = PNORMI + 1 RNORSI = PRERSI + 1 LWKMN = RNORSI ELSE DELTAI = 1 EPSI = 1 WSSI = 1 WSSDEI = 1 WSSEPI = 1 RVARI = 1 PARTLI = 1 SSTOLI = 1 TAUFCI = 1 EPSMAI = 1 OLMAVI = 1 FJACBI = 1 FJACXI = 1 XPLUSI = 1 BETACI = 1 BETASI = 1 BETANI = 1 DELTSI = 1 DELTNI = 1 DDELTI = 1 FSI = 1 FNI = 1 SI = 1 SSSI = 1 SSI = 1 SSFI = 1 TI = 1 TTI = 1 TAUI = 1 ALPHAI = 1 VCVI = 1 OMEGAI = 1 YTI = 1 UI = 1 QRAUXI = 1 WRK1I = 1 SEI = 1 RCONDI = 1 ETAI = 1 ACTRSI = 1 PNORMI = 1 PRERSI = 1 RNORSI = 1 LWKMN = 1 END IF * RETURN END *SXPY SUBROUTINE SXPY + (N,M,X,LDX,Y,LDY,XPY,LDXPY) C***BEGIN PROLOGUE SXPY C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE COMPUTE XPY = X + Y C***END PROLOGUE SXPY * C...SCALAR ARGUMENTS INTEGER + LDX,LDXPY,LDY,M,N * C...ARRAY ARGUMENTS REAL + X(LDX,M),XPY(LDXPY,M),Y(LDY,M) * C...LOCAL SCALARS INTEGER + I,J * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDX C THE LEADING DIMENSION OF ARRAY X. C INTEGER LDXPY C THE LEADING DIMENSION OF ARRAY XPY. C INTEGER LDY C THE LEADING DIMENSION OF ARRAY Y. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN ARRAYS X AND Y TO BE ADDED C TOGETHER. C INTEGER N C THE NUMBER OF ROWS OF DATA IN ARRAYS X AND Y TO BE ADDED C TOGETHER. C REAL X(LDX,M) C THE FIRST OF THE TWO ARRAYS TO BE ADDED TOGETHER. C REAL XPY(LDXPY,M) C THE SUM OF THE TWO ARRAYS TO BE ADDED TOGETHER. C REAL Y(LDY,M) C THE SECOND OF THE TWO ARRAYS TO BE ADDED TOGETHER. * * C***FIRST EXECUTABLE STATEMENT SXPY * * DO 20 J=1,M DO 10 I=1,N XPY(I,J) = X(I,J) + Y(I,J) 10 CONTINUE 20 CONTINUE * RETURN END *SZERO SUBROUTINE SZERO + (N,M,A,LDA) C***BEGIN PROLOGUE SZERO C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO, BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE SET A = ZERO C***END PROLOGUE SZERO * C...SCALAR ARGUMENTS INTEGER + LDA,M,N * C...ARRAY ARGUMENTS REAL + A(LDA,M) * C...LOCAL SCALARS REAL + ZERO INTEGER + I,J * C...DATA STATEMENTS DATA + ZERO + /0.0E0/ * C...VARIABLE DEFINITIONS (ALPHABETICALLY) C REAL A(LDA,M) C THE ARRAY TO BE SET TO ZERO. C INTEGER I C AN INDEXING VARIABLE. C INTEGER J C AN INDEXING VARIABLE. C INTEGER LDA C THE LEADING DIMENSION OF ARRAY A. C INTEGER M C THE NUMBER OF COLUMNS OF DATA IN ARRAY A TO BE SET TO ZERO. C INTEGER N C THE NUMBER OF ROWS OF DATA IN ARRAY A TO BE SET TO ZERO. C REAL ZERO C THE VALUE 0.0E0. * * C***FIRST EXECUTABLE STATEMENT SZERO * * DO 20 J=1,M DO 10 I=1,N A(I,J) = ZERO 10 CONTINUE 20 CONTINUE * RETURN END *ISAMAX INTEGER FUNCTION ISAMAX(N,SX,INCX) C***BEGIN PROLOGUE ISAMAX C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A2 C***KEYWORDS BLAS,LINEAR ALGEBRA,MAXIMUM COMPONENT,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE FIND LARGEST COMPONENT OF S.P. VECTOR C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C SX SINGLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF SX C --OUTPUT-- C ISAMAX SMALLEST INDEX (ZERO IF N .LE. 0) C FIND SMALLEST INDEX OF MAXIMUM MAGNITUDE OF SINGLE PRECISION SX. C ISAMAX = FIRST I, I = 1 TO N, TO MINIMIZE ABS(SX(1-INCX+I*INCX) C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE ISAMAX * C...SCALAR ARGUMENTS INTEGER + INCX,N * C...ARRAY ARGUMENTS REAL SX(*) * C...LOCAL SCALARS REAL SMAX,XMAG INTEGER + I,II,NS * C...INTRINSIC FUNCTIONS INTRINSIC + ABS * * C***FIRST EXECUTABLE STATEMENT ISAMAX * * ISAMAX = 0 IF(N.LE.0) RETURN ISAMAX = 1 IF(N.LE.1)RETURN IF(INCX.EQ.1)GOTO 20 * C CODE FOR INCREMENTS NOT EQUAL TO 1. * SMAX = ABS(SX(1)) NS = N*INCX II = 1 DO 10 I=1,NS,INCX XMAG = ABS(SX(I)) IF(XMAG.LE.SMAX) GO TO 5 ISAMAX = II SMAX = XMAG 5 II = II + 1 10 CONTINUE RETURN * C CODE FOR INCREMENTS EQUAL TO 1. * 20 SMAX = ABS(SX(1)) DO 30 I = 2,N XMAG = ABS(SX(I)) IF(XMAG.LE.SMAX) GO TO 30 ISAMAX = I SMAX = XMAG 30 CONTINUE RETURN END *SASUM REAL FUNCTION SASUM(N,SX,INCX) C***BEGIN PROLOGUE SASUM C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A3A C***KEYWORDS ADD,BLAS,LINEAR ALGEBRA,MAGNITUDE,SUM,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE SUM OF MAGNITUDES OF S.P VECTOR COMPONENTS C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C SX SINGLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF SX C --OUTPUT-- C SASUM SINGLE PRECISION RESULT (ZERO IF N .LE. 0) C RETURNS SUM OF MAGNITUDES OF SINGLE PRECISION SX. C SASUM = SUM FROM 0 TO N-1 OF ABS(SX(1+I*INCX)) C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE SASUM * C...SCALAR ARGUMENTS INTEGER + INCX,N * C...ARRAY ARGUMENTS REAL SX(*) * C...LOCAL SCALARS INTEGER + I,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,MOD * * C***FIRST EXECUTABLE STATEMENT SASUM * * SASUM = 0.0E0 IF(N.LE.0)RETURN IF(INCX.EQ.1)GOTO 20 * C CODE FOR INCREMENTS NOT EQUAL TO 1. * NS = N*INCX DO 10 I=1,NS,INCX SASUM = SASUM + ABS(SX(I)) 10 CONTINUE RETURN * C CODE FOR INCREMENTS EQUAL TO 1. * * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6. * 20 M = MOD(N,6) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SASUM = SASUM + ABS(SX(I)) 30 CONTINUE IF( N .LT. 6 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,6 SASUM = SASUM + ABS(SX(I)) + ABS(SX(I + 1)) + ABS(SX(I + 2)) 1 + ABS(SX(I + 3)) + ABS(SX(I + 4)) + ABS(SX(I + 5)) 50 CONTINUE RETURN END *SAXPY SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY) C***BEGIN PROLOGUE SAXPY C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A7 C***KEYWORDS BLAS,LINEAR ALGEBRA,TRIAD,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE S.P. COMPUTATION Y = A*X + Y C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C SA SINGLE PRECISION SCALAR MULTIPLIER C SX SINGLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF SX C SY SINGLE PRECISION VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF SY C --OUTPUT-- C SY SINGLE PRECISION RESULT (UNCHANGED IF N .LE. 0) C OVERWRITE SINGLE PRECISION SY WITH SINGLE PRECISION SA*SX +SY. C FOR I = 0 TO N-1, REPLACE SY(LY+I*INCY) WITH SA*SX(LX+I*INCX) + C SY(LY+I*INCY), WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N C AND LY IS DEFINED IN A SIMILAR WAY USING INCY. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE SAXPY * C...SCALAR ARGUMENTS REAL SA INTEGER + INCX,INCY,N * C...ARRAY ARGUMENTS REAL SX(*),SY(*) * C...LOCAL SCALARS INTEGER + I,IX,IY,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT SAXPY * * IF(N.LE.0.OR.SA.EQ.0.E0) RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE * C CODE FOR NONEQUAL OR NONPOSITIVE INCREMENTS. * IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N SY(IY) = SY(IY) + SA*SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * C CODE FOR BOTH INCREMENTS EQUAL TO 1 * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 4. * 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SY(I) = SY(I) + SA*SX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 SY(I) = SY(I) + SA*SX(I) SY(I + 1) = SY(I + 1) + SA*SX(I + 1) SY(I + 2) = SY(I + 2) + SA*SX(I + 2) SY(I + 3) = SY(I + 3) + SA*SX(I + 3) 50 CONTINUE RETURN * C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. * 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX SY(I) = SA*SX(I) + SY(I) 70 CONTINUE RETURN END *SCHEX SUBROUTINE SCHEX(R,LDR,P,K,L,Z,LDZ,NZ,C,S,JOB) C***BEGIN PROLOGUE SCHEX C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D7B C***KEYWORDS CHOLESKY DECOMPOSITION,EXCHANGE,LINEAR ALGEBRA,LINPACK, C MATRIX,POSITIVE DEFINITE C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE UPDATES THE CHOLESKY FACTORIZATION A=TRANS(R)*R OF A C POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL C PERMUTATIONS OF THE FORM TRANS(E)*A*E WHERE E IS A C PERMUTATION MATRIX. C***DESCRIPTION C SCHEX UPDATES THE CHOLESKY FACTORIZATION C A = TRANS(R)*R C OF A POSITIVE DEFINITE MATRIX A OF ORDER P UNDER DIAGONAL C PERMUTATIONS OF THE FORM C TRANS(E)*A*E C WHERE E IS A PERMUTATION MATRIX. SPECIFICALLY, GIVEN C AN UPPER TRIANGULAR MATRIX R AND A PERMUTATION MATRIX C E (WHICH IS SPECIFIED BY K, L, AND JOB), SCHEX DETERMINES C AN ORTHOGONAL MATRIX U SUCH THAT C U*R*E = RR, C WHERE RR IS UPPER TRIANGULAR. AT THE USERS OPTION, THE C TRANSFORMATION U WILL BE MULTIPLIED INTO THE ARRAY Z. C IF A = TRANS(X)*X, SO THAT R IS THE TRIANGULAR PART OF THE C QR FACTORIZATION OF X, THEN RR IS THE TRIANGULAR PART OF THE C QR FACTORIZATION OF X*E, I.E., X WITH ITS COLUMNS PERMUTED. C FOR A LESS TERSE DESCRIPTION OF WHAT SCHEX DOES AND HOW C IT MAY BE APPLIED, SEE THE LINPACK GUIDE. C THE MATRIX Q IS DETERMINED AS THE PRODUCT U(L-K)*...*U(1) C OF PLANE ROTATIONS OF THE FORM C ( C(I) S(I) ) C ( ) , C ( -S(I) C(I) ) C WHERE C(I) IS REAL. THE ROWS THESE ROTATIONS OPERATE ON C ARE DESCRIBED BELOW. C THERE ARE TWO TYPES OF PERMUTATIONS, WHICH ARE DETERMINED C BY THE VALUE OF JOB. C 1. RIGHT CIRCULAR SHIFT (JOB = 1). C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER. C 1,...,K-1,L,K,K+1,...,L-1,L+1,...,P. C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) C ACTS IN THE (L-I,L-I+1)-PLANE. C 2. LEFT CIRCULAR SHIFT (JOB = 2). C THE COLUMNS ARE REARRANGED IN THE FOLLOWING ORDER C 1,...,K-1,K+1,K+2,...,L,K,L+1,...,P. C U IS THE PRODUCT OF L-K ROTATIONS U(I), WHERE U(I) C ACTS IN THE (K+I-1,K+I)-PLANE. C ON ENTRY C R REAL(LDR,P), WHERE LDR .GE. P. C R CONTAINS THE UPPER TRIANGULAR FACTOR C THAT IS TO BE UPDATED. ELEMENTS OF R C BELOW THE DIAGONAL ARE NOT REFERENCED. C LDR INTEGER. C LDR IS THE LEADING DIMENSION OF THE ARRAY R. C P INTEGER. C P IS THE ORDER OF THE MATRIX R. C K INTEGER. C K IS THE FIRST COLUMN TO BE PERMUTED. C L INTEGER. C L IS THE LAST COLUMN TO BE PERMUTED. C L MUST BE STRICTLY GREATER THAN K. C Z REAL(LDZ,NZ), WHERE LDZ.GE.P. C Z IS AN ARRAY OF NZ P-VECTORS INTO WHICH THE C TRANSFORMATION U IS MULTIPLIED. Z IS C NOT REFERENCED IF NZ = 0. C LDZ INTEGER. C LDZ IS THE LEADING DIMENSION OF THE ARRAY Z. C NZ INTEGER. C NZ IS THE NUMBER OF COLUMNS OF THE MATRIX Z. C JOB INTEGER. C JOB DETERMINES THE TYPE OF PERMUTATION. C JOB = 1 RIGHT CIRCULAR SHIFT. C JOB = 2 LEFT CIRCULAR SHIFT. C ON RETURN C R CONTAINS THE UPDATED FACTOR. C Z CONTAINS THE UPDATED MATRIX Z. C C REAL(P). C C CONTAINS THE COSINES OF THE TRANSFORMING ROTATIONS. C S REAL(P). C S CONTAINS THE SINES OF THE TRANSFORMING ROTATIONS. C LINPACK. THIS VERSION DATED 08/14/78 . C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SROTG C***END PROLOGUE SCHEX * C...SCALAR ARGUMENTS INTEGER + JOB,K,L,LDR,LDZ,NZ,P * C...ARRAY ARGUMENTS REAL C(*),R(LDR,*),S(*),Z(LDZ,*) * C...LOCAL SCALARS REAL T,T1 INTEGER + I,II,IL,IU,J,JJ,KM1,KP1,LM1,LMK * C...EXTERNAL SUBROUTINES EXTERNAL + SROTG * C...INTRINSIC FUNCTIONS INTRINSIC + MAX0,MIN0 * * C***FIRST EXECUTABLE STATEMENT SCHEX * * KM1 = K - 1 KP1 = K + 1 LMK = L - K LM1 = L - 1 * C PERFORM THE APPROPRIATE TASK. * GO TO (10,130), JOB * C RIGHT CIRCULAR SHIFT. * 10 CONTINUE * C REORDER THE COLUMNS. * DO 20 I = 1, L II = L - I + 1 S(I) = R(II,L) 20 CONTINUE DO 40 JJ = K, LM1 J = LM1 - JJ + K DO 30 I = 1, J R(I,J+1) = R(I,J) 30 CONTINUE R(J+1,J+1) = 0.0E0 40 CONTINUE IF (K .EQ. 1) GO TO 60 DO 50 I = 1, KM1 II = L - I + 1 R(I,K) = S(II) 50 CONTINUE 60 CONTINUE * C CALCULATE THE ROTATIONS. * T = S(1) DO 70 I = 1, LMK T1 = S(I) CALL SROTG(S(I+1),T,C(I),T1) S(I) = T1 T = S(I+1) 70 CONTINUE R(K,K) = T DO 90 J = KP1, P IL = MAX0(1,L-J+1) DO 80 II = IL, LMK I = L - II T = C(II)*R(I,J) + S(II)*R(I+1,J) R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) R(I,J) = T 80 CONTINUE 90 CONTINUE * C IF REQUIRED, APPLY THE TRANSFORMATIONS TO Z. * IF (NZ .LT. 1) GO TO 120 DO 110 J = 1, NZ DO 100 II = 1, LMK I = L - II T = C(II)*Z(I,J) + S(II)*Z(I+1,J) Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) Z(I,J) = T 100 CONTINUE 110 CONTINUE 120 CONTINUE GO TO 260 * C LEFT CIRCULAR SHIFT * 130 CONTINUE * C REORDER THE COLUMNS * DO 140 I = 1, K II = LMK + I S(II) = R(I,K) 140 CONTINUE DO 160 J = K, LM1 DO 150 I = 1, J R(I,J) = R(I,J+1) 150 CONTINUE JJ = J - KM1 S(JJ) = R(J+1,J+1) 160 CONTINUE DO 170 I = 1, K II = LMK + I R(I,L) = S(II) 170 CONTINUE DO 180 I = KP1, L R(I,L) = 0.0E0 180 CONTINUE * C REDUCTION LOOP. * DO 220 J = K, P IF (J .EQ. K) GO TO 200 * C APPLY THE ROTATIONS. * IU = MIN0(J-1,L-1) DO 190 I = K, IU II = I - K + 1 T = C(II)*R(I,J) + S(II)*R(I+1,J) R(I+1,J) = C(II)*R(I+1,J) - S(II)*R(I,J) R(I,J) = T 190 CONTINUE 200 CONTINUE IF (J .GE. L) GO TO 210 JJ = J - K + 1 T = S(JJ) CALL SROTG(R(J,J),T,C(JJ),S(JJ)) 210 CONTINUE 220 CONTINUE * C APPLY THE ROTATIONS TO Z. * IF (NZ .LT. 1) GO TO 250 DO 240 J = 1, NZ DO 230 I = K, LM1 II = I - KM1 T = C(II)*Z(I,J) + S(II)*Z(I+1,J) Z(I+1,J) = C(II)*Z(I+1,J) - S(II)*Z(I,J) Z(I,J) = T 230 CONTINUE 240 CONTINUE 250 CONTINUE 260 CONTINUE RETURN END *SCOPY SUBROUTINE SCOPY(N,SX,INCX,SY,INCY) C***BEGIN PROLOGUE SCOPY C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A5 C***KEYWORDS BLAS,COPY,LINEAR ALGEBRA,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE COPY S.P. VECTOR Y = X C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C SX SINGLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF SX C SY SINGLE PRECISION VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF SY C --OUTPUT-- C SY COPY OF VECTOR SX (UNCHANGED IF N .LE. 0) C COPY SINGLE PRECISION SX TO SINGLE PRECISION SY. C FOR I = 0 TO N-1, COPY SX(LX+I*INCX) TO SY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE SCOPY * C...SCALAR ARGUMENTS INTEGER + INCX,INCY,N * C...ARRAY ARGUMENTS REAL SX(*),SY(*) * C...LOCAL SCALARS INTEGER + I,IX,IY,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT SCOPY * * IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE * C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. * IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N SY(IY) = SX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * C CODE FOR BOTH INCREMENTS EQUAL TO 1 * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 7. * 20 M = MOD(N,7) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SY(I) = SX(I) 30 CONTINUE IF( N .LT. 7 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,7 SY(I) = SX(I) SY(I + 1) = SX(I + 1) SY(I + 2) = SX(I + 2) SY(I + 3) = SX(I + 3) SY(I + 4) = SX(I + 4) SY(I + 5) = SX(I + 5) SY(I + 6) = SX(I + 6) 50 CONTINUE RETURN * C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. * 60 CONTINUE NS = N*INCX DO 70 I=1,NS,INCX SY(I) = SX(I) 70 CONTINUE RETURN END *SDOT REAL FUNCTION SDOT(N,SX,INCX,SY,INCY) C***BEGIN PROLOGUE SDOT C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A4 C***KEYWORDS BLAS,INNER PRODUCT,LINEAR ALGEBRA,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE S.P. INNER PRODUCT OF S.P. VECTORS C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C SX SINGLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF SX C SY SINGLE PRECISION VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF SY C --OUTPUT-- C SDOT SINGLE PRECISION DOT PRODUCT (ZERO IF N .LE. 0) C RETURNS THE DOT PRODUCT OF SINGLE PRECISION SX AND SY. C SDOT = SUM FOR I = 0 TO N-1 OF SX(LX+I*INCX) * SY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE SDOT * C...SCALAR ARGUMENTS INTEGER + INCX,INCY,N * C...ARRAY ARGUMENTS REAL SX(*),SY(*) * C...LOCAL SCALARS INTEGER + I,IX,IY,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT SDOT * * SDOT = 0.0E0 IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1)5,20,60 5 CONTINUE * C CODE FOR UNEQUAL INCREMENTS OR NONPOSITIVE INCREMENTS. * IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N SDOT = SDOT + SX(IX)*SY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * C CODE FOR BOTH INCREMENTS EQUAL TO 1 * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. * 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SDOT = SDOT + SX(I)*SY(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SDOT = SDOT + SX(I)*SY(I) + SX(I + 1)*SY(I + 1) + 1 SX(I + 2)*SY(I + 2) + SX(I + 3)*SY(I + 3) + SX(I + 4)*SY(I + 4) 50 CONTINUE RETURN * C CODE FOR POSITIVE EQUAL INCREMENTS .NE.1. * 60 CONTINUE NS=N*INCX DO 70 I=1,NS,INCX SDOT = SDOT + SX(I)*SY(I) 70 CONTINUE RETURN END *SNRM2 REAL FUNCTION SNRM2(N,SX,INCX) C***BEGIN PROLOGUE SNRM2 C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A3B C***KEYWORDS BLAS,EUCLIDEAN,L2,LENGTH,LINEAR ALGEBRA,NORM,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE EUCLIDEAN LENGTH (L2 NORM) OF S.P. VECTOR C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C SX SINGLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF SX C --OUTPUT-- C SNRM2 SINGLE PRECISION RESULT (ZERO IF N .LE. 0) C EUCLIDEAN NORM OF THE N-VECTOR STORED IN SX() WITH STORAGE C INCREMENT INCX . C IF N .LE. 0, RETURN WITH RESULT = 0. C IF N .GE. 1, THEN INCX MUST BE .GE. 1 C C. L. LAWSON, 1978 JAN 08 C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE C HOPEFULLY APPLICABLE TO ALL MACHINES. C CUTLO = MAXIMUM OF SQRT(U/EPS) OVER ALL KNOWN MACHINES. C CUTHI = MINIMUM OF SQRT(V) OVER ALL KNOWN MACHINES. C WHERE C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) C V = LARGEST NO. (OVERFLOW LIMIT) C BRIEF OUTLINE OF ALGORITHM.. C PHASE 1 SCANS ZERO COMPONENTS. C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. C VALUES FOR CUTLO AND CUTHI.. C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE C UNIVAC AND DEC AT 2**(-103) C THUS CUTLO = 2**(-51) = 4.44089E-16 C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. C THUS CUTHI = 2**(63.5) = 1.30438E19 C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. C THUS CUTLO = 2**(-33.5) = 8.23181D-11 C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE SNRM2 * C...SCALAR ARGUMENTS INTEGER + INCX,N * C...ARRAY ARGUMENTS REAL SX(*) * C...LOCAL SCALARS REAL CUTHI,CUTLO,HITEST,ONE,SUM,XMAX,ZERO INTEGER + I,J,NEXT,NN * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,FLOAT,SQRT * C...DATA STATEMENTS DATA + ZERO,ONE/0.0E0,1.0E0/ DATA + CUTLO,CUTHI/4.441E-16,1.304E19/ * * C***FIRST EXECUTABLE STATEMENT SNRM2 * * XMAX = ZERO IF(N .GT. 0) GO TO 10 SNRM2 = ZERO GO TO 300 * 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N * INCX C BEGIN MAIN LOOP I = 1 C 20 GO TO NEXT,(30, 50, 70, 110) 20 GO TO NEXT 30 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO * C PHASE 1. SUM IS ZERO * 50 IF( SX(I) .EQ. ZERO) GO TO 200 IF( ABS(SX(I)) .GT. CUTLO) GO TO 85 * C PREPARE FOR PHASE 2. ASSIGN 70 TO NEXT GO TO 105 * C PREPARE FOR PHASE 4. * 100 I = J ASSIGN 110 TO NEXT SUM = (SUM / SX(I)) / SX(I) 105 XMAX = ABS(SX(I)) GO TO 115 * C PHASE 2. SUM IS SMALL. C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. * 70 IF( ABS(SX(I)) .GT. CUTLO ) GO TO 75 * C COMMON CODE FOR PHASES 2 AND 4. C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. * 110 IF( ABS(SX(I)) .LE. XMAX ) GO TO 115 SUM = ONE + SUM * (XMAX / SX(I))**2 XMAX = ABS(SX(I)) GO TO 200 * 115 SUM = SUM + (SX(I)/XMAX)**2 GO TO 200 * * C PREPARE FOR PHASE 3. * 75 SUM = (SUM * XMAX) * XMAX * * C FOR REAL OR D.P. SET HITEST = CUTHI/N C FOR COMPLEX SET HITEST = CUTHI/(2*N) * 85 HITEST = CUTHI/FLOAT( N ) * C PHASE 3. SUM IS MID-RANGE. NO SCALING. * DO 95 J =I,NN,INCX IF(ABS(SX(J)) .GE. HITEST) GO TO 100 95 SUM = SUM + SX(J)**2 SNRM2 = SQRT( SUM ) GO TO 300 * 200 CONTINUE I = I + INCX IF ( I .LE. NN ) GO TO 20 * C END OF MAIN LOOP. * C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. * SNRM2 = XMAX * SQRT(SUM) 300 CONTINUE RETURN END *SPODI SUBROUTINE SPODI(A,LDA,N,DET,JOB) C***BEGIN PROLOGUE SPODI C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2B1B,D3B1B C***KEYWORDS DETERMINANT,FACTOR,INVERSE,LINEAR ALGEBRA,LINPACK,MATRIX, C POSITIVE DEFINITE C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN C REAL SYMMETRIC POSITIVE DEFINITE MATRIX (SEE ABSTRACT) C USING THE FACTORS COMPUTED BY SPOCO, SPOFA OR SQRDC. C***DESCRIPTION C SPODI COMPUTES THE DETERMINANT AND INVERSE OF A CERTAIN C REAL SYMMETRIC POSITIVE DEFINITE MATRIX (SEE BELOW) C USING THE FACTORS COMPUTED BY SPOCO, SPOFA OR SQRDC. C ON ENTRY C A REAL(LDA, N) C THE OUTPUT A FROM SPOCO OR SPOFA C OR THE OUTPUT X FROM SQRDC. C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C N INTEGER C THE ORDER OF THE MATRIX A . C JOB INTEGER C = 11 BOTH DETERMINANT AND INVERSE. C = 01 INVERSE ONLY. C = 10 DETERMINANT ONLY. C ON RETURN C A IF SPOCO OR SPOFA WAS USED TO FACTOR A , THEN C SPODI PRODUCES THE UPPER HALF OF INVERSE(A) . C IF SQRDC WAS USED TO DECOMPOSE X , THEN C SPODI PRODUCES THE UPPER HALF OF INVERSE(TRANS(X)*X), C WHERE TRANS(X) IS THE TRANSPOSE. C ELEMENTS OF A BELOW THE DIAGONAL ARE UNCHANGED. C IF THE UNITS DIGIT OF JOB IS ZERO, A IS UNCHANGED. C DET REAL(2) C DETERMINANT OF A OR OF TRANS(X)*X IF REQUESTED. C OTHERWISE NOT REFERENCED. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. DET(1) .LT. 10.0 C OR DET(1) .EQ. 0.0 . C ERROR CONDITION C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY C AND IF SPOCO OR SPOFA HAS SET INFO .EQ. 0 . C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SSCAL C***END PROLOGUE SPODI * C...SCALAR ARGUMENTS INTEGER JOB,LDA,N * C...ARRAY ARGUMENTS REAL A(LDA,*),DET(*) * C...LOCAL SCALARS REAL S,T INTEGER I,J,JM1,K,KP1 * C...EXTERNAL SUBROUTINES EXTERNAL SAXPY,SSCAL * C...INTRINSIC FUNCTIONS INTRINSIC MOD * * C***FIRST EXECUTABLE STATEMENT SPODI * * IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0E0 DET(2) = 0.0E0 S = 10.0E0 DO 50 I = 1, N DET(1) = A(I,I)**2*DET(1) C ...EXIT IF (DET(1) .EQ. 0.0E0) GO TO 60 10 IF (DET(1) .GE. 1.0E0) GO TO 20 DET(1) = S*DET(1) DET(2) = DET(2) - 1.0E0 GO TO 10 20 CONTINUE 30 IF (DET(1) .LT. S) GO TO 40 DET(1) = DET(1)/S DET(2) = DET(2) + 1.0E0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE * C COMPUTE INVERSE(R) * IF (MOD(JOB,10) .EQ. 0) GO TO 140 DO 100 K = 1, N A(K,K) = 1.0E0/A(K,K) T = -A(K,K) CALL SSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0E0 CALL SAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE * C FORM INVERSE(R) * TRANS(INVERSE(R)) * DO 130 J = 1, N JM1 = J - 1 IF (JM1 .LT. 1) GO TO 120 DO 110 K = 1, JM1 T = A(K,J) CALL SAXPY(K,T,A(1,J),1,A(1,K),1) 110 CONTINUE 120 CONTINUE T = A(J,J) CALL SSCAL(J,T,A(1,J),1) 130 CONTINUE 140 CONTINUE RETURN END *SQRDC SUBROUTINE SQRDC(X,LDX,N,P,QRAUX,JPVT,WORK,JOB) C***BEGIN PROLOGUE SQRDC C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D5 C***KEYWORDS DECOMPOSITION,LINEAR ALGEBRA,LINPACK,MATRIX, C ORTHOGONAL TRIANGULAR C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING IS C A USERS OPTION. C***DESCRIPTION C SQRDC USES HOUSEHOLDER TRANSFORMATIONS TO COMPUTE THE QR C FACTORIZATION OF AN N BY P MATRIX X. COLUMN PIVOTING C BASED ON THE 2-NORMS OF THE REDUCED COLUMNS MAY BE C PERFORMED AT THE USER'S OPTION. C ON ENTRY C X REAL(LDX,P), WHERE LDX .GE. N. C X CONTAINS THE MATRIX WHOSE DECOMPOSITION IS TO BE C COMPUTED. C LDX INTEGER. C LDX IS THE LEADING DIMENSION OF THE ARRAY X. C N INTEGER. C N IS THE NUMBER OF ROWS OF THE MATRIX X. C P INTEGER. C P IS THE NUMBER OF COLUMNS OF THE MATRIX X. C JPVT INTEGER(P). C JPVT CONTAINS INTEGERS THAT CONTROL THE SELECTION C OF THE PIVOT COLUMNS. THE K-TH COLUMN X(K) OF X C IS PLACED IN ONE OF THREE CLASSES ACCORDING TO THE C VALUE OF JPVT(K). C IF JPVT(K) .GT. 0, THEN X(K) IS AN INITIAL C COLUMN. C IF JPVT(K) .EQ. 0, THEN X(K) IS A FREE COLUMN. C IF JPVT(K) .LT. 0, THEN X(K) IS A FINAL COLUMN. C BEFORE THE DECOMPOSITION IS COMPUTED, INITIAL COLUMNS C ARE MOVED TO THE BEGINNING OF THE ARRAY X AND FINAL C COLUMNS TO THE END. BOTH INITIAL AND FINAL COLUMNS C ARE FROZEN IN PLACE DURING THE COMPUTATION AND ONLY C FREE COLUMNS ARE MOVED. AT THE K-TH STAGE OF THE C REDUCTION, IF X(K) IS OCCUPIED BY A FREE COLUMN, C IT IS INTERCHANGED WITH THE FREE COLUMN OF LARGEST C REDUCED NORM. JPVT IS NOT REFERENCED IF C JOB .EQ. 0. C WORK REAL(P). C WORK IS A WORK ARRAY. WORK IS NOT REFERENCED IF C JOB .EQ. 0. C JOB INTEGER. C JOB IS AN INTEGER THAT INITIATES COLUMN PIVOTING. C IF JOB .EQ. 0, NO PIVOTING IS DONE. C IF JOB .NE. 0, PIVOTING IS DONE. C ON RETURN C X X CONTAINS IN ITS UPPER TRIANGLE THE UPPER C TRIANGULAR MATRIX R OF THE QR FACTORIZATION. C BELOW ITS DIAGONAL X CONTAINS INFORMATION FROM C WHICH THE ORTHOGONAL PART OF THE DECOMPOSITION C CAN BE RECOVERED. NOTE THAT IF PIVOTING HAS C BEEN REQUESTED, THE DECOMPOSITION IS NOT THAT C OF THE ORIGINAL MATRIX X BUT THAT OF X C WITH ITS COLUMNS PERMUTED AS DESCRIBED BY JPVT. C QRAUX REAL(P). C QRAUX CONTAINS FURTHER INFORMATION REQUIRED TO RECOVER C THE ORTHOGONAL PART OF THE DECOMPOSITION. C JPVT JPVT(K) CONTAINS THE INDEX OF THE COLUMN OF THE C ORIGINAL MATRIX THAT HAS BEEN INTERCHANGED INTO C THE K-TH COLUMN, IF PIVOTING WAS REQUESTED. C LINPACK. THIS VERSION DATED 08/14/78 . C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SDOT,SNRM2,SSCAL,SSWAP C***END PROLOGUE SQRDC * C...SCALAR ARGUMENTS INTEGER + JOB,LDX,N,P * C...ARRAY ARGUMENTS REAL QRAUX(*),WORK(*),X(LDX,*) INTEGER + JPVT(*) * C...LOCAL SCALARS REAL MAXNRM,NRMXL,T,TT INTEGER + J,JJ,JP,L,LP1,LUP,MAXJ,PL,PU LOGICAL + NEGJ,SWAPJ * C...EXTERNAL FUNCTIONS REAL SDOT,SNRM2 EXTERNAL + SDOT,SNRM2 * C...EXTERNAL SUBROUTINES EXTERNAL + SAXPY,SSCAL,SSWAP * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,AMAX1,MIN0,SIGN,SQRT * * C***FIRST EXECUTABLE STATEMENT SQRDC * * PL = 1 PU = 0 IF (JOB .EQ. 0) GO TO 60 * C PIVOTING HAS BEEN REQUESTED. REARRANGE THE COLUMNS C ACCORDING TO JPVT. * DO 20 J = 1, P SWAPJ = JPVT(J) .GT. 0 NEGJ = JPVT(J) .LT. 0 JPVT(J) = J IF (NEGJ) JPVT(J) = -J IF (.NOT.SWAPJ) GO TO 10 IF (J .NE. PL) CALL SSWAP(N,X(1,PL),1,X(1,J),1) JPVT(J) = JPVT(PL) JPVT(PL) = J PL = PL + 1 10 CONTINUE 20 CONTINUE PU = P DO 50 JJ = 1, P J = P - JJ + 1 IF (JPVT(J) .GE. 0) GO TO 40 JPVT(J) = -JPVT(J) IF (J .EQ. PU) GO TO 30 CALL SSWAP(N,X(1,PU),1,X(1,J),1) JP = JPVT(PU) JPVT(PU) = JPVT(J) JPVT(J) = JP 30 CONTINUE PU = PU - 1 40 CONTINUE 50 CONTINUE 60 CONTINUE * C COMPUTE THE NORMS OF THE FREE COLUMNS. * IF (PU .LT. PL) GO TO 80 DO 70 J = PL, PU QRAUX(J) = SNRM2(N,X(1,J),1) WORK(J) = QRAUX(J) 70 CONTINUE 80 CONTINUE * C PERFORM THE HOUSEHOLDER REDUCTION OF X. * LUP = MIN0(N,P) DO 200 L = 1, LUP IF (L .LT. PL .OR. L .GE. PU) GO TO 120 * C LOCATE THE COLUMN OF LARGEST NORM AND BRING IT C INTO THE PIVOT POSITION. * MAXNRM = 0.0E0 MAXJ = L DO 100 J = L, PU IF (QRAUX(J) .LE. MAXNRM) GO TO 90 MAXNRM = QRAUX(J) MAXJ = J 90 CONTINUE 100 CONTINUE IF (MAXJ .EQ. L) GO TO 110 CALL SSWAP(N,X(1,L),1,X(1,MAXJ),1) QRAUX(MAXJ) = QRAUX(L) WORK(MAXJ) = WORK(L) JP = JPVT(MAXJ) JPVT(MAXJ) = JPVT(L) JPVT(L) = JP 110 CONTINUE 120 CONTINUE QRAUX(L) = 0.0E0 IF (L .EQ. N) GO TO 190 * C COMPUTE THE HOUSEHOLDER TRANSFORMATION FOR COLUMN L. * NRMXL = SNRM2(N-L+1,X(L,L),1) IF (NRMXL .EQ. 0.0E0) GO TO 180 IF (X(L,L) .NE. 0.0E0) NRMXL = SIGN(NRMXL,X(L,L)) CALL SSCAL(N-L+1,1.0E0/NRMXL,X(L,L),1) X(L,L) = 1.0E0 + X(L,L) * C APPLY THE TRANSFORMATION TO THE REMAINING COLUMNS, C UPDATING THE NORMS. * LP1 = L + 1 IF (P .LT. LP1) GO TO 170 DO 160 J = LP1, P T = -SDOT(N-L+1,X(L,L),1,X(L,J),1)/X(L,L) CALL SAXPY(N-L+1,T,X(L,L),1,X(L,J),1) IF (J .LT. PL .OR. J .GT. PU) GO TO 150 IF (QRAUX(J) .EQ. 0.0E0) GO TO 150 TT = 1.0E0 - (ABS(X(L,J))/QRAUX(J))**2 TT = AMAX1(TT,0.0E0) T = TT TT = 1.0E0 + 0.05E0*TT*(QRAUX(J)/WORK(J))**2 IF (TT .EQ. 1.0E0) GO TO 130 QRAUX(J) = QRAUX(J)*SQRT(T) GO TO 140 130 CONTINUE QRAUX(J) = SNRM2(N-L,X(L+1,J),1) WORK(J) = QRAUX(J) 140 CONTINUE 150 CONTINUE 160 CONTINUE 170 CONTINUE * C SAVE THE TRANSFORMATION. * QRAUX(L) = X(L,L) X(L,L) = -NRMXL 180 CONTINUE 190 CONTINUE 200 CONTINUE RETURN END *SQRSL SUBROUTINE SQRSL(X,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) C***BEGIN PROLOGUE SQRSL C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D9,D2A1 C***KEYWORDS LINEAR ALGEBRA,LINPACK,MATRIX,ORTHOGONAL TRIANGULAR,SOLVE C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE APPLIES THE OUTPUT OF SQRDC TO COMPUTE COORDINATE TRANS- C FORMATIONS PROJECTIONS, AND LEAST SQUARES SOLUTIONS. C***DESCRIPTION C SQRSL APPLIES THE OUTPUT OF SQRDC TO COMPUTE COORDINATE C TRANSFORMATIONS, PROJECTIONS, AND LEAST SQUARES SOLUTIONS. C FOR K .LE. MIN(N,P), LET XK BE THE MATRIX C XK = (X(JPVT(1)),X(JPVT(2)), ... ,X(JPVT(K))) C FORMED FROM COLUMNNS JPVT(1), ... ,JPVT(K) OF THE ORIGINAL C N X P MATRIX X THAT WAS INPUT TO SQRDC (IF NO PIVOTING WAS C DONE, XK CONSISTS OF THE FIRST K COLUMNS OF X IN THEIR C ORIGINAL ORDER). SQRDC PRODUCES A FACTORED ORTHOGONAL MATRIX Q C AND AN UPPER TRIANGULAR MATRIX R SUCH THAT C XK = Q * (R) C (0) C THIS INFORMATION IS CONTAINED IN CODED FORM IN THE ARRAYS C X AND QRAUX. C ON ENTRY C X REAL(LDX,P) C X CONTAINS THE OUTPUT OF SQRDC. C LDX INTEGER C LDX IS THE LEADING DIMENSION OF THE ARRAY X. C N INTEGER C N IS THE NUMBER OF ROWS OF THE MATRIX XK. IT MUST C HAVE THE SAME VALUE AS N IN SQRDC. C K INTEGER C K IS THE NUMBER OF COLUMNS OF THE MATRIX XK. K C MUST NOT BE GREATER THAN MIN(N,P), WHERE P IS THE C SAME AS IN THE CALLING SEQUENCE TO SQRDC. C QRAUX REAL(P) C QRAUX CONTAINS THE AUXILIARY OUTPUT FROM SQRDC. C Y REAL(N) C Y CONTAINS AN N-VECTOR THAT IS TO BE MANIPULATED C BY SQRSL. C JOB INTEGER C JOB SPECIFIES WHAT IS TO BE COMPUTED. JOB HAS C THE DECIMAL EXPANSION ABCDE, WITH THE FOLLOWING C MEANING. C IF A .NE. 0, COMPUTE QY. C IF B,C,D, OR E .NE. 0, COMPUTE QTY. C IF C .NE. 0, COMPUTE B. C IF D .NE. 0, COMPUTE RSD. C IF E .NE. 0, COMPUTE XB. C NOTE THAT A REQUEST TO COMPUTE B, RSD, OR XB C AUTOMATICALLY TRIGGERS THE COMPUTATION OF QTY, FOR C WHICH AN ARRAY MUST BE PROVIDED IN THE CALLING C SEQUENCE. C ON RETURN C QY REAL(N). C QY CONTAINS Q*Y, IF ITS COMPUTATION HAS BEEN C REQUESTED. C QTY REAL(N). C QTY CONTAINS TRANS(Q)*Y, IF ITS COMPUTATION HAS C BEEN REQUESTED. HERE TRANS(Q) IS THE C TRANSPOSE OF THE MATRIX Q. C B REAL(K) C B CONTAINS THE SOLUTION OF THE LEAST SQUARES PROBLEM C MINIMIZE NORM2(Y - XK*B), C IF ITS COMPUTATION HAS BEEN REQUESTED. (NOTE THAT C IF PIVOTING WAS REQUESTED IN SQRDC, THE J-TH C COMPONENT OF B WILL BE ASSOCIATED WITH COLUMN JPVT(J) C OF THE ORIGINAL MATRIX X THAT WAS INPUT INTO SQRDC.) C RSD REAL(N). C RSD CONTAINS THE LEAST SQUARES RESIDUAL Y - XK*B, C IF ITS COMPUTATION HAS BEEN REQUESTED. RSD IS C ALSO THE ORTHOGONAL PROJECTION OF Y ONTO THE C ORTHOGONAL COMPLEMENT OF THE COLUMN SPACE OF XK. C XB REAL(N). C XB CONTAINS THE LEAST SQUARES APPROXIMATION XK*B, C IF ITS COMPUTATION HAS BEEN REQUESTED. XB IS ALSO C THE ORTHOGONAL PROJECTION OF Y ONTO THE COLUMN SPACE C OF X. C INFO INTEGER. C INFO IS ZERO UNLESS THE COMPUTATION OF B HAS C BEEN REQUESTED AND R IS EXACTLY SINGULAR. IN C THIS CASE, INFO IS THE INDEX OF THE FIRST ZERO C DIAGONAL ELEMENT OF R AND B IS LEFT UNALTERED. C THE PARAMETERS QY, QTY, B, RSD, AND XB ARE NOT REFERENCED C IF THEIR COMPUTATION IS NOT REQUESTED AND IN THIS CASE C CAN BE REPLACED BY DUMMY VARIABLES IN THE CALLING PROGRAM. C TO SAVE STORAGE, THE USER MAY IN SOME CASES USE THE SAME C ARRAY FOR DIFFERENT PARAMETERS IN THE CALLING SEQUENCE. A C FREQUENTLY OCCURING EXAMPLE IS WHEN ONE WISHES TO COMPUTE C ANY OF B, RSD, OR XB AND DOES NOT NEED Y OR QTY. IN THIS C CASE ONE MAY IDENTIFY Y, QTY, AND ONE OF B, RSD, OR XB, WHILE C PROVIDING SEPARATE ARRAYS FOR ANYTHING ELSE THAT IS TO BE C COMPUTED. THUS THE CALLING SEQUENCE C CALL SQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO) C WILL RESULT IN THE COMPUTATION OF B AND RSD, WITH RSD C OVERWRITING Y. MORE GENERALLY, EACH ITEM IN THE FOLLOWING C LIST CONTAINS GROUPS OF PERMISSIBLE IDENTIFICATIONS FOR C A SINGLE CALLINNG SEQUENCE. C 1. (Y,QTY,B) (RSD) (XB) (QY) C 2. (Y,QTY,RSD) (B) (XB) (QY) C 3. (Y,QTY,XB) (B) (RSD) (QY) C 4. (Y,QY) (QTY,B) (RSD) (XB) C 5. (Y,QY) (QTY,RSD) (B) (XB) C 6. (Y,QY) (QTY,XB) (B) (RSD) C IN ANY GROUP THE VALUE RETURNED IN THE ARRAY ALLOCATED TO C THE GROUP CORRESPONDS TO THE LAST MEMBER OF THE GROUP. C LINPACK. THIS VERSION DATED 08/14/78 . C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SCOPY,SDOT C***END PROLOGUE SQRSL * C...SCALAR ARGUMENTS INTEGER + INFO,JOB,K,LDX,N * C...ARRAY ARGUMENTS REAL B(*),QRAUX(*),QTY(*),QY(*),RSD(*),X(LDX,*),XB(*),Y(*) * C...LOCAL SCALARS REAL T,TEMP INTEGER + I,J,JJ,JU,KP1 LOGICAL + CB,CQTY,CQY,CR,CXB * C...EXTERNAL FUNCTIONS REAL SDOT EXTERNAL + SDOT * C...EXTERNAL SUBROUTINES EXTERNAL + SAXPY,SCOPY * C...INTRINSIC FUNCTIONS INTRINSIC + MIN0,MOD * * C***FIRST EXECUTABLE STATEMENT SQRSL * * C SET INFO FLAG. * INFO = 0 * C DETERMINE WHAT IS TO BE COMPUTED. * CQY = JOB/10000 .NE. 0 CQTY = MOD(JOB,10000) .NE. 0 CB = MOD(JOB,1000)/100 .NE. 0 CR = MOD(JOB,100)/10 .NE. 0 CXB = MOD(JOB,10) .NE. 0 JU = MIN0(K,N-1) * C SPECIAL ACTION WHEN N=1. * IF (JU .NE. 0) GO TO 40 IF (CQY) QY(1) = Y(1) IF (CQTY) QTY(1) = Y(1) IF (CXB) XB(1) = Y(1) IF (.NOT.CB) GO TO 30 IF (X(1,1) .NE. 0.0E0) GO TO 10 INFO = 1 GO TO 20 10 CONTINUE B(1) = Y(1)/X(1,1) 20 CONTINUE 30 CONTINUE IF (CR) RSD(1) = 0.0E0 GO TO 250 40 CONTINUE * C SET UP TO COMPUTE QY OR QTY. * IF (CQY) CALL SCOPY(N,Y,1,QY,1) IF (CQTY) CALL SCOPY(N,Y,1,QTY,1) IF (.NOT.CQY) GO TO 70 * C COMPUTE QY. * DO 60 JJ = 1, JU J = JU - JJ + 1 IF (QRAUX(J) .EQ. 0.0E0) GO TO 50 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -SDOT(N-J+1,X(J,J),1,QY(J),1)/X(J,J) CALL SAXPY(N-J+1,T,X(J,J),1,QY(J),1) X(J,J) = TEMP 50 CONTINUE 60 CONTINUE 70 CONTINUE IF (.NOT.CQTY) GO TO 100 * C COMPUTE TRANS(Q)*Y. * DO 90 J = 1, JU IF (QRAUX(J) .EQ. 0.0E0) GO TO 80 TEMP = X(J,J) X(J,J) = QRAUX(J) T = -SDOT(N-J+1,X(J,J),1,QTY(J),1)/X(J,J) CALL SAXPY(N-J+1,T,X(J,J),1,QTY(J),1) X(J,J) = TEMP 80 CONTINUE 90 CONTINUE 100 CONTINUE * C SET UP TO COMPUTE B, RSD, OR XB. * IF (CB) CALL SCOPY(K,QTY,1,B,1) KP1 = K + 1 IF (CXB) CALL SCOPY(K,QTY,1,XB,1) IF (CR .AND. K .LT. N) CALL SCOPY(N-K,QTY(KP1),1,RSD(KP1),1) IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120 DO 110 I = KP1, N XB(I) = 0.0E0 110 CONTINUE 120 CONTINUE IF (.NOT.CR) GO TO 140 DO 130 I = 1, K RSD(I) = 0.0E0 130 CONTINUE 140 CONTINUE IF (.NOT.CB) GO TO 190 * C COMPUTE B. * DO 170 JJ = 1, K J = K - JJ + 1 IF (X(J,J) .NE. 0.0E0) GO TO 150 INFO = J C ......EXIT GO TO 180 150 CONTINUE B(J) = B(J)/X(J,J) IF (J .EQ. 1) GO TO 160 T = -B(J) CALL SAXPY(J-1,T,X(1,J),1,B,1) 160 CONTINUE 170 CONTINUE 180 CONTINUE 190 CONTINUE IF (.NOT.CR .AND. .NOT.CXB) GO TO 240 * C COMPUTE RSD OR XB AS REQUIRED. * DO 230 JJ = 1, JU J = JU - JJ + 1 IF (QRAUX(J) .EQ. 0.0E0) GO TO 220 TEMP = X(J,J) X(J,J) = QRAUX(J) IF (.NOT.CR) GO TO 200 T = -SDOT(N-J+1,X(J,J),1,RSD(J),1)/X(J,J) CALL SAXPY(N-J+1,T,X(J,J),1,RSD(J),1) 200 CONTINUE IF (.NOT.CXB) GO TO 210 T = -SDOT(N-J+1,X(J,J),1,XB(J),1)/X(J,J) CALL SAXPY(N-J+1,T,X(J,J),1,XB(J),1) 210 CONTINUE X(J,J) = TEMP 220 CONTINUE 230 CONTINUE 240 CONTINUE 250 CONTINUE RETURN END *SROT SUBROUTINE SROT(N,SX,INCX,SY,INCY,SC,SS) C***BEGIN PROLOGUE SROT C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A8 C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE APPLY S.P. GIVENS ROTATION C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C SX SINGLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF SX C SY SINGLE PRECISION VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF SY C SC ELEMENT OF ROTATION MATRIX C SS ELEMENT OF ROTATION MATRIX C --OUTPUT-- C SX ROTATED VECTOR SX (UNCHANGED IF N .LE. 0) C SY ROTATED VECTOR SY (UNCHANGED IF N .LE. 0) C MULTIPLY THE 2 X 2 MATRIX ( SC SS) TIMES THE 2 X N MATRIX (SX**T) C (-SS SC) (SY**T) C WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN C SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE C LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE SROT * C...SCALAR ARGUMENTS REAL SC,SS INTEGER + INCX,INCY,N * C...ARRAY ARGUMENTS REAL SX(*),SY(*) * C...LOCAL SCALARS REAL ONE,W,Z,ZERO INTEGER + I,KX,KY,NSTEPS * C...DATA STATEMENTS DATA + ZERO,ONE/0.E0,1.E0/ * * C***FIRST EXECUTABLE STATEMENT SROT * * IF(N .LE. 0 .OR. (SS .EQ. ZERO .AND. SC .EQ. ONE)) GO TO 40 IF(.NOT. (INCX .EQ. INCY .AND. INCX .GT. 0)) GO TO 20 * NSTEPS=INCX*N DO 10 I=1,NSTEPS,INCX W=SX(I) Z=SY(I) SX(I)=SC*W+SS*Z SY(I)=-SS*W+SC*Z 10 CONTINUE GO TO 40 * 20 CONTINUE KX=1 KY=1 * IF(INCX .LT. 0) KX=1-(N-1)*INCX IF(INCY .LT. 0) KY=1-(N-1)*INCY * DO 30 I=1,N W=SX(KX) Z=SY(KY) SX(KX)=SC*W+SS*Z SY(KY)=-SS*W+SC*Z KX=KX+INCX KY=KY+INCY 30 CONTINUE 40 CONTINUE * RETURN END *SROTG SUBROUTINE SROTG(SA,SB,SC,SS) C***BEGIN PROLOGUE SROTG C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1B10 C***KEYWORDS BLAS,GIVENS ROTATION,LINEAR ALGEBRA,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE CONSTRUCT S.P. PLANE GIVENS ROTATION C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C SA SINGLE PRECISION SCALAR C SB SINGLE PRECISION SCALAR C --OUTPUT-- C SA SINGLE PRECISION RESULT R C SB SINGLE PRECISION RESULT Z C SC SINGLE PRECISION RESULT C SS SINGLE PRECISION RESULT C DESIGNED BY C. L. LAWSON, JPL, 1977 SEPT 08 C CONSTRUCT THE GIVENS TRANSFORMATION C ( SC SS ) C G = ( ) , SC**2 + SS**2 = 1 , C (-SS SC ) C WHICH ZEROS THE SECOND ENTRY OF THE 2-VECTOR (SA,SB)**T. C THE QUANTITY R = (+/-)SQRT(SA**2 + SB**2) OVERWRITES SA IN C STORAGE. THE VALUE OF SB IS OVERWRITTEN BY A VALUE Z WHICH C ALLOWS SC AND SS TO BE RECOVERED BY THE FOLLOWING ALGORITHM@D C IF Z=1 SET SC=0. AND SS=1. C IF ABS(Z) .LT. 1 SET SC=SQRT(1-Z**2) AND SS=Z C IF ABS(Z) .GT. 1 SET SC=1/Z AND SS=SQRT(1-SC**2) C NORMALLY, THE SUBPROGRAM SROT(N,SX,INCX,SY,INCY,SC,SS) WILL C NEXT BE CALLED TO APPLY THE TRANSFORMATION TO A 2 BY N MATRIX. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE SROTG * C...SCALAR ARGUMENTS REAL SA,SB,SC,SS * C...LOCAL SCALARS REAL R,U,V * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,SQRT * * C***FIRST EXECUTABLE STATEMENT SROTG * * IF (ABS(SA) .LE. ABS(SB)) GO TO 10 * C *** HERE ABS(SA) .GT. ABS(SB) *** * U = SA + SA V = SB / U * C NOTE THAT U AND R HAVE THE SIGN OF SA * R = SQRT(.25 + V**2) * U * C NOTE THAT SC IS POSITIVE * SC = SA / R SS = V * (SC + SC) SB = SS SA = R RETURN * C *** HERE ABS(SA) .LE. ABS(SB) *** * 10 IF (SB .EQ. 0.) GO TO 20 U = SB + SB V = SA / U * C NOTE THAT U AND R HAVE THE SIGN OF SB C (R IS IMMEDIATELY STORED IN SA) * SA = SQRT(.25 + V**2) * U * C NOTE THAT SS IS POSITIVE * SS = SB / SA SC = V * (SS + SS) IF (SC .EQ. 0.) GO TO 15 SB = 1. / SC RETURN 15 SB = 1. RETURN * C *** HERE SA = SB = 0. *** * 20 SC = 1. SS = 0. RETURN * END *SSCAL SUBROUTINE SSCAL(N,SA,SX,INCX) C***BEGIN PROLOGUE SSCAL C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A6 C***KEYWORDS BLAS,LINEAR ALGEBRA,SCALE,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE S.P. VECTOR SCALE X = A*X C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C SA SINGLE PRECISION SCALE FACTOR C SX SINGLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF SX C --OUTPUT-- C SX SINGLE PRECISION RESULT (UNCHANGED IF N .LE. 0) C REPLACE SINGLE PRECISION SX BY SINGLE PRECISION SA*SX. C FOR I = 0 TO N-1, REPLACE SX(1+I*INCX) WITH SA * SX(1+I*INCX) C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE SSCAL * C...SCALAR ARGUMENTS REAL SA INTEGER + INCX,N * C...ARRAY ARGUMENTS REAL SX(*) * C...LOCAL SCALARS INTEGER + I,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT SSCAL * * IF(N.LE.0)RETURN IF(INCX.EQ.1)GOTO 20 * C CODE FOR INCREMENTS NOT EQUAL TO 1. * NS = N*INCX DO 10 I = 1,NS,INCX SX(I) = SA*SX(I) 10 CONTINUE RETURN * C CODE FOR INCREMENTS EQUAL TO 1. * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5. * 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M SX(I) = SA*SX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 SX(I) = SA*SX(I) SX(I + 1) = SA*SX(I + 1) SX(I + 2) = SA*SX(I + 2) SX(I + 3) = SA*SX(I + 3) SX(I + 4) = SA*SX(I + 4) 50 CONTINUE RETURN END *SSWAP SUBROUTINE SSWAP(N,SX,INCX,SY,INCY) C***BEGIN PROLOGUE SSWAP C***DATE WRITTEN 791001 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D1A5 C***KEYWORDS BLAS,INTERCHANGE,LINEAR ALGEBRA,VECTOR C***AUTHOR LAWSON, C. L., (JPL) C HANSON, R. J., (SNLA) C KINCAID, D. R., (U. OF TEXAS) C KROGH, F. T., (JPL) C***PURPOSE INTERCHANGE S.P VECTORS C***DESCRIPTION C B L A S SUBPROGRAM C DESCRIPTION OF PARAMETERS C --INPUT-- C N NUMBER OF ELEMENTS IN INPUT VECTOR(S) C SX SINGLE PRECISION VECTOR WITH N ELEMENTS C INCX STORAGE SPACING BETWEEN ELEMENTS OF SX C SY SINGLE PRECISION VECTOR WITH N ELEMENTS C INCY STORAGE SPACING BETWEEN ELEMENTS OF SY C --OUTPUT-- C SX INPUT VECTOR SY (UNCHANGED IF N .LE. 0) C SY INPUT VECTOR SX (UNCHANGED IF N .LE. 0) C INTERCHANGE SINGLE PRECISION SX AND SINGLE PRECISION SY. C FOR I = 0 TO N-1, INTERCHANGE SX(LX+I*INCX) AND SY(LY+I*INCY), C WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS C DEFINED IN A SIMILAR WAY USING INCY. C***REFERENCES LAWSON C.L., HANSON R.J., KINCAID D.R., KROGH F.T., C *BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE*, C ALGORITHM NO. 539, TRANSACTIONS ON MATHEMATICAL C SOFTWARE, VOLUME 5, NUMBER 3, SEPTEMBER 1979, 308-323 C***ROUTINES CALLED (NONE) C***END PROLOGUE SSWAP * C...SCALAR ARGUMENTS INTEGER + INCX,INCY,N * C...ARRAY ARGUMENTS REAL SX(*),SY(*) * C...LOCAL SCALARS REAL STEMP1,STEMP2,STEMP3 INTEGER + I,IX,IY,M,MP1,NS * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT SSWAP * * IF(N.LE.0)RETURN IF(INCX.EQ.INCY) IF(INCX-1) 5,20,60 5 CONTINUE * C CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS. * IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N STEMP1 = SX(IX) SX(IX) = SY(IY) SY(IY) = STEMP1 IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN * C CODE FOR BOTH INCREMENTS EQUAL TO 1 * * C CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 3. * 20 M = MOD(N,3) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M STEMP1 = SX(I) SX(I) = SY(I) SY(I) = STEMP1 30 CONTINUE IF( N .LT. 3 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 STEMP1 = SX(I) STEMP2 = SX(I+1) STEMP3 = SX(I+2) SX(I) = SY(I) SX(I+1) = SY(I+1) SX(I+2) = SY(I+2) SY(I) = STEMP1 SY(I+1) = STEMP2 SY(I+2) = STEMP3 50 CONTINUE RETURN 60 CONTINUE * C CODE FOR EQUAL, POSITIVE, NONUNIT INCREMENTS. * NS = N*INCX DO 70 I=1,NS,INCX STEMP1 = SX(I) SX(I) = SY(I) SY(I) = STEMP1 70 CONTINUE RETURN END *STRCO SUBROUTINE STRCO(T,LDT,N,RCOND,Z,JOB) C***BEGIN PROLOGUE STRCO C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A3 C***KEYWORDS CONDITION,FACTOR,LINEAR ALGEBRA,LINPACK,MATRIX,TRIANGULAR C***AUTHOR MOLER, C. B., (U. OF NEW MEXICO) C***PURPOSE ESTIMATES THE CONDITION OF A REAL TRIANGULAR MATRIX. C***DESCRIPTION C STRCO ESTIMATES THE CONDITION OF A REAL TRIANGULAR MATRIX. C ON ENTRY C T REAL(LDT,N) C T CONTAINS THE TRIANGULAR MATRIX. THE ZERO C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE C USED TO STORE OTHER INFORMATION. C LDT INTEGER C LDT IS THE LEADING DIMENSION OF THE ARRAY T. C N INTEGER C N IS THE ORDER OF THE SYSTEM. C JOB INTEGER C = 0 T IS LOWER TRIANGULAR. C = NONZERO T IS UPPER TRIANGULAR. C ON RETURN C RCOND REAL C AN ESTIMATE OF THE RECIPROCAL CONDITION OF T . C FOR THE SYSTEM T*X = B , RELATIVE PERTURBATIONS C IN T AND B OF SIZE EPSILON MAY CAUSE C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION C 1.0 + RCOND .EQ. 1.0 C IS TRUE, THEN T MAY BE SINGULAR TO WORKING C PRECISION. IN PARTICULAR, RCOND IS ZERO IF C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE C UNDERFLOWS. C Z REAL(N) C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. C IF T IS CLOSE TO A SINGULAR MATRIX, THEN Z IS C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SASUM,SAXPY,SSCAL C***END PROLOGUE STRCO * C...SCALAR ARGUMENTS REAL RCOND INTEGER + JOB,LDT,N * C...ARRAY ARGUMENTS REAL T(LDT,*),Z(*) * C...LOCAL SCALARS REAL EK,S,SM,TNORM,W,WK,WKM,YNORM INTEGER + I1,J,J1,J2,K,KK,L LOGICAL + LOWER * C...EXTERNAL FUNCTIONS REAL SASUM EXTERNAL + SASUM * C...EXTERNAL SUBROUTINES EXTERNAL + SAXPY,SSCAL * C...INTRINSIC FUNCTIONS INTRINSIC + ABS,AMAX1,SIGN * * C***FIRST EXECUTABLE STATEMENT STRCO * * LOWER = JOB .EQ. 0 * C COMPUTE 1-NORM OF T * TNORM = 0.0E0 DO 10 J = 1, N L = J IF (LOWER) L = N + 1 - J I1 = 1 IF (LOWER) I1 = J TNORM = AMAX1(TNORM,SASUM(L,T(I1,J),1)) 10 CONTINUE * C RCOND = 1/(NORM(T)*(ESTIMATE OF NORM(INVERSE(T)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE T*Z = Y AND TRANS(T)*Y = E . C TRANS(T) IS THE TRANSPOSE OF T . C THE COMPONENTS OF E ARE CHOSEN TO CAUSE MAXIMUM LOCAL C GROWTH IN THE ELEMENTS OF Y . C THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW. * C SOLVE TRANS(T)*Y = E * EK = 1.0E0 DO 20 J = 1, N Z(J) = 0.0E0 20 CONTINUE DO 100 KK = 1, N K = KK IF (LOWER) K = N + 1 - KK IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,-Z(K)) IF (ABS(EK-Z(K)) .LE. ABS(T(K,K))) GO TO 30 S = ABS(T(K,K))/ABS(EK-Z(K)) CALL SSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) IF (T(K,K) .EQ. 0.0E0) GO TO 40 WK = WK/T(K,K) WKM = WKM/T(K,K) GO TO 50 40 CONTINUE WK = 1.0E0 WKM = 1.0E0 50 CONTINUE IF (KK .EQ. N) GO TO 90 J1 = K + 1 IF (LOWER) J1 = 1 J2 = N IF (LOWER) J2 = K - 1 DO 60 J = J1, J2 SM = SM + ABS(Z(J)+WKM*T(K,J)) Z(J) = Z(J) + WK*T(K,J) S = S + ABS(Z(J)) 60 CONTINUE IF (S .GE. SM) GO TO 80 W = WKM - WK WK = WKM DO 70 J = J1, J2 Z(J) = Z(J) + W*T(K,J) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) * YNORM = 1.0E0 * C SOLVE T*Z = Y * DO 130 KK = 1, N K = N + 1 - KK IF (LOWER) K = KK IF (ABS(Z(K)) .LE. ABS(T(K,K))) GO TO 110 S = ABS(T(K,K))/ABS(Z(K)) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM 110 CONTINUE IF (T(K,K) .NE. 0.0E0) Z(K) = Z(K)/T(K,K) IF (T(K,K) .EQ. 0.0E0) Z(K) = 1.0E0 I1 = 1 IF (LOWER) I1 = K + 1 IF (KK .GE. N) GO TO 120 W = -Z(K) CALL SAXPY(N-KK,W,T(I1,K),1,Z(I1),1) 120 CONTINUE 130 CONTINUE C MAKE ZNORM = 1.0 S = 1.0E0/SASUM(N,Z,1) CALL SSCAL(N,S,Z,1) YNORM = S*YNORM * IF (TNORM .NE. 0.0E0) RCOND = YNORM/TNORM IF (TNORM .EQ. 0.0E0) RCOND = 0.0E0 RETURN END *STRSL SUBROUTINE STRSL(T,LDT,N,B,JOB,INFO) C***BEGIN PROLOGUE STRSL C***DATE WRITTEN 780814 (YYMMDD) C***REVISION DATE 820801 (YYMMDD) C***CATEGORY NO. D2A3 C***KEYWORDS LINEAR ALGEBRA,LINPACK,MATRIX,SOLVE,TRIANGULAR C***AUTHOR STEWART, G. W., (U. OF MARYLAND) C***PURPOSE SOLVES SYSTEMS OF THE FORM T*X=B OR TRANS(T)*X=B C WHERE T IS A TRIANGULAR MATRIX OF ORDER N. C***DESCRIPTION C STRSL SOLVES SYSTEMS OF THE FORM C T * X = B C OR C TRANS(T) * X = B C WHERE T IS A TRIANGULAR MATRIX OF ORDER N. HERE TRANS(T) C DENOTES THE TRANSPOSE OF THE MATRIX T. C ON ENTRY C T REAL(LDT,N) C T CONTAINS THE MATRIX OF THE SYSTEM. THE ZERO C ELEMENTS OF THE MATRIX ARE NOT REFERENCED, AND C THE CORRESPONDING ELEMENTS OF THE ARRAY CAN BE C USED TO STORE OTHER INFORMATION. C LDT INTEGER C LDT IS THE LEADING DIMENSION OF THE ARRAY T. C N INTEGER C N IS THE ORDER OF THE SYSTEM. C B REAL(N). C B CONTAINS THE RIGHT HAND SIDE OF THE SYSTEM. C JOB INTEGER C JOB SPECIFIES WHAT KIND OF SYSTEM IS TO BE SOLVED. C IF JOB IS C 00 SOLVE T*X=B, T LOWER TRIANGULAR, C 01 SOLVE T*X=B, T UPPER TRIANGULAR, C 10 SOLVE TRANS(T)*X=B, T LOWER TRIANGULAR, C 11 SOLVE TRANS(T)*X=B, T UPPER TRIANGULAR. C ON RETURN C B B CONTAINS THE SOLUTION, IF INFO .EQ. 0. C OTHERWISE B IS UNALTERED. C INFO INTEGER C INFO CONTAINS ZERO IF THE SYSTEM IS NONSINGULAR. C OTHERWISE INFO CONTAINS THE INDEX OF C THE FIRST ZERO DIAGONAL ELEMENT OF T. C LINPACK. THIS VERSION DATED 08/14/78 . C G. W. STEWART, UNIVERSITY OF MARYLAND, ARGONNE NATIONAL LAB. C***REFERENCES DONGARRA J.J., BUNCH J.R., MOLER C.B., STEWART G.W., C *LINPACK USERS GUIDE*, SIAM, 1979. C***ROUTINES CALLED SAXPY,SDOT C***END PROLOGUE STRSL * C...SCALAR ARGUMENTS INTEGER + INFO,JOB,LDT,N * C...ARRAY ARGUMENTS REAL B(*),T(LDT,*) * C...LOCAL SCALARS REAL TEMP INTEGER + CASE,J,JJ * C...EXTERNAL FUNCTIONS REAL SDOT EXTERNAL + SDOT * C...EXTERNAL SUBROUTINES EXTERNAL + SAXPY * C...INTRINSIC FUNCTIONS INTRINSIC + MOD * * C***FIRST EXECUTABLE STATEMENT STRSL * * C BEGIN BLOCK PERMITTING ...EXITS TO 150 * C CHECK FOR ZERO DIAGONAL ELEMENTS. * DO 10 INFO = 1, N C ......EXIT IF (T(INFO,INFO) .EQ. 0.0E0) GO TO 150 10 CONTINUE INFO = 0 * C DETERMINE THE TASK AND GO TO IT. * CASE = 1 IF (MOD(JOB,10) .NE. 0) CASE = 2 IF (MOD(JOB,100)/10 .NE. 0) CASE = CASE + 2 GO TO (20,50,80,110), CASE * C SOLVE T*X=B FOR T LOWER TRIANGULAR * 20 CONTINUE B(1) = B(1)/T(1,1) IF (N .LT. 2) GO TO 40 DO 30 J = 2, N TEMP = -B(J-1) CALL SAXPY(N-J+1,TEMP,T(J,J-1),1,B(J),1) B(J) = B(J)/T(J,J) 30 CONTINUE 40 CONTINUE GO TO 140 * C SOLVE T*X=B FOR T UPPER TRIANGULAR. * 50 CONTINUE B(N) = B(N)/T(N,N) IF (N .LT. 2) GO TO 70 DO 60 JJ = 2, N J = N - JJ + 1 TEMP = -B(J+1) CALL SAXPY(J,TEMP,T(1,J+1),1,B(1),1) B(J) = B(J)/T(J,J) 60 CONTINUE 70 CONTINUE GO TO 140 * C SOLVE TRANS(T)*X=B FOR T LOWER TRIANGULAR. * 80 CONTINUE B(N) = B(N)/T(N,N) IF (N .LT. 2) GO TO 100 DO 90 JJ = 2, N J = N - JJ + 1 B(J) = B(J) - SDOT(JJ-1,T(J+1,J),1,B(J+1),1) B(J) = B(J)/T(J,J) 90 CONTINUE 100 CONTINUE GO TO 140 * C SOLVE TRANS(T)*X=B FOR T UPPER TRIANGULAR. * 110 CONTINUE B(1) = B(1)/T(1,1) IF (N .LT. 2) GO TO 130 DO 120 J = 2, N B(J) = B(J) - SDOT(J-1,T(1,J),1,B(1),1) B(J) = B(J)/T(J,J) 120 CONTINUE 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END *SMPREC REAL FUNCTION SMPREC() C***BEGIN PROLOGUE SPREC C***REFER TO SODR,SODRC C***ROUTINES CALLED (NONE) C***DATE WRITTEN 860529 (YYMMDD) C***REVISION DATE 890530 (YYMMDD) C***CATEGORY NO. G2E,I1B1 C***KEYWORDS ORTHOGONAL DISTANCE REGRESSION, C NONLINEAR LEAST SQUARES, C MEASUREMENT ERROR MODELS, C ERRORS IN VARIABLES C***AUTHOR BOGGS, PAUL T. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C GAITHERSBURG, MD 20899 C BYRD, RICHARD H. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C DONALDSON, JANET R. C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C SCHNABEL, ROBERT B. C DEPARTMENT OF COMPUTER SCIENCE C UNIVERSITY OF COLORADO C BOULDER, CO 80309 C AND C APPLIED AND COMPUTATIONAL MATHEMATICS DIVISION C NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY C BOULDER, CO 80303-3328 C***PURPOSE DETERMINE MACHINE PRECISION FOR TARGET MACHINE AND COMPILER C ASSUMING FLOATING-POINT NUMBERS ARE REPRESENTED IN THE C T-DIGIT, BASE-B FORM C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, AND C 0 .LT. X(1). C TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE, C EITHER C ACTIVATE THE DESIRED SET OF DATA STATEMENTS BY C REMOVING THE C FROM COLUMN 1 C OR C SET B, TD AND TS USING I1MACH BY ACTIVATING C THE DECLARATION STATEMENTS FOR I1MACH C AND THE STATEMENTS PRECEEDING THE FIRST C EXECUTABLE STATEMENT BELOW. C***END PROLOGUE SPREC * C...LOCAL SCALARS REAL + B INTEGER + TD,TS * C...EXTERNAL FUNCTIONS C INTEGER C + I1MACH C EXTERNAL C + I1MACH * C...VARIABLE DEFINITIONS (ALPHABETICALLY) * C REAL B C THE BASE OF THE TARGET MACHINE. C (MAY BE DEFINED USING I1MACH(10).) C INTEGER TD C THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION. C (MAY BE DEFINED USING I1MACH(14).) C INTEGER TS C THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION. C (MAY BE DEFINED USING I1MACH(11).) * * C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. C DATA B / 2 / C DATA TS / 24 / C DATA TD / 60 / * C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM C THE BURROUGHS 6700/7700 SYSTEMS C DATA B / 8 / C DATA TS / 13 / C DATA TD / 26 / * C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN5 COMPILER) C THE CYBER 170/180 SERIES UNDER NOS C DATA B / 2 / C DATA TS / 48 / C DATA TD / 96 / * C MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN COMPILER) C THE CYBER 170/180 SERIES UNDER NOS/VE C THE CYBER 200 SERIES C DATA B / 2 / C DATA TS / 47 / C DATA TD / 94 / * C MACHINE CONSTANTS FOR THE CRAY 1 C DATA B / 2 / C DATA TS / 47 / C DATA TD / 94 / * C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * C MACHINE CONSTANTS FOR THE HARRIS COMPUTER C DATA B / 2 / C DATA TS / 23 / C DATA TD / 38 / * C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 C THE HONEYWELL 600/6000 SERIES C DATA B / 2 / C DATA TS / 27 / C DATA TD / 63 / * C MACHINE CONSTANTS FOR THE HP 2100 C (3 WORD DOUBLE PRECISION OPTION WITH FTN4) C DATA B / 2 / C DATA TS / 23 / C DATA TD / 39 / * C MACHINE CONSTANTS FOR THE HP 2100 C (4 WORD DOUBLE PRECISION OPTION WITH FTN4) C DATA B / 2 / C DATA TS / 23 / C DATA TD / 55 / * C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * C MACHINE CONSTANTS FOR THE IBM PC C DATA B / 2 / C DATA TS / 24 / C DATA TD / 53 / * C MACHINE CONSTANTS FOR THE INTERDATA (PERKIN ELMER) 7/32 C INTERDATA (PERKIN ELMER) 8/32 C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). C DATA B / 2 / C DATA TS / 27 / C DATA TD / 54 / * C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). C DATA B / 2 / C DATA TS / 27 / C DATA TD / 62 / * C MACHINE CONSTANTS FOR THE PDP-11 SYSTEM C DATA B / 2 / C DATA TS / 24 / C DATA TD / 56 / * C MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230 C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * C MACHINE CONSTANTS FOR THE PRIME 850 AND PRIME 4050 C DATA B / 2 / C DATA TS / 23 / C DATA TD / 47 / * C MACHINE CONSTANTS FOR THE SEL SYSTEMS 85/86 C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * C MACHINE CONSTANTS FOR SUN 3 C DATA B / 2 / C DATA TS / 24 / C DATA TD / 53 / * C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C DATA B / 2 / C DATA TS / 27 / C DATA TD / 60 / * C MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS COMPILER C DATA B / 2 / C DATA TS / 24 / C DATA TD / 56 / * C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITHOUT G_FLOATING C DATA B / 2 / C DATA TS / 24 / C DATA TD / 56 / * C MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITH G_FLOATING C DATA B / 2 / C DATA TS / 24 / C DATA TD / 53 / * C MACHINE CONSTANTS FOR THE XEROX SIGMA 5/7/9 C DATA B / 16 / C DATA TS / 6 / C DATA TD / 14 / * * C***FIRST EXECUTABLE STATEMENT SMPREC * * C B = I1MACH(10) C TS = I1MACH(11) C TD = I1MACH(14) * SMPREC = B ** (1-TS) * RETURN * END